{- |

This module provides a set of functions for building simple command-line interfaces. It allows interfaces which collect values (such as Integers, Dates, or other structured values), build lists of values, and use simple menus. It is not intended to build complex interfaces with full cursor control. It is oriented towards line-based interfaces.

/Requests/

The central concept of the library is the 'Request' type, which embodies an interactive request for data. When requesting data, there is always the possibility of failure. That is, the user may enter a value that doesn't parse, or may want to quit the process. For this reason, the value stored by a request is @"IO" ("Maybe" a)@, which shows there may not always be a value available. 'Request' is a monad, and when a request fails, no subsequent requests are asked. Instead, the whole request chain is abandoned.

The function 'reqResp' gives the most basic request possible, which is for a string. From this, other requests can be built. The library provides several:

 * 'reqInt' - Requests "Int" values.

 * 'reqInteger' - Requests "Integer" values.

 * 'reqChar' - Requests a single character (without waiting for the user to press enter)

 * 'reqPassword' - Like 'reqResp', but doesn't echo the user's input to the console.

 * 'reqRead' - Requests "Read"-able values.

 * 'reqList' - Asks a request repeatedly and builds a list of the responses, which are returned when the user
    enters a failure value.

 * 'reqMenu' - Given a list of items, asks the user to pick one of the items and returns it.

 * 'reqFail' - Always results in failure. Useful in menus for creating a \"quit\" or \"none\" selection.

A number of request patterns are also exported by the module. These embody different control schemes that are useful when building command-line interfaces. These include:

  * 'reqIf' - Takes a request which evaluates to a boolean and two requests representing \"then\" and \"else\" branches. The appropriate subsequent request is used, based on the value of the conditional request.
  
  * 'reqAgree' - Takes a request and determines if the user answers yes or no. A default can also be provided.
  
  * 'reqForever' - Takes a request and asks it over and over, until a failure value appears.
  
  * 'reqIterate' - Takes a function which, given a value, produces a request. An initial 'Request' value is also provided. The initial value is given to the function, and the value produced by the function is fed back into it. This continues until a failure occurs. This model is useful for shell-type applications which take a state, operate on it, and produce a new state, which is then fed back in.
  
  * 'reqCont' - Takes a request and a \"continuation\" request. If the first request fails, the \"continuation\" request is run. This is useful for confirming if the user really wants to quit an application, or other escape mechanisms. 

/Running Requests/

Requests can be run with two different functions:

  * 'execReq' - Takes a request, runs it, and returns a meaningless value. This is most often used to run a request from \'main\'.
  
  * 'runRequest' - Runs a request and returns the raw @"IO" ("Maybe a")@ value returned. This is useful for   running a request and extracting the value returned out of it.
  
/Prompting/

In most req functions, except 'reqMenu' and 'reqChoices', nothing is printed to the screen. Instead, a set of functions is provided which take a request and a string to use as a prompt. These functions include:

  * 'prompt' - Displays a message and gets a response. If the message ends in a space, it is assumed that input should be typed on the same line. Otherwise, a newline is printed and input is then gathered.

  * 'prompt1' -- Simple way to ask for a response and provide a default.

  * 'promptAgree' -- Simple way to ask for a yes\/no response.

/Simple Programs/

Getting values combines prompting and requests. Here's a \'guess a number\' game which probably isn't real fun (from examples\\guess_num.hs):

> guess_num_boring =
>     do
>       num <- prompt "Enter your guess between 1 - 100: " reqInt
>       if num == 50
>         then reqIO $ putStrLn "You win!"
>         else reqIO $ putStrLn "Too bad!"

To run the program, type @play_game guess_num_boring@ at the prompt. A better program might actually randomize the number, and tell you if you are low or high (again from examples\\guess_num.hs):


> 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

To run the program, type @play_game guess_num_fun@ at the prompt. Several features of this program are worth pointing out:

  * 'reqIO' - This function is used to lift IO operations into the 'Request' type.
  
  * 'reqUntil' - This function takes a condition and a request, and runs the request until the condition is satisfied. The conditional has the type @(a -> Request b)@, which allows the conditional to produce output, or base its decision on other requests. Naturally, the second argument has the type @(Request a)@, which means the result of the request can be passed to the condition. Other functions which wrap up input patterns are 'reqFoldl', 'reqList', 'reqCont', and others.
  
/Combining Requests/

The functions in this library are designed to allow more complex 'Request' values to be built from them. For example, imagine you are coding for a tax form submission and have a data type like this (from examples\\taxpayer.hs):

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

Because @Taxpayer@ derives "Read", a simple way of collecting a @Taxpayer@ value from the user would be:

> reqTaxpayer :: Request Taxpayer
> reqTaxpayer = prompt "Please enter tax payer information: " (reqRead reqResp)

Of course, this isn't very friendly:

> *Main> getTaxpayer reqTaxpayer
> Please enter tax payer information: Taxpayer {name="John", age = 30, ssn = "" }
> You entered: Taxpayer {name = "John", age = 30, ssn = ""}

Typing @Taxpayer { name = \"John\" ... }@ each time
is pretty tedious. A better solution builds the value from simpler pieces:

> 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)

Now, when tax payer info must be entered a nice set of prompts is displayed:

> *Main> getTaxpayer reqTaxpayerEasy
> Please enter the tax payer's name: Bob
> Please enter their age: 50
> Please enter their SSN/ASN: 111-11-1111
> You entered: Taxpayer {name = "Bob", age = 50, ssn = "111-11-1111"}

/Validation/

HCL provides the 'reqWhile' and 'reqUntil' functions which help ensure values entered are correct. For example, in the above, we could validate SSN's fairly easily like so (again, from example\\tax_payer.hs):

> reqSSN :: Request String -> Request String
> reqSSN req =
>   do
>     -- very simple validation
>     let
>       matchSSN = matchRegex (mkRegex "^...-..-....$")
>       invalidSSN ssn = return $ isNothing (matchSSN ssn)
>     ssn <- reqWhile invalidSSN req
>     return ssn

In the above, 'reqWhile' repeatedly uses @invalidSSN@ to determine if the value entered matches the (very simple) regular expression provided. When it does, the SSN entered is returned. Until then, the request is asked over and over. One subtlety to note is that a request to get the actual value is passed in to the function as @req@. This allows the function @reqTaxpayerValidate@ to pass it's own prompt and request into reqSSN:

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

Running @reqTaxpayerValidate@ from the prompt then gives:

> *Main> getTaxpayer reqTaxpayerValidate
> Please enter the tax payer's name: Bob
> Please enter their age: 20
> What is their SSN/ASN: 324=12=1231
> What is their SSN/ASN: 324-12-1211
> You entered: Taxpayer {name = "Bob", age = 20, ssn = "324-12-1211"}

/Dealing with Failure/

A fundamental assumption of the 'Request' type is that requests can fail. The user can enter no input or provide bad input. The discussion of validation above is a bit disingenuous because it does not mention what happens when the user just types a newline at the prompt. In all cases, the request chain ends and the program exits.

This is due to the behavior of the 'Request' monad - as soon as one request fails, the rest fail. The library provides several functions for dealing with this:

  * 'reqDefault' - Allows a default value to be supplied, which will be returned if the user provides no input or bad input.
  
  * 'required' - Repeatedly asks a request until the user provides input. \"Failure\" values will not occur.
  
  * 'reqCont' - Takes two request arguments. If the first fails, the second is used. Useful for providing a \"continuation\" to a request chain.
  
  * 'reqWhich' - Indicates if a request failed or not, through the use of the "Either" type. There is no direct way to determine if a request failed (that is, if it evaluates to Nothing, the entire chain fails and you won't see it). This function allows some visibility into if a specific request succeeded or not.

One use for 'reqCont' is to confirm if the user really wants to quit a program.  In the guess-a-number game, hitting Enter at a prompt stops the game. This can be avoided by changing how the guess a number game is launched:

> guess_num_cont =
>     reqCont guess_num_fun confirm
>   where
>     confirm =
>       reqIf (promptAgree "Are you sure you want to quit? " (Just False) reqResp)
>         reqFail
>         guess_num_cont

Above, 'reqCont' will run @guess_num_fun@ until it returns a @Just@ value. If @Nothing@ is returned, then @reqConfirm@ is run. If the user does not wish to quit, @reqConfirm@ will run @guess_num_confirm@ again. Otherwise, 'reqFail' is run, which causes the request to fail and thus the program to exit. Notice that the confirmation behavior was added by just adding another layer to the request chain. The @guess_num_fun@ function was used to provide gameplay - @guess_num_confirm@ just added a layer to control when the game ends.

However, because this pattern is fairly common, HCL provides the 'reqConfirm' function, which acts just like the 'reqCont' pattern above. That is, it takes a request to run and a request which returns a "Bool". If the initial request fails, the confirmation request is run. If that request results in @True@, the failure is allowed to propagate. Otherwise, the initial request is run again. The function @guess_num_confirm@ gives an example of its usage:

> guess_num_confirm =
>     reqConfirm confirm guess_num_fun 
>   where
>     confirm = promptAgree "Are you sure you want to quit? " (Just False) reqResp

  
/Making Menus/  

Several functions are used to build simple, hierarchical menus. A menu is defined as a list of pairs, where the first element is the label and the second a value to return. Usually, that value is a 'Request'. In some cases it is not. There are two functions used for building menus:

  * 'reqChoices' - A low-level means to build menus. It does not expect the second item in the pair to be a request, and is thus very general. 
  
  * 'reqMenu' - Expects the list given to be a pair of a string and another request. When an item is   selected, that request is run and the value is returned.
  
  * 'reqSubMenu' - Inserts a menu into a menu. When the item for the submenu is selected, the submenu will display its choices. When the user wishes to exit (by providing a failure value), the previously displayed menu will display again.
  
  * 'reqMenuItem' - Constructs an indvidual menu item.
  
  * 'reqMenuEnd' - Indicates the end of a list of menu items.
  
  * 'reqMenuExit' - A specialized menu item which will cause the menu request to fail. That means we return to the previous menu or exit the request chain altogether, depending on how the menus are structured.
  
'reqMenu' and 'reqSubMenu' work together to build hierarchical menus in which the user can automatically navigate \"up\" by just hitting return. For example, imagine a simple menu-driven PIM:

> *Main> pim
> 1. Manage contacts
> 2. Manage calendar
> ? 1
> 1. Add a contact
> 2. Remove a contact
> ? <-- User hits return here, returns to main menu
> 1. Manage contacts
> 2. Manage calendar
> ?

Setting this up is fairly straightforward (from examples\\pim.hs):

> pim = execReq $ reqConfirm confirm topMenu 
>   where
>     confirm = promptAgree "Are you sure you want to quit?" (Just False) reqResp
>     
> topMenu =
>   reqMenu $
>   -- Insert a submenu defined elsewhere
>   reqSubMenu topMenu "Manage contacts" manageContactsMenu $
>   -- Insert a sub menu directly
>   reqSubMenu topMenu "Manage calendar"
>     (reqMenuItem "Add an event" notImpl $
>       ...
>       reqMenuExit "Return to previous menu"
>       reqMenuEnd) $
>   ...
>   -- End the menu definition
>   reqMenuEnd
>   
> -- Defines a partial menu
> manageContactsMenu =
>   reqMenuItem "Add a contact" notImpl $
>   ...
>   reqMenuExit "Return to previous menu"
>   reqMenuEnd
> 
> notImpl = reqIO $ putStrLn "This function is not implemented."

'reqMenu' begins the process of definining a menu. 'reqMenuItem' is used to build a menu item, and when combined with @($)@ as above can be used to define a list of menu items \"in-line\". 'reqSubMenu' takes the menu to return to as its first argument (in the case above, @topMenu@), a label to name the menu item, and a request which will become the submenu. As seen above, submenus can be inserted directly (e.g. \"Manage calendar\"), or they can be defined independently (e.g. \"Manage contacts\"). 'reqMenuExit' allows the submenu to return to control to its calling menu. Finally, 'reqMenuEnd' can be used to end an \"in-line\" menu definition.

/Just Plain Cool/

Some of the other functions included are just cool to use:

  * 'reqIterate' - This take a function which maps a value to a request and a request. The request is evaluated and the results passed to the function. The result of that function is passed back into the function again. 'reqIterate' is useful for applications that manipulate some sort of environment by  repeatedly passing the modified environment back into themselves. An example of this is shown in  examples\\shell.hs where the @shell@ function is repeatedly called from @main@ using 'reqIterate'. The  hangman game in hangman\\hangman.hs also uses this when the @playRound@ function is repeatedly called from @main@.
  
  * 'reqFoldl' - Like @foldl@, but for requests. The accumulating function takes values of type a (which  come from the request given) and type b (the accumulating value) and produces a 'Request' of type b. If and when the initial request fails, whatever accumulated value that was built is returned.
  
  * 'reqList' - Takes a request and repeatedly runs it, building a list of the results. When the request  fails, the list is returned.
  
  * 'makeReq' - Not really so cool, but allows you to construct your own 'Request' values. Values created with 'makeReq' can be extracted with 'runRequest'. However, they will come back with the type @("IO" ("Maybe a")@, where the value is always a @Just@ value.

/Examples/

Several examples are included with the library, including a hangman game you can play:

  * examples\\guess_num.hs - Demonstrates various ways of implementing a "guess a number" game.
  
  * examples\\pim.hs - Shows how to build simple menus.
  
  * examples\\shell.hs - Shows how to use reqIterate to build a simple shell.
  
  * examples\\tax_payer.hs - Demonstrates how to construct requests for specific structured data types from simpler requests.
  
  * hangman\\hangman.hs - Implements the hangman game. An executable is installed when you install the library - just run @hangman@ at the command line.
  
-}

{-# LANGUAGE ScopedTypeVariables #-}

module System.Console.HCL 
(
-- * Request type and related functions

  Request (..),
  runRequest, execReq, reqIO, reqLiftMaybe, makeReq,
-- * Request building blocks

  reqResp, reqInteger, reqInt, reqRead, reqChar, reqPassword,
-- * Functions lifted into Requests

  andReq, orReq, notReq, reqIf, reqConst, reqLift, reqLift2,
  reqMaybe,
-- * Request patterns

  reqAgree, reqFail, required, reqUntil, reqWhile, reqDefault, reqForever,
  reqChoices, reqIterate, reqCont, reqConfirm, reqWhich, reqFoldl, 
  reqList, 
-- * Menus

  reqMenu, reqMenuItem, reqMenuEnd, reqSubMenu, reqMenuExit,
-- * Prompting

  prompt, promptWithDefault, prompt1, promptAgree
) where
 
import Data.Char (isSpace, toLower, isPrint)
import System.IO
import Test.QuickCheck 
import System.IO.Unsafe (unsafePerformIO)
import System.Random
import Data.Maybe (isNothing, isJust)
import Control.Applicative (Alternative (..))
import Control.Exception (catch, IOException)
import Control.Monad (when, MonadPlus)
import Control.Monad.Trans 

{- |
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. -}
newtype 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 a -> IO ()
execReq (Request IO (Maybe a)
req) =
  do
    Maybe a
result <- IO (Maybe a)
req
    IO () -> (a -> IO ()) -> Maybe a -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe a
result

-- | Extracts the value from a given request.

runRequest :: Request a  -- ^ The request to evaluate.

              -> IO (Maybe a) -- ^ Result of the request.

runRequest :: Request a -> IO (Maybe a)
runRequest (Request IO (Maybe a)
r) = IO (Maybe a)
r

{- |
Because we have defined @'Request'@ as @"Applicative"@,
we must also define it as @"Functor"@. -}
instance Functor Request where
  fmap :: (a -> b) -> Request a -> Request b
fmap = (a -> b) -> Request a -> Request b
forall a b. (a -> b) -> Request a -> Request b
reqLift

{- |
Because we have defined @'Request'@ as @"Monad"@,
we must also define it as @"Applicative"@. -}
instance Applicative Request where
  pure :: a -> Request a
pure = a -> Request a
forall a. a -> Request a
makeReq
  Request (a -> b)
f <*> :: Request (a -> b) -> Request a -> Request b
<*> Request a
x = Request (a -> b)
f Request (a -> b) -> ((a -> b) -> Request b) -> Request b
forall a b. Request a -> (a -> Request b) -> Request b
`andMaybe` \a -> b
f' ->
    (a -> b) -> Request a -> Request b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' Request a
x

{- |
@'Request'@ behavior as a @"Monad"@ all bind operations fail
afterwards. Thus, when one request fails, all subsequent requests
automatically fail. -}
instance Monad Request where
  Request a
f >>= :: Request a -> (a -> Request b) -> Request b
>>= a -> Request b
g = Request a
f Request a -> (a -> Request b) -> Request b
forall a b. Request a -> (a -> Request b) -> Request b
`andMaybe` a -> Request b
g

{- |
Request behavior as a @MonadFail@ covers failure - when
a request results in @Nothing@, -}
instance MonadFail Request where
  fail :: String -> Request a
fail String
_ = Request a
forall a. Request a
reqFail

{- |
Because we have defined @'Request'@ as @"MonadPlus"@, we must also
define it as @"Alternative"@. -}
instance Alternative Request where
  empty :: Request a
empty = Request a
forall a. Request a
reqFail
  <|> :: Request a -> Request a -> Request a
(<|>) = Request a -> Request a -> Request a
forall a. Request a -> Request a -> Request a
reqCont

{- |
@'Request'@ behaviour as a @"MonadPlus"@ allows for successive fallback
requests to be used on failure. -}
instance MonadPlus Request

{- |
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 :: a -> Request a
makeReq = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a)
-> (a -> IO (Maybe a)) -> a -> Request a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> (a -> Maybe a) -> a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just

{- |
If the request given results in @Nothing@, @Nothing@ is
returned. Otherwise, the value held in the Just constructor is passed
to the 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 a -> (a -> Request b) -> Request b
andMaybe (Request IO (Maybe a)
req) a -> Request b
next =
  IO (Maybe b) -> Request b
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe b) -> Request b) -> IO (Maybe b) -> Request b
forall a b. (a -> b) -> a -> b
$ do
    Maybe a
v <- IO (Maybe a)
req
    case Maybe a
v of
        Maybe a
Nothing -> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
        Just a
x  -> Request b -> IO (Maybe b)
forall a. Request a -> IO (Maybe a)
runRequest (Request b -> IO (Maybe b)) -> Request b -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ a -> Request b
next a
x

-- | Allow the Request type to use IO operations.

instance MonadIO Request where
  liftIO :: IO a -> Request a
liftIO = IO a -> Request a
forall a. IO a -> Request a
reqIO

{- |
Allows @"IO"@ operations in the @Request@ type. If the @"IO"@
operation throws an @"IOError", the resulting @'Request'@ will return
@Nothing@.  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 a -> Request a
reqIO IO a
io = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
io) ((IOException -> IO (Maybe a)) -> IO (Maybe a))
-> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$
  \(IOException
_ :: IOException) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

{- |
Lifts a @"Maybe" a@ into a @'Request' a@. -}
reqLiftMaybe :: Maybe a -- ^ the value to lift

                -> Request a -- ^ the resulting 'Request'

reqLiftMaybe :: Maybe a -> Request a
reqLiftMaybe = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a)
-> (Maybe a -> IO (Maybe a)) -> Maybe a -> Request a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return

{- |
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 String
reqResp =
  IO (Maybe String) -> Request String
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe String) -> Request String)
-> IO (Maybe String) -> Request String
forall a b. (a -> b) -> a -> b
$
  do
    String
val <- IO String
getLine
    if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
val
     then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
     else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
val

{- |
Gets an @"Integer"@ from the user. If the value entered cannot be converted,
the request fails. -}
reqInteger :: Request Integer
reqInteger :: Request Integer
reqInteger = Request String -> Request Integer
forall a. Read a => Request String -> Request a
reqRead Request String
reqResp

{- |
Gets an @"Int"@ from the user. If the value entered cannot be converted, the
request fails. -}
reqInt :: Request Int
reqInt :: Request Int
reqInt = Request String -> Request Int
forall a. Read a => Request String -> Request a
reqRead Request String
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 :: Request String -> Request a
reqRead Request String
req =
  Request String
req Request String -> (String -> Request a) -> Request a
forall a b. Request a -> (a -> Request b) -> Request b
`andMaybe` \String
val ->
    IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$
    do
      case ReadS a
forall a. Read a => ReadS a
reads String
val of
        []          -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        ((a
v, String
_):[]) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
v
        [(a, String)]
_           -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

{- |
@'reqChar'@ requests a single character. Unlike other @'Request'@s, it
does not wait for the user to hit enter; it simply returns the first
keystroke. -}
reqChar :: Request Char
reqChar :: Request Char
reqChar = IO (Maybe Char) -> Request Char
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe Char) -> Request Char)
-> IO (Maybe Char) -> Request Char
forall a b. (a -> b) -> a -> b
$ do
  BufferMode
mode <- Handle -> IO BufferMode
hGetBuffering Handle
stdin
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
  Char
val <- IO Char
getChar
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
val Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
mode
  Maybe Char -> IO (Maybe Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Char -> IO (Maybe Char)) -> Maybe Char -> IO (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Char -> Maybe Char
forall a. a -> Maybe a
Just Char
val

{- |
@'reqPassword'@ works like @'reqResp'@ except that it does not echo
the user's input to standard output. -}
reqPassword :: Request String
reqPassword :: Request String
reqPassword = IO (Maybe String) -> Request String
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe String) -> Request String)
-> IO (Maybe String) -> Request String
forall a b. (a -> b) -> a -> b
$ do
  Bool
echo <- Handle -> IO Bool
hGetEcho Handle
stdin
  Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
False
  Maybe String
val <- Request String -> IO (Maybe String)
forall a. Request a -> IO (Maybe a)
runRequest Request String
reqResp
  String -> IO ()
putStrLn String
""
  Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
echo
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
val

{- |
@&&@ 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 :: Request Bool -> Request Bool -> Request Bool
andReq Request Bool
left Request Bool
right = Request Bool -> Request Bool -> Request Bool -> Request Bool
forall a. Request Bool -> Request a -> Request a -> Request a
reqIf Request Bool
left
  Request Bool
right
  (Bool -> Request Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

{- |
@||@ 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 :: Request Bool -> Request Bool -> Request Bool
orReq Request Bool
left Request Bool
right = Request Bool -> Request Bool -> Request Bool -> Request Bool
forall a. Request Bool -> Request a -> Request a -> Request a
reqIf Request Bool
left
    (Bool -> Request Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    Request Bool
right

-- | not operator for requests.

notReq :: Request Bool -- ^ Request to evaluate.

          -> Request Bool -- ^ Result value.

notReq :: Request Bool -> Request Bool
notReq = (Bool -> Bool) -> Request Bool -> Request Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not

-- | 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 :: Request Bool -> Request a -> Request a -> Request a
reqIf Request Bool
test Request a
thenCase Request a
elseCase = do
  Bool
cond <- Request Bool
test
  if Bool
cond
    then Request a
thenCase
    else Request a
elseCase

-- | Takes a value and makes it into a request. 

reqConst :: a -- ^ Value to make into a request.

            -> Request a -- ^ Result.

reqConst :: a -> Request a
reqConst = a -> Request a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Lifts a one-argument function into @'Request'@ types.

reqLift :: (a -> b) -- ^ Function to lift.

           -> Request a -- ^ Argument to function.

           -> Request b -- ^ Result.

reqLift :: (a -> b) -> Request a -> Request b
reqLift a -> b
f Request a
req =
  do
    a
reqVal <- Request a
req
    b -> Request b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
reqVal)

{- |
Lifts a two 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 :: (a -> b -> c) -> Request a -> Request b -> Request c
reqLift2 a -> b -> c
f Request a
left Request b
right =
  do
    a
leftVal <- Request a
left
    b
rightVal <- Request b
right
    c -> Request c
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> c
f a
leftVal b
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 :: Maybe Bool -> Request String -> Request Bool
reqAgree Maybe Bool
def Request String
req =
  (Request String
req Request String -> (String -> Request Bool) -> Request Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Request Bool
f) Request Bool -> Request Bool -> Request Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Bool -> Request Bool
forall a. Maybe a -> Request a
reqLiftMaybe Maybe Bool
def where
  f :: String -> Request Bool
f String
x = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x of
    (Char
'y':String
_) -> Bool -> Request Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    (Char
'n':String
_) -> Bool -> Request Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    String
_       -> Request Bool
forall a. Request a
reqFail

-- | Automatic failure. Useful in menus to quit or return to the previous menu.

reqFail :: Request a
reqFail :: Request a
reqFail = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$ Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
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 a -> Request a
required Request a
req = Request a
req Request a -> Request a -> Request a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request a -> Request a
forall a. Request a -> Request a
required Request a
req

{- |
Like the @"maybe"@ function, but for requests. Given a request value, a
default value, and a function that maps @a@ to @'Request' b@, this
function either returns the default if the request value is @Nothing@
or an @"IOError"@ is thrown, 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 a -> Request b -> (a -> Request b) -> Request b
reqMaybe  Request a
req Request b
def a -> Request b
f = (Request a
req Request a -> (a -> Request b) -> Request b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Request b
f) Request b -> Request b -> Request b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request b
def

{- |
Runs the request while the condition given holds, then returns the
first result where it doesn't. Good for verification. If either
request or condition return @Nothing@ at any point, the reault will
also be @Nothing@. -}
reqWhile :: (a -> Request Bool) -- ^ the condition

            -> Request a -- ^ the request

            -> Request a
reqWhile :: (a -> Request Bool) -> Request a -> Request a
reqWhile a -> Request Bool
cond Request a
req = do
  a
val <- Request a
req
  Request Bool -> Request a -> Request a -> Request a
forall a. Request Bool -> Request a -> Request a -> Request a
reqIf (a -> Request Bool
cond a
val)
    ((a -> Request Bool) -> Request a -> Request a
forall a. (a -> Request Bool) -> Request a -> Request a
reqWhile a -> Request Bool
cond Request a
req)
    (a -> Request a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val)
      
{- |
Runs the request until the condition given is satisfied, then returns
the first result that satisfies it. If either request or condition
return @Notthing@ the result will also be @Nothing@. -}
reqUntil :: (a -> Request Bool) -- ^ Condition to test.

            -> Request a -- ^ Request value to evaluate according to test.

            -> Request a -- ^ Result.

reqUntil :: (a -> Request Bool) -> Request a -> Request a
reqUntil a -> Request Bool
cond Request a
req = (a -> Request Bool) -> Request a -> Request a
forall a. (a -> Request Bool) -> Request a -> Request a
reqWhile (((Bool -> Bool) -> Request Bool -> Request Bool
forall a b. (a -> b) -> Request a -> Request b
reqLift Bool -> Bool
not) (Request Bool -> Request Bool)
-> (a -> Request Bool) -> a -> Request Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Request Bool
cond) Request a
req
      
{- |
Requests a response from user. If @Nothing@ is returned or an
@"IOError"@ is thrown, assumes default and returns that. -}
reqDefault :: Request a -- ^ Request to evaluate.

              -> a -- ^ Default value.

              -> Request a -- ^ Result.

reqDefault :: Request a -> a -> Request a
reqDefault Request a
req a
def =
  Request a
req Request a -> Request a -> Request a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Request a
forall a. a -> Request a
makeReq a
def

{- |
Ask a request forever -- until failure. -}
reqForever :: Request a -- ^ Request to ask forever.

              -> Request a -- ^ Result.

reqForever :: Request a -> Request a
reqForever Request a
req =
  Request a
req Request a -> Request a -> Request a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Request a -> Request a
forall a. Request a -> Request a
reqForever Request a
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 :: [(String, a)] -> Request Int -> Request a
reqChoices [(String, a)]
choices Request Int
req =
  do
    let choiceCnt :: Int
choiceCnt = [(String, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, a)]
choices
        choiceList :: [(Int, String)]
choiceList = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] (((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
label, a
_) -> String
label) [(String, a)]
choices)
    [Request ()] -> Request [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (((Int, String) -> Request ()) -> [(Int, String)] -> [Request ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
idx, String
label) -> IO () -> Request ()
forall a. IO a -> Request a
reqIO (IO () -> Request ()) -> IO () -> Request ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ((Int -> String
forall a. Show a => a -> String
show Int
idx) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label)) [(Int, String)]
choiceList)
    Int
idx <- String -> Request Int -> Request Int
forall a. String -> Request a -> Request a
prompt String
"? " Request Int
req
    if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [(String, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, a)]
choices
      then Request a
forall a. Request a
reqFail
      else a -> Request a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, a) -> a
forall a b. (a, b) -> b
snd ([(String, a)]
choices [(String, a)] -> Int -> (String, a)
forall a. [a] -> Int -> a
!! (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))

{- |
Takes a list of strings and requests and forms a menu out of them. Menus can
built using 'reqMenuItem', 'reqSubMenu', 'reqMenuExit', and 'reqMenuEnd'.
-}
reqMenu :: [(String, Request a)] -- ^ List of request choices and labels.

           -> Request a -- ^ Result.

reqMenu :: [(String, Request a)] -> Request a
reqMenu [(String, Request a)]
choices =
  do
    Request a
choice <- [(String, Request a)] -> Request Int -> Request (Request a)
forall a. [(String, a)] -> Request Int -> Request a
reqChoices [(String, Request a)]
choices Request Int
reqInt
    Request a
choice

-- | Used to add an individual entry to a menu that is being built. 

reqMenuItem :: String -- ^ the label for the selection

  -> Request a -- ^ the @'Request'@ to run when selected

  -> [(String, Request a)] -- ^ the menu being built

  -> [(String, Request a)] -- ^ the resulting menu

reqMenuItem :: String
-> Request a -> [(String, Request a)] -> [(String, Request a)]
reqMenuItem String
label Request a
item = (:) (String
label, Request a
item) 

-- | Creates a submenu within a menu. When the submenu exits, control returns to the item specified.

reqSubMenu :: Request a -- ^ The menu to return to.

  -> String -- ^ The label of the submenu (in the current menu)

  -> [(String, Request a)] -- ^ The submenu itself

  -> [(String, Request a)] -- ^ The existing menu into which this submenu will be inserted.

  -> [(String, Request a)] -- ^ The menu item built and returned.

reqSubMenu :: Request a
-> String
-> [(String, Request a)]
-> [(String, Request a)]
-> [(String, Request a)]
reqSubMenu Request a
prevMenu String
label [(String, Request a)]
subMenu = (:) (String
label, Request a -> Request a
forall a. Request a -> Request a
reqForever (Request a -> Request a) -> Request a -> Request a
forall a b. (a -> b) -> a -> b
$ Request a -> Request a -> Request a
forall a. Request a -> Request a -> Request a
reqCont ([(String, Request a)] -> Request a
forall a. [(String, Request a)] -> Request a
reqMenu [(String, Request a)]
subMenu) Request a
prevMenu)  

-- | Causes the program to exit from the current menu.  

reqMenuExit :: String -- ^ the label, e.g.: @\"quit\"@

  -> [(String, Request a)] -- ^ the menu being built

  -> [(String, Request a)] -- ^ the resulting menu

reqMenuExit :: String -> [(String, Request a)] -> [(String, Request a)]
reqMenuExit String
label = (:) (String
label, Request a
forall a. Request a
reqFail)

-- | Ends a list of menu item definitions.

reqMenuEnd :: [(String, Request a)]
reqMenuEnd :: [(String, Request a)]
reqMenuEnd = []

{- |
Executes the request given and, if a failure value occurs, executes
the @"Bool"@ request given (usually some sort of prompt asking if they
want to quit). If the answer is @True@, the failure value
propagates. Otherwise, the initial request is run again. -}
reqConfirm :: Request Bool -- ^ When evaluated, determines if the failure is allowed to proceed or not.

  -> Request a -- ^ The request to run and to watch for failure

  -> Request a -- ^ Result of the request (if it did not fail).

reqConfirm :: Request Bool -> Request a -> Request a
reqConfirm Request Bool
conf Request a
req = Request a
req Request a -> Request a -> Request a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request Bool -> Request a -> Request a -> Request a
forall a. Request Bool -> Request a -> Request a -> Request a
reqIf Request Bool
conf
  Request a
forall a. Request a
reqFail
  (Request Bool -> Request a -> Request a
forall a. Request Bool -> Request a -> Request a
reqConfirm Request Bool
conf Request a
req)
  
{- |
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 :: (a -> Request a) -> a -> Request a
reqIterate a -> Request a
f a
x = a -> Request a
f a
x Request a -> (a -> Request a) -> Request a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> Request a) -> a -> Request a
forall a. (a -> Request a) -> a -> Request a
reqIterate a -> Request a
f

{- |
Takes a request and a "continuation" request. If the first request
results in @Nothing@ or an @"IOError"@ is thrown, 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 :: Request a -> Request a -> Request a
reqCont Request a
req Request a
cont = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$ do
  Maybe a
req' <- IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Request a -> IO (Maybe a)
forall a. Request a -> IO (Maybe a)
runRequest Request a
req) (\(IOException
_ :: IOError) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)
  case Maybe a
req' of
    Maybe a
Nothing -> Request a -> IO (Maybe a)
forall a. Request a -> IO (Maybe a)
runRequest Request a
cont
    Just a
x  -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

{- |
Indicates if the request failed or succceeded. If @"Left" ()@ is
returned, the request failed. If @"Right" v@ is returned, the request
produced a value. Though the value returned is itself a request, it
will always be valid. An @"IOError"@ being thrown by the original
request is considered a failire.-}
reqWhich :: Request a -- ^ Request to evaluate.

            -> Request (Either () a) -- ^ Result.

reqWhich :: Request a -> Request (Either () a)
reqWhich Request a
req = (a -> Either () a) -> Request a -> Request (Either () a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either () a
forall a b. b -> Either a b
Right Request a
req Request (Either () a)
-> Request (Either () a) -> Request (Either () a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either () a -> Request (Either () a)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either () a
forall a b. a -> Either a b
Left ())

{- |
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 :: (a -> b -> Request b) -> b -> Request a -> Request b
reqFoldl a -> b -> Request b
f b
x Request a
req = Request b
result Request b -> Request b -> Request b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b -> Request b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x where
  result :: Request b
result = do
    a
reqVal <- Request a
req
    a -> b -> Request b
f a
reqVal b
x

{- |
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 :: Request a -> Request [a]
reqList Request a
req = (a -> [a] -> Request [a]) -> [a] -> Request a -> Request [a]
forall a b. (a -> b -> Request b) -> b -> Request a -> Request b
reqFoldl (\a
l [a]
ls -> [a] -> Request [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
la -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls)) [] Request a
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 :: String -> Request a -> Request a
prompt String
msg (Request IO (Maybe a)
req) =
  IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$
  do
    if Char -> Bool
isSpace (String -> Char
forall a. [a] -> a
last String
msg)
      then String -> IO ()
putStr String
msg
      else String -> IO ()
putStrLn String
msg
    Handle -> IO ()
hFlush Handle
stdout
    Maybe a
val <- IO (Maybe a)
req
    Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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. -}
prompt1 :: (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.

prompt1 :: String -> Request a -> a -> Request a
prompt1 String
msg Request a
req a
def =
  let msgWithDefault :: String
msgWithDefault = String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
def String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] "
  in
    String -> Request a -> Request a
forall a. String -> Request a -> Request a
prompt String
msgWithDefault (Request a -> a -> Request a
forall a. Request a -> a -> Request a
reqDefault Request a
req a
def)

{- |
Deprecated name for 'prompt1'. -}
promptWithDefault :: (Show a) => String -> Request a -> a -> Request a 
promptWithDefault :: String -> Request a -> a -> Request a
promptWithDefault = String -> Request a -> a -> Request a
forall a. Show a => String -> Request a -> a -> Request a
prompt1

{- |
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 :: String -> Maybe Bool -> Request String -> Request Bool
promptAgree String
msg Maybe Bool
def Request String
req =
    String -> Request Bool -> Request Bool
forall a. String -> Request a -> Request a
prompt String
msgWithDefault (Maybe Bool -> Request String -> Request Bool
reqAgree Maybe Bool
def Request String
req)
  where
    msgWithDefault :: String
msgWithDefault =
      String -> (Bool -> String) -> Maybe Bool -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
msg
      (\Bool
v -> if Bool
v then (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(Y/n) ") else (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(y/N) "))
      Maybe Bool
def

{- |
Used to define an arbitrary that generates a request which randomizes
its response, each time it is evaluated. -}
newtype RandomRequest a = RandomRequest { RandomRequest a -> Request a
request :: Request a }

{- |
  Everytime the request returned is evaluated, it returns a random
  Just v or Nothing value. -}
instance (Arbitrary a) => Arbitrary (RandomRequest a) where
  arbitrary :: Gen (RandomRequest a)
arbitrary =
    let random :: a -> Request a
random a
val = IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (IO (Maybe a) -> Request a) -> IO (Maybe a) -> Request a
forall a b. (a -> b) -> a -> b
$
          do
            StdGen
rnd <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
            let (Int
lo, StdGen
rnd') = (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1 :: Int, Int
10 :: Int) StdGen
rnd
            if Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5
              then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
              else Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
val
    in
      do
        a
val <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
        RandomRequest a -> Gen (RandomRequest a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request a -> RandomRequest a
forall a. Request a -> RandomRequest a
RandomRequest (Request a -> RandomRequest a) -> Request a -> RandomRequest a
forall a b. (a -> b) -> a -> b
$ a -> Request a
forall a. a -> Request a
random a
val)
  
{- |
Creates a request which will return a random value or Nothing. The
request returns the same value every time it is evaluated. -}
instance (Arbitrary a) => Arbitrary (Request a) where
  arbitrary :: Gen (Request a)
arbitrary =
    do
      a
val <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
      Bool
rnd <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
      if Bool
rnd
        then Request a -> Gen (Request a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request a -> Gen (Request a)) -> Request a -> Gen (Request a)
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
val))
        else Request a -> Gen (Request a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request a -> Gen (Request a)) -> Request a -> Gen (Request a)
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> Request a
forall a. IO (Maybe a) -> Request a
Request (Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)

-- | Show for random requests.  

instance (Show a) => Show (RandomRequest a) where
  show :: RandomRequest a -> String
show (RandomRequest Request a
req) = Request a -> String
forall a. Show a => a -> String
show Request a
req
  
-- | Show for requests.  

instance (Show a) => Show (Request a) where
  show :: Request a -> String
show = Request a -> String
forall a. Show a => Request a -> String
showRequest

-- | Show for requests.  

showRequest :: Request a -> String
showRequest (Request IO (Maybe a)
r) = String
"requesting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Maybe a -> String
forall a. Show a => a -> String
show (Maybe a -> String) -> Maybe a -> String
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> Maybe a
forall a. IO a -> a
unsafePerformIO (IO (Maybe a)
r IO (Maybe a) -> (Maybe a -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe a
result -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
result))

{- |
  Ensures @required@ always returns a @(Just _)@ value. Kind of
  a bogus test because this will hang if required does NOT return
  a @Just@. -}
prop_requiredReturns :: RandomRequest Integer -> Bool
prop_requiredReturns :: RandomRequest Integer -> Bool
prop_requiredReturns RandomRequest Integer
reqRandom =
    IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let req :: Request Integer
req = RandomRequest Integer -> Request Integer
forall a. RandomRequest a -> Request a
request RandomRequest Integer
reqRandom
          Request IO (Maybe Integer)
result = Request Integer -> Request Integer
forall a. Request a -> Request a
required Request Integer
req
      Maybe Integer
ioVal <- IO (Maybe Integer)
result
      case Maybe Integer
ioVal of
        Maybe Integer
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe Integer
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

{- |
 Test that @reqDefault@ always returns a default value if the request
 resulted in @Nothing@. Otherwise, ensure it returned the request value. -}
prop_reqDefaultReturnsDefault :: Request Integer -> Integer -> Bool
prop_reqDefaultReturnsDefault :: Request Integer -> Integer -> Bool
prop_reqDefaultReturnsDefault Request Integer
req Integer
def =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let Request IO (Maybe Integer)
result = Request Integer -> Integer -> Request Integer
forall a. Request a -> a -> Request a
reqDefault Request Integer
req Integer
def
          Request IO (Maybe Integer)
input = Request Integer
req
      Maybe Integer
inputVal <- IO (Maybe Integer)
input
      Just Integer
resultVal <- IO (Maybe Integer)
result
      case Maybe Integer
inputVal of
        Maybe Integer
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
resultVal Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
def)
        Just Integer
v -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
resultVal Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
v)

-- | Test that bad choices don't cause exceptions. This test is noisy because it prints 

-- a lot of garbage to the screen, some of which are bell characters!

prop_reqChoicesDoesntFail :: [(String, Int)] -> Request Int -> Bool
prop_reqChoicesDoesntFail :: [(String, Int)] -> Request Int -> Bool
prop_reqChoicesDoesntFail [(String, Int)]
choices req :: Request Int
req@(Request IO (Maybe Int)
input) =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let Request IO (Maybe Int)
result = [(String, Int)] -> Request Int -> Request Int
forall a. [(String, a)] -> Request Int -> Request a
reqChoices [(String, Int)]
choices Request Int
req
      Maybe Int
inputVal <- IO (Maybe Int)
input
      Maybe Int
resultVal <- IO (Maybe Int)
result
      case Maybe Int
inputVal of
        -- If we got a valid number, ensure reqChoice behavior is correct.

        Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ([(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
choices) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
resultVal
               -- Result value of nothing here means a valid index was selected but nothing was returned.

               | Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
resultVal -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               -- Determine value returned was in fact in the choices

               | Bool
otherwise ->
                    let choiceVal :: Int
choiceVal = (String, Int) -> Int
forall a b. (a, b) -> b
snd ([(String, Int)]
choices [(String, Int)] -> Int -> (String, Int)
forall a. [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                        Just Int
v = Maybe Int
resultVal
                    in
                      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
choiceVal Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v
        Maybe Int
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
resultVal 
                    
{- |
  Test that the @andMaybe@ function works as specified. Good test because
  \>\>= is implemented using it! -}
prop_andMaybeWorks :: Request Int -> Request Int -> Bool
prop_andMaybeWorks :: Request Int -> Request Int -> Bool
prop_andMaybeWorks first :: Request Int
first@(Request IO (Maybe Int)
firstReq) second :: Request Int
second@(Request IO (Maybe Int)
secondReq) =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let Request IO (Maybe Int)
resultReq = Request Int
first Request Int -> (Int -> Request Int) -> Request Int
forall a b. Request a -> (a -> Request b) -> Request b
`andMaybe` \Int
v -> Request Int
second
      Maybe Int
resultVal <- IO (Maybe Int)
resultReq
      Maybe Int
firstVal <- IO (Maybe Int)
firstReq
      Maybe Int
secondVal <- IO (Maybe Int)
secondReq
      case Maybe Int
resultVal of
        -- If the result is nothing, the first thing (or the second) must

        -- be nothing.

        Maybe Int
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
firstVal Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
secondVal 
        -- Otherwise, it is the value of the second request.

        Just Int
n -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Int
v -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v) Maybe Int
secondVal

-- | Ensure that @reqWhich@ works as expected

prop_reqWhichWorks :: Request Int -> Bool
prop_reqWhichWorks :: Request Int -> Bool
prop_reqWhichWorks req :: Request Int
req@(Request IO (Maybe Int)
inputReq) =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let Request IO (Maybe (Either () Int))
resultReq = Request Int -> Request (Either () Int)
forall a. Request a -> Request (Either () a)
reqWhich Request Int
req
      Maybe (Either () Int)
resultVal <- IO (Maybe (Either () Int))
resultReq
      Maybe Int
inputVal <- IO (Maybe Int)
inputReq
      case Maybe (Either () Int)
resultVal of
        Maybe (Either () Int)
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just (Left ()
_) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
inputVal
        Just (Right Int
_) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
inputVal

-- | Ensure that @reqMaybe@ works as expected.

prop_reqMaybeWorks :: Request Int -> Request Int -> Bool
prop_reqMaybeWorks :: Request Int -> Request Int -> Bool
prop_reqMaybeWorks first :: Request Int
first@(Request IO (Maybe Int)
firstReq) def :: Request Int
def@(Request IO (Maybe Int)
defaultReq) =
  IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    do
      let Request IO (Maybe Int)
resultReq = Request Int -> Request Int -> (Int -> Request Int) -> Request Int
forall a b. Request a -> Request b -> (a -> Request b) -> Request b
reqMaybe Request Int
first Request Int
def (Int -> Request Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Request Int) -> (Int -> Int) -> Int -> Request Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. a -> a
id)
          compareMaybes :: a -> Maybe a -> Bool
compareMaybes a
n = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\a
v -> a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v)
      Maybe Int
firstVal <- IO (Maybe Int)
firstReq
      Maybe Int
defaultVal <- IO (Maybe Int)
defaultReq
      Maybe Int
resultVal <- IO (Maybe Int)
resultReq
      case Maybe Int
resultVal of
        Maybe Int
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
defaultVal
        Just Int
n | Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
firstVal -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Bool
forall a. Eq a => a -> Maybe a -> Bool
compareMaybes Int
n Maybe Int
defaultVal
               | Bool
otherwise -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Bool
forall a. Eq a => a -> Maybe a -> Bool
compareMaybes Int
n Maybe Int
firstVal