[Haskell-cafe] Seeking code review

[Justin Bailey]

Fellow Haskellers,

I've been working on a library designed to make building simple
line-based command line scripts easy and straightforward for some time
now. To that end, before I release it I'd like feedback on the code
and its design. I've pasted the library below. Unfortunately I had to
leave off the documentation and QuickCheck properties as they went
over the size limit.

Some simple programs that can be built using the library include guess
a number (use as "play_game guess_num_fun"):

guess_num_fun =
      do
        target <- reqIO $ getStdRandom (randomR (1::Integer,100))
        let guessed val =
              case compare target val of
                GT -> do { reqIO $ putStrLn "Too low!"; return False }
                LT -> do { reqIO $ putStrLn "Too high!"; return False }
                EQ -> do { reqIO $ putStrLn "You win!"; return True }
        reqUntil guessed (prompt "Enter a number between 1 and 100: "
reqInteger)

play_game game = execReq game

Or the ability to collect structured values (use with "getTaxpayer
reqTaxpayerEasy")

data Taxpayer = Taxpayer { name :: String, age :: Int, ssn :: String }
 deriving (Read, Show)

reqTaxpayerEasy :: Request Taxpayer
reqTaxpayerEasy =
  do
    name <- prompt "Please enter the tax payer's name: " reqResp
    age <- prompt "Please enter their age: " reqInt
    ssn <- prompt "What is their SSN/ASN: " reqResp
    return (Taxpayer name age ssn)

getTaxpayer which =
  execReq $
    do
      peon <- which
      reqIO $ putStrLn $ "You entered: " ++ show peon

You can also build simple menus (use with "pim"):

topMenu = reqMenu $
  ("Manage contacts", reqCont manageContactsMenu topMenu) :
  ("Manage calendar", reqCont manageCalendarMenu topMenu) : []

manageContactsMenu = reqMenu $
  ("Add a contact", undefined) :
  ("Remove a contact", undefined) :
  ("Return to previous menu", reqFail) :[]

manageCalendarMenu = reqMenu $
 ("Add an event", undefined) :
 ("Remove an event", undefined) :
 ("List events", undefined) :
 ("Return to previous menu", reqFail) : []

pim =
  execReq $ reqForever topMenu

Except for the examples above, this email is literate haskell if
anyone wishes to play with the code.

Thanks in advance for any and all feedback! Feel free to contact me if
you'd like more examples or the "real" file.

Justin

--- cut here ----

\begin{code}
module HCL
(
-- * Request type and related functions.
  Request,
  runRequest, execReq, reqIO, makeReq,
-- * Request building blocks
  reqResp, reqInteger, reqInt, reqRead,
-- * Functions lifted into Requests
  andReq, orReq, notReq, reqIf, reqConst, reqLift, reqLift2,
  reqMaybe,
-- * Higher-level Request combinators
  reqAgree, reqFail, required, reqUntil, reqWhile, reqDefault, reqForever,
  reqChoices, reqMenu, reqIterate, reqCont, reqWhich, reqFoldl,
  reqList,
-- * Prompting
  prompt, promptWithDefault, promptAgree
) where

import Data.Char (isSpace, toLower, isPrint)
import System.IO (hFlush, stdout)
import Test.QuickCheck
import System.IO.Unsafe (unsafePerformIO)
import System.Random
import Data.Maybe (isNothing, isJust)

{- |
The Request data type represents a value requested interactively. The
request may have failed or been no response, in which case the request
fails. Otherwise, the request holds the response given. -}
data Request a = Request (IO (Maybe a))

{- |
Runs a request, throws away the result, and
returns an IO type (rather than a Request). Useful when a request
should just be run and we don't care about the result. Generally used at the top
level to evaluate a request in main. -}
execReq :: Request a -- ^ Request to run.
           -> IO () -- ^ No meaningful value is returned.
execReq (Request req) =
  do
    result <- req
    maybe (return ()) (\_ -> return ()) result

-- | Extracts the value from a given request.
runRequest :: Request a  -- ^ The request to evaluate.
              -> IO (Maybe a) -- ^ Result of the request.
runRequest (Request r) = r

{- |
Allows IO operations in the Request
type. Same as liftIO in MonadIO class (in Control.Monad.Trans module) -}
reqIO :: IO a -- ^ IO action to perform
         -> Request a -- ^ Result of the IO action, as a Request.
reqIO io = Request ioVal
  where
    ioVal =
      do
        val <- io
        return $ Just val

{- |
Request behavior as a Monad covers failure - when
a request results in Nothing, all bind
operations fail afterwards. Thus, when one request fails,
all subsequent requests automatically fail. -}
instance Monad Request where
  return x = makeReq x
  f >>= g = f `andMaybe` g


{- |
Takes a value and makes it into a request. Should
not be an IO (Maybe a) type value, unless
multiply nested values is desired. -}
makeReq :: a -- ^ The value to turn into a Request.
           -> Request a -- ^ The value as a Request.
makeReq val = Request (return $ Just val)

{- |
If the request given results in Nothing, Nothing
is returned. Otherwise, the value held in the Just
constructor is passed to the "next" function given. This is essentially
the bind operation. -}
andMaybe :: Request a -- ^ Request to try.
            -> (a -> Request b) -- ^ Function which processes the
result of the previous request and returns a new request.
            -> Request b -- ^ The new request returned.
andMaybe (Request req) next =
  Request $
  do
    v <- req
    case v of
        Nothing -> return Nothing
        Just x  -> nextReqVal
          where
            Request nextReqVal = next x

{- |
The basic request - get a string from the user. If a newline or all whitespace
is entered, the request is assumed to be a failure. -}
-- Read a string from the user.
reqResp :: Request String
reqResp =
  Request $
  do
    val <- getLine
    if all isSpace val
     then return Nothing
     else return $ Just val

{- |
Gets an Integer from the user. If the value entered cannot be converted,
the request fails. -}
reqInteger :: Request Integer
reqInteger = reqRead reqResp

{- |
Gets an Int from the user. If the value entered cannot be converted, the
request fails. -}
reqInt :: Request Int
reqInt = reqRead reqResp

{- |
Uses reads to process a request. If the value cannot be parsed,
fails. Otherwise, returns the value parsed. -}
reqRead :: (Read a) => Request String -- ^ A request that returns a
string (generally 'reqResp'), which will then be parsed.
           -> Request a -- ^ The value parsed.
reqRead req =
  req `andMaybe` \val ->
    Request $
    do
      case reads val of
        []          -> return Nothing
        ((v, _):[]) -> return $ Just v
        _           -> return Nothing


{- |
&& operator for requests (with failure). Behaves similarly, including
"short-circuit" behavior. If either condition fails, the entire Request
fails. -}
andReq :: Request Bool -- ^ Left boolean value.
          -> Request Bool -- ^ Right boolean value.
          -> Request Bool -- ^ Result value.
andReq left right =
      left `andMaybe` \lb ->
      Request $
        case lb of
          False -> return $ Just False
          True  -> runRequest right

{- |
|| operator for requests (with failure). Behaves similarly, including
"short-circuit" behavior. If either condition fails, the entire Request
fails. -}
orReq :: Request Bool -- ^ Left boolean value.
         -> Request Bool -- ^ Right boolean value.
         -> Request Bool -- ^ Result value.
orReq left right =
    left `andMaybe` \lb ->
    Request $
      case lb of
          True -> return (Just True)
          False -> runRequest right


-- | not operator for requests.
notReq :: Request Bool -- ^ Request to evaluate.
          -> Request Bool -- ^ Result value.
notReq expr =
  expr `andMaybe` \nb ->
    Request $ return (Just $ not nb)

-- | If statement for requests.
reqIf :: Request Bool -- ^ The test to apply
         -> Request a -- ^ Request to evaluate if test is true.
         -> Request a -- ^ Request to evaluate if test if false.
         -> Request a -- ^ Result.
reqIf test thenCase elseCase =
  test `andMaybe` \tb ->
    if tb
    then thenCase
    else elseCase

-- | Takes a value and makes it into a request.
reqConst :: a -- ^ Value to make into a request.
            -> Request a -- ^ Result.
reqConst val = return val

-- | Lifts a one-argument function into Request types.
reqLift :: (a -> b) -- ^ Function to lift.
           -> Request a -- ^ Argument to function.
           -> Request b -- ^ Result.
reqLift f req =
  do
    reqVal <- req
    return (f reqVal)

{- |
Lifts a 2 argument function into Request types. The arguments to the function
are evaluated in order, from left to right, since the Request monad imposes
sequencing. -}
reqLift2 :: (a -> b -> c) -- ^ Function to lift.
            -> Request a -- ^ First argument to function.
            -> Request b -- ^ Second argument to function.
            -> Request c -- ^ Result.
reqLift2 f left right =
  do
    leftVal <- left
    rightVal <- right
    return (f leftVal rightVal)

{- |
Returns true if the user answer y or Y. Allows
a default to be specified, and allows failure if
no default is given. -}
reqAgree :: Maybe Bool -- ^ Default value (if any).
            -> Request String -- ^ Request which gets a string
(usually reqResp).
            -> Request Bool -- ^ Result.
reqAgree def req = Request result
  where
    Request result = reqMaybe req (Request returnDefault) (Request .
returnAgreement)
    returnDefault = return $ maybe Nothing (\d -> Just d) def
    returnAgreement resp =
      case clean resp of
          ('y':_) -> return $ Just True
          ('n':_) -> return $ Just False
          _ -> returnDefault
    clean = (map toLower) . filter (not . isSpace)

-- | Automatic failure. Useful in menus to quit or return to the previous menu.
reqFail :: Request a
reqFail = Request $ return Nothing

{- |
Takes a request and guarantees a value will be
returned. That is, the request is repeated until a
valid (i.e. not Nothing) response is returned. -}
required :: Request a -- ^ Request to evaluate.
            -> Request a -- ^ Result.
required (Request req) =
    Request required'
  where
    required' =
      do
        val <- req
        case val of
          Nothing -> required'
          Just v -> return (Just v)

{- |
Like the maybe function, but for requests. Given a request value,
a default value,and a function that maps b to Request a,
this function either returns the default if the request value is nothing,
or it applies the function given to the value of the request and returns it.
-}
reqMaybe :: Request a -- ^ Request to evaluate.
            -> Request b -- ^ Default value.
            -> (a -> Request b) -- ^ Function to map b to Request a.
            -> Request b -- ^ Result.
reqMaybe (Request req) (Request def) fun =
  Request $
  do
    val <- req
    case val of
      Nothing -> def
      Just v -> nextReqVal
        where
          Request nextReqVal = fun v

{- |
Runs the request while the condition given holds,
then returns the result. Good for verification. -}
reqWhile :: (a -> Request Bool)
            -> Request a
            -> Request a
reqWhile cond req =
  do
    reqVal <- req
    testVal <- cond reqVal
    if testVal
      then reqWhile cond req
      else return reqVal

{- |
Runs the request until the condition given is satisfied,
then returns the result. -}
reqUntil :: (a -> Request Bool) -- ^ Condition to test.
            -> Request a -- ^ Request value to evaluate according to test.
            -> Request a -- ^ Result.
reqUntil cond req = reqWhile ((reqLift not) . cond) req

{- |
Requests a response from user. If Nothing is returned,
assumes default and returns that. -}
reqDefault :: Request a -- ^ Request to evaluate.
              -> a -- ^ Default value.
              -> Request a -- ^ Result.
reqDefault req def =
  Request $
  do
    val <- runRequest req
    case val of
      Nothing -> return $ Just def
      v -> return v

-- Ask a request forever (or until failure).
reqForever :: Request a -- ^ Request to ask forever.
              -> Request a -- ^ Result.
reqForever req =
  req `andMaybe` \_ -> reqForever req

{- |
Given a list of items and programs to run, displays a menu
of the items and runs the selected program. Very low level - usually reqMenu
is used instead. If the user selects an invalid choice, failure occurs. -}
reqChoices :: [(String, a)] -- ^ List of choices and labels which will
be selected from.
              -> Request Int -- ^ Request which gets the selection
from the user.
              -> Request a -- ^ Result of selection.
reqChoices choices req =
  do
    let choiceCnt = length choices
        choiceList = zip [(1::Int)..] (map (\(label, _) -> label) choices)
    sequence (map (\(idx, label) -> reqIO $ putStrLn ((show idx) ++ ".
" ++ label)) choiceList)
    idx <- prompt "? " req
    if idx < 1 || idx > length choices
      then reqFail
      else return (snd (choices !! (idx - 1)))

-- | Takes a list of strings and requests and forms a menu out of
them. Usually used over reqChoices.
reqMenu :: [(String, Request a)] -- ^ List of request choices and labels.
           -> Request a -- ^ Result.
reqMenu choices =
  do
    choice <- reqChoices choices reqInt
    choice

{- |
Takes an initial value and function which produces a request
from that value. Applies the function to the initial value
and then recurses. Useful for functions which operate off their
own output (e.g. a shell maintaining an environment). -}
reqIterate :: (a -> Request a) -- ^ Iterative function which
transforms a to Request a.
              -> a -- ^ Initial value used.
              -> Request a -- ^ Result of evaulation.
reqIterate fn initial =
  do
    result <- fn initial
    reqIterate fn result

{- |
Takes a request and a "continuation" request. If the
first request results in Nothing, run the second request.
In either case, return the result of the successful request. -}
reqCont :: Request a -- ^ First request to evaluate.
           -> Request a -- ^ Continuation request which is evaluated
if first fails.
           -> Request a -- ^ Result.
reqCont req cont =
  do
    result <- reqWhich req
    case result of
      Left _ -> cont
      Right val -> return val

{-
Indicates if the request failed or succceeded. If Left () is
returned, the request failed. If Right v is returned, the request
produce a value. Though the value returned is itself a request, it
will always be valid. -}
reqWhich :: Request a -- ^ Request to evaluate.
            -> Request (Either () a) -- ^ Result.
reqWhich req =
  do
    let -- default value, indicating a bad selection was made.
        failed = Request (return (Just (Left ())))
        -- Indicates a valid item was selected.
        success val =  Request (return (Just (Right val)))
    reqMaybe req failed success

{- |
Give a function from a -> b, an initial value,
and a Request for a, builds a Request for b. When (Request a) fails,
then the function returns whatever (Request b) has been built.
-}
reqFoldl :: (a -> b -> Request b) -- ^ Accumulating function.
            -> b -- ^ Initial value.
            -> Request a -- ^ Request to evaluate.
            -> Request b -- ^ Result.
reqFoldl fn initial req =
    reqFoldl' initial
  where
    reqFoldl' acc =
      do
        result <- reqWhich req
        case result of
          Left _ -> return acc
          Right val ->
            do
              result <- fn val acc
              reqFoldl' result


{- |
Given a request, builds a list of response. When
the user enters nothing, the list building ends -}
reqList :: Request a -- ^ Request to evaluate.
           -> Request [a] -- ^ Result.
reqList req = reqFoldl (\l ls -> return (l:ls)) [] req

{- |
Prints a message and makes a request. If the message ends in a space,
it is assumed
that the user should enter values on the same line. Otherwise, a new
line is printed
and the reqeust is evaulated. -}
prompt :: String -- ^ Message to display.
          -> Request a -- ^ Request which gathers input
          -> Request a -- ^ Result.
prompt msg (Request req) =
  Request $
  do
    if isSpace (last msg)
      then putStr msg
      else putStrLn msg
    hFlush stdout
    val <- req
    return val

{- |
Displays a message prompt and a default choice in a common way. If
the user doesn't provide a choice or enters bad data, the default value provided
is returned. Otherwise, the value entered is returned. -}
promptWithDefault :: (Show a) => String -- ^ Message to display.
Follows conventions of 'prompt'.
                     -> Request a -- ^ Request to evaluate.
                     -> a -- ^ Default value to use if necessary.
                     -> Request a -- ^ Result.
promptWithDefault msg req def =
  let msgWithDefault = msg ++ " [" ++ show def ++ "] "
  in
    prompt msgWithDefault (reqDefault req def)

{- |
Prints a message, displays defaults (if any), and
turns a Request String into a Request Bool. If
a default value is provided, it will be returned if the
user enters nothing or an invalid response. -}
promptAgree :: String -- ^ Message to display. Follows conventions of 'prompt'.
               -> Maybe Bool -- ^ Default value, if any.
               -> Request String -- ^ Request which gets a string
(usually reqResp).
               -> Request Bool -- ^ Result.
promptAgree msg def req =
    prompt msgWithDefault (reqAgree def req)
  where
    msgWithDefault =
      maybe msg
      (\v -> if v then (msg ++ "(Y/n) ") else (msg ++ "(y/N) "))
      def
\end{code}