{-# LANGUAGE ScopedTypeVariables #-}
module System.Console.HCL
(
Request (..),
runRequest, execReq, reqIO, reqLiftMaybe, makeReq,
reqResp, reqInteger, reqInt, reqRead, reqChar, reqPassword,
andReq, orReq, notReq, reqIf, reqConst, reqLift, reqLift2,
reqMaybe,
reqAgree, reqFail, required, reqUntil, reqWhile, reqDefault, reqForever,
reqChoices, reqIterate, reqCont, reqConfirm, reqWhich, reqFoldl,
reqList,
reqMenu, reqMenuItem, reqMenuEnd, reqSubMenu, reqMenuExit,
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
newtype Request a = Request (IO (Maybe a))
execReq :: Request a
-> IO ()
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
runRequest :: Request a
-> IO (Maybe a)
runRequest :: Request a -> IO (Maybe a)
runRequest (Request IO (Maybe a)
r) = IO (Maybe a)
r
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
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
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
instance MonadFail Request where
fail :: String -> Request a
fail String
_ = Request a
forall a. Request a
reqFail
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
instance MonadPlus Request
makeReq :: a
-> Request a
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
andMaybe :: Request a
-> (a -> Request b)
-> Request b
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
instance MonadIO Request where
liftIO :: IO a -> Request a
liftIO = IO a -> Request a
forall a. IO a -> Request a
reqIO
reqIO :: IO a
-> Request a
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
reqLiftMaybe :: Maybe a
-> Request a
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
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
reqInteger :: Request Integer
reqInteger :: Request Integer
reqInteger = Request String -> Request Integer
forall a. Read a => Request String -> Request a
reqRead Request String
reqResp
reqInt :: Request Int
reqInt :: Request Int
reqInt = Request String -> Request Int
forall a. Read a => Request String -> Request a
reqRead Request String
reqResp
reqRead :: (Read a) => Request String
-> Request a
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 :: 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 :: 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
andReq :: Request Bool
-> Request Bool
-> Request Bool
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)
orReq :: Request Bool
-> Request Bool
-> Request Bool
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
notReq :: Request Bool
-> Request Bool
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
reqIf :: Request Bool
-> Request a
-> Request a
-> Request a
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
reqConst :: a
-> Request a
reqConst :: a -> Request a
reqConst = a -> Request a
forall (m :: * -> *) a. Monad m => a -> m a
return
reqLift :: (a -> b)
-> Request a
-> Request b
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)
reqLift2 :: (a -> b -> c)
-> Request a
-> Request b
-> Request c
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)
reqAgree :: Maybe Bool
-> Request String
-> Request Bool
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
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
required :: Request a
-> Request a
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
reqMaybe :: Request a
-> Request b
-> (a -> Request b)
-> Request b
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
reqWhile :: (a -> Request Bool)
-> Request a
-> 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)
reqUntil :: (a -> Request Bool)
-> Request a
-> Request a
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
reqDefault :: Request a
-> a
-> Request a
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
reqForever :: Request a
-> Request a
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
reqChoices :: [(String, a)]
-> Request Int
-> Request a
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)))
reqMenu :: [(String, Request a)]
-> Request a
[(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
reqMenuItem :: String
-> Request a
-> [(String, Request a)]
-> [(String, Request a)]
String
label Request a
item = (:) (String
label, Request a
item)
reqSubMenu :: Request a
-> String
-> [(String, Request a)]
-> [(String, Request a)]
-> [(String, Request a)]
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)
reqMenuExit :: String
-> [(String, Request a)]
-> [(String, Request a)]
String
label = (:) (String
label, Request a
forall a. Request a
reqFail)
reqMenuEnd :: [(String, Request a)]
= []
reqConfirm :: Request Bool
-> Request a
-> Request a
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)
reqIterate :: (a -> Request a)
-> a
-> Request a
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
reqCont :: Request a
-> Request a
-> Request a
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
reqWhich :: Request a
-> Request (Either () a)
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 ())
reqFoldl :: (a -> b -> Request b)
-> b
-> Request a
-> Request b
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
reqList :: Request a
-> Request [a]
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
prompt :: String
-> Request a
-> Request a
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
prompt1 :: (Show a) => String
-> Request a
-> a
-> Request a
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)
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
promptAgree :: String
-> Maybe Bool
-> Request String
-> Request Bool
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
newtype RandomRequest a = RandomRequest { RandomRequest a -> Request a
request :: Request a }
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)
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)
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
instance (Show a) => Show (Request a) where
show :: Request a -> String
show = Request a -> String
forall a. Show a => Request a -> String
showRequest
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))
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
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)
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
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
| 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
| 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
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
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
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
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
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