summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjlamothe <>2018-12-05 19:19:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-12-05 19:19:00 (GMT)
commit1ece7c27be412d5ba731d92673cd90d1e1aadb25 (patch)
tree121a32cf2361bf44d443ae1ed8aa9b46f2be1ee9
parent5de6537f30c4d833ce061c9697efce2edb5eaa70 (diff)
version 1.7.1HEAD1.7.1master
-rw-r--r--ChangeLog.md34
-rwxr-xr-xHCL.cabal9
-rwxr-xr-xsrc/System/Console/HCL.hs247
-rw-r--r--test/Spec.hs12
-rw-r--r--test/Spec/Monad.hs20
-rw-r--r--test/Spec/MonadPlus.hs30
-rw-r--r--test/Spec/ReqAgree.hs25
-rw-r--r--test/Spec/ReqDefault.hs15
-rw-r--r--test/Spec/ReqMaybe.hs15
-rw-r--r--test/Spec/ReqWhich.hs15
10 files changed, 269 insertions, 153 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..63723e1
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,34 @@
+# HCL Change Log
+
+## v1.7.1
+
+* added `ChangeLog.md` to cabal file
+* request functions with fallbacks catch `IOError` and fallback appropriately
+* code refactoring
+
+## v1.7
+
+* `reqIO` now catches `IOError` and returns `Nothing`
+* implemented `reqLiftMaybe`
+
+## v1.6
+
+* added test suite
+* fixed compiler warnings
+* documemtation fixes
+* defined `Request` as `Alternative` and `MonadPlus`
+
+## v1.5.1
+
+* fixed broken cabal file
+
+## v1.5
+
+* modified code to compile against QuickCheck 2.*
+ * made `Request` a `Functor` and `Applicative`
+* implemented `reqChar` and `reqPassword`
+
+## v1.4
+
+* QuickCheck 2 updates
+ * Thanks to Sergei Trofimovich for a patch which makes sure HCL compiles against QuickCheck 1.
diff --git a/HCL.cabal b/HCL.cabal
index 7c2c9bc..07dd199 100755
--- a/HCL.cabal
+++ b/HCL.cabal
@@ -1,5 +1,5 @@
Name: HCL
-Version: 1.7
+Version: 1.7.1
License: BSD3
Author: Justin Bailey
Homepage: http://github.com/m4dc4p/hcl/tree/master
@@ -15,6 +15,7 @@ Description:
menus. It is not intended to build complex interfaces with full cursor
control. It is oriented towards line-based interfaces.
cabal-version: >= 1.8
+extra-source-files: ChangeLog.md
Data-files: hangman/2of12.txt
Library
@@ -37,8 +38,14 @@ test-suite HCL-test
other-modules:
Spec.AndReq
Spec.Constructors
+ Spec.ReqMaybe
+ Spec.Monad
+ Spec.MonadPlus
Spec.NotReq
Spec.OrReq
+ Spec.ReqAgree
+ Spec.ReqDefault
Spec.ReqIf
Spec.ReqLift
Spec.ReqLift2
+ Spec.ReqWhich
diff --git a/src/System/Console/HCL.hs b/src/System/Console/HCL.hs
index 2d4da17..43a3cc2 100755
--- a/src/System/Console/HCL.hs
+++ b/src/System/Console/HCL.hs
@@ -350,7 +350,7 @@ instance Applicative Request where
fmap f' x
{- |
-'Request' behavior as a @"Monad"@ covers failure - when
+@'Request'@ behavior as a @"Monad"@ covers failure - when
a request results in @Nothing@, all bind
operations fail afterwards. Thus, when one request fails,
all subsequent requests automatically fail. -}
@@ -363,50 +363,44 @@ Because we have defined @'Request'@ as @"MonadPlus"@, we must also
define it as @"Alternative"@. -}
instance Alternative Request where
empty = reqFail
- x <|> y = Request $ do
- maybeVal <- runRequest x
- case maybeVal of
- Nothing -> runRequest y
- Just val -> return $ Just val
+ (<|>) = reqCont
{- |
-'Request' behaviour as a @"MonadPlus"@ allows for successive fallback
+@'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
+not be an @"IO" ("Maybe" a)@ type value, unless
multiply nested values is desired. -}
makeReq :: a -- ^ The value to turn into a Request.
-> Request a -- ^ The value as a Request.
-makeReq val = Request (return $ Just val)
+makeReq = Request . return . Just
{- |
-If the request given results in @Nothing@, @Nothing@
-is returned. Otherwise, the value held in the Just
-constructor is passed to the "next" function given. This is essentially
-the bind operation. -}
+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 req) next =
- Request $
- do
+ Request $ do
v <- req
case v of
Nothing -> return Nothing
- Just x -> nextReqVal
- where
- Request nextReqVal = next x
+ Just x -> runRequest $ next x
-- | Allow the Request type to use IO operations.
instance MonadIO Request where
liftIO = reqIO
{- |
-Allows @IO@ operations in the @Request@
-type. Same as @liftIO@ in "MonadIO" class (in @Control.Monad.Trans@ module) -}
+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 = Request $ catch (fmap Just io) $
@@ -432,19 +426,19 @@ reqResp =
else return $ Just val
{- |
-Gets an "Integer" from the user. If the value entered cannot be converted,
+Gets an @"Integer"@ from the user. If the value entered cannot be converted,
the request fails. -}
reqInteger :: Request Integer
reqInteger = reqRead reqResp
{- |
-Gets an "Int" from the user. If the value entered cannot be converted, the
+Gets an @"Int"@ from the user. If the value entered cannot be converted, the
request fails. -}
reqInt :: Request Int
reqInt = reqRead reqResp
{- |
-Uses @reads@ to process a request. If the value cannot be parsed,
+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.
@@ -458,7 +452,7 @@ reqRead req =
_ -> return Nothing
{- |
-@reqChar@ requests a single character. Unlike other @Request@s, it
+@'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
@@ -471,7 +465,8 @@ reqChar = Request $ do
return $ Just val
{- |
-@reqPassword@ works like 'reqResp' except that it does not echo the user's input to standard output. -}
+@'reqPassword'@ works like @'reqResp'@ except that it does not echo
+the user's input to standard output. -}
reqPassword :: Request String
reqPassword = Request $ do
echo <- hGetEcho stdin
@@ -483,18 +478,15 @@ reqPassword = Request $ do
{- |
@&&@ operator for requests (with failure). Behaves similarly, including
-"short-circuit" behavior. If either condition fails, the entire @Request@
+"short-circuit" behavior. If either condition fails, the entire @'Request'@
fails. -}
andReq :: Request Bool -- ^ Left boolean value.
-> Request Bool -- ^ Right boolean value.
-> Request Bool -- ^ Result value.
-andReq left right =
- left `andMaybe` \lb ->
- Request $
- case lb of
- False -> return $ Just False
- True -> runRequest right
-
+andReq left right = reqIf left
+ right
+ (return False)
+
{- |
@||@ operator for requests (with failure). Behaves similarly, including
"short-circuit" behavior. If either condition fails, the entire @Request@
@@ -502,38 +494,32 @@ fails. -}
orReq :: Request Bool -- ^ Left boolean value.
-> Request Bool -- ^ Right boolean value.
-> Request Bool -- ^ Result value.
-orReq left right =
- left `andMaybe` \lb ->
- Request $
- case lb of
- True -> return (Just True)
- False -> runRequest right
-
+orReq left right = reqIf left
+ (return True)
+ right
-- | not operator for requests.
notReq :: Request Bool -- ^ Request to evaluate.
-> Request Bool -- ^ Result value.
-notReq expr =
- expr `andMaybe` \nb ->
- Request $ return (Just $ not nb)
+notReq = fmap 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 test thenCase elseCase =
- test `andMaybe` \tb ->
- if tb
+reqIf test thenCase elseCase = do
+ cond <- test
+ if cond
then thenCase
else elseCase
-- | Takes a value and makes it into a request.
reqConst :: a -- ^ Value to make into a request.
-> Request a -- ^ Result.
-reqConst val = return val
+reqConst = return
--- | Lifts a one-argument function into @Request@ types.
+-- | Lifts a one-argument function into @'Request'@ types.
reqLift :: (a -> b) -- ^ Function to lift.
-> Request a -- ^ Argument to function.
-> Request b -- ^ Result.
@@ -543,9 +529,9 @@ reqLift f req =
return (f 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. -}
+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.
@@ -561,18 +547,14 @@ 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 String -- ^ Request which gets a string (usually @'reqResp'@).
-> Request Bool -- ^ Result.
-reqAgree def req = Request result
- where
- Request result = reqMaybe req (Request returnDefault) (Request . returnAgreement)
- returnDefault = return $ maybe Nothing (\d -> Just d) def
- returnAgreement resp =
- case clean resp of
- ('y':_) -> return $ Just True
- ('n':_) -> return $ Just False
- _ -> returnDefault
- clean = (map toLower) . filter (not . isSpace)
+reqAgree def req =
+ (req >>= f) <|> reqLiftMaybe def where
+ f x = case dropWhile isSpace $ map toLower x of
+ ('y':_) -> return True
+ ('n':_) -> return False
+ _ -> reqFail
-- | Automatic failure. Useful in menus to quit or return to the previous menu.
reqFail :: Request a
@@ -584,78 +566,59 @@ returned. That is, the request is repeated until a
valid (i.e. not @Nothing@) response is returned. -}
required :: Request a -- ^ Request to evaluate.
-> Request a -- ^ Result.
-required (Request req) =
- Request required'
- where
- required' =
- do
- val <- req
- case val of
- Nothing -> required'
- Just v -> return (Just v)
+required req = req <|> required req
{- |
-Like the @maybe@ function, but for requests. Given a request value,
-a default value,and a function that maps @b@ to @Request a@,
-this function either returns the default if the request value is nothing,
-or it applies the function given to the value of the request and returns it.
+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 req) (Request def) fun =
- Request $
- do
- val <- req
- case val of
- Nothing -> def
- Just v -> nextReqVal
- where
- Request nextReqVal = fun v
+reqMaybe req def f = (req >>= f) <|> def
{- |
-Runs the request while the condition given holds,
-then returns the result. Good for verification. -}
-reqWhile :: (a -> Request Bool)
- -> Request a
+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 cond req =
- do
- reqVal <- req
- testVal <- cond reqVal
- if testVal
- then reqWhile cond req
- else return reqVal
+reqWhile cond req = do
+ val <- req
+ reqIf (cond val)
+ (reqWhile cond req)
+ (return val)
{- |
-Runs the request until the condition given is satisfied,
-then returns the result. -}
+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 cond req = reqWhile ((reqLift not) . cond) req
{- |
-Requests a response from user. If @Nothing@ is returned,
-assumes default and returns that. -}
+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 req def =
- Request $
- do
- val <- runRequest req
- case val of
- Nothing -> return $ Just def
- v -> return v
+ req <|> makeReq def
{- |
Ask a request forever -- until failure. -}
reqForever :: Request a -- ^ Request to ask forever.
-> Request a -- ^ Result.
reqForever req =
- req `andMaybe` \_ -> reqForever req
+ req >> reqForever req
{- |
Given a list of items and programs to run, displays a menu
@@ -711,15 +674,16 @@ 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.
--}
+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 conf req = reqCont req (reqIf conf reqFail (reqConfirm conf req))
+reqConfirm conf req = req <|> reqIf conf
+ reqFail
+ (reqConfirm conf req)
{- |
Takes an initial value and function which produces a request
@@ -729,64 +693,43 @@ own output (e.g. a shell maintaining an environment). -}
reqIterate :: (a -> Request a) -- ^ Iterative function which transforms a to Request a.
-> a -- ^ Initial value used.
-> Request a -- ^ Result of evaulation.
-reqIterate fn initial =
- do
- result <- reqWhich (fn initial)
- case result of
- Left _ -> return initial
- Right val -> reqIterate fn val
+reqIterate f x = f x >>= reqIterate f
{- |
-Takes a request and a "continuation" request. If the
-first request results in @Nothing@, run the second request.
-In either case, return the result of the successful request. -}
+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 req cont =
- do
- result <- reqWhich req
- case result of
- Left _ -> cont
- Right val -> return val
+reqCont req cont = Request $ do
+ req' <- catch (runRequest req) (\(_ :: IOError) -> return Nothing)
+ case req' of
+ Nothing -> runRequest cont
+ Just x -> return $ Just 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. -}
+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 req =
- do
- let -- default value, indicating a bad selection was made.
- failed = Request (return (Just (Left ())))
- -- Indicates a valid item was selected.
- success val = Request (return (Just (Right val)))
- reqMaybe req failed success
+reqWhich req = fmap Right req <|> return (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.
--}
+Give a function from @a -> b@, an initial value, and a @'Request'@ for
+@a@, builds a @'Request'@ for @b@. When @('Request' a)@ fails, then
+the function returns whatever @('Request' b)@ has been built. -}
reqFoldl :: (a -> b -> Request b) -- ^ Accumulating function.
-> b -- ^ Initial value.
-> Request a -- ^ Request to evaluate.
-> Request b -- ^ Result.
-reqFoldl fn initial req =
- reqFoldl' initial
- where
- reqFoldl' acc =
- do
- result <- reqWhich req
- case result of
- Left _ -> return acc
- Right val ->
- do
- result <- fn val acc
- reqFoldl' result
-
+reqFoldl f x req = result <|> return x where
+ result = do
+ reqVal <- req
+ f reqVal x
{- |
Given a request, builds a list of response. When
diff --git a/test/Spec.hs b/test/Spec.hs
index ede3e63..e545120 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -6,11 +6,17 @@ import Test.HUnit
import qualified Spec.AndReq as AndReq
import qualified Spec.Constructors as Constructors
+import qualified Spec.Monad as Monad
+import qualified Spec.MonadPlus as MonadPlus
import qualified Spec.NotReq as NotReq
import qualified Spec.OrReq as OrReq
+import qualified Spec.ReqAgree as ReqAgree
+import qualified Spec.ReqDefault as ReqDefault
import qualified Spec.ReqIf as ReqIf
import qualified Spec.ReqLift as ReqLift
import qualified Spec.ReqLift2 as ReqLift2
+import qualified Spec.ReqMaybe as ReqMaybe
+import qualified Spec.ReqWhich as ReqWhich
main = do
counts <- runTestTT tests
@@ -22,7 +28,13 @@ tests = TestList
, AndReq.tests
, OrReq.tests
, NotReq.tests
+ , ReqDefault.tests
+ , ReqMaybe.tests
+ , ReqWhich.tests
, ReqIf.tests
, ReqLift.tests
, ReqLift2.tests
+ , ReqAgree.tests
+ , Monad.tests
+ , MonadPlus.tests
]
diff --git a/test/Spec/Monad.hs b/test/Spec/Monad.hs
new file mode 100644
index 0000000..b573829
--- /dev/null
+++ b/test/Spec/Monad.hs
@@ -0,0 +1,20 @@
+module Spec.Monad (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "Monad" $ TestList [ returnTest, bindTests ]
+
+returnTest = TestLabel "return" $ TestCase $ do
+ val <- runRequest $ return 1
+ assertEqual "" (Just 1) val
+
+bindTests = TestLabel ">>=" $ TestList $ map bindTest
+ [ ( "success", Just 1, Just 2 )
+ , ( "failure", Nothing, Nothing )
+ ]
+
+bindTest (label, x, expect ) = TestLabel label $ TestCase $ do
+ val <- runRequest $ reqLiftMaybe x >>= return . succ
+ assertEqual "" expect val
diff --git a/test/Spec/MonadPlus.hs b/test/Spec/MonadPlus.hs
new file mode 100644
index 0000000..abad4f0
--- /dev/null
+++ b/test/Spec/MonadPlus.hs
@@ -0,0 +1,30 @@
+module Spec.MonadPlus (tests) where
+
+import Control.Monad
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "MonadPlus" $ TestList
+ [ mzeroTest
+ , mplusTests
+ ]
+
+mzeroTest = TestLabel "mzero" $ TestCase $ do
+ val <- runRequest mzero
+ assertEqual "" Nothing (val :: Maybe ())
+
+mplusTests = TestLabel "mplus" $ TestList $ map mplusTest
+ [ ( "both pass", makeReq 1, makeReq 2, Just 1 )
+ , ( "first fails", reqFail, makeReq 2, Just 2 )
+ , ( "first errors", err, makeReq 2, Just 2 )
+ , ( "second fails", makeReq 1, reqFail, Just 1 )
+ , ( "second errors", makeReq 1, err, Just 1 )
+ , ( "both fail", reqFail, reqFail, Nothing )
+ ]
+
+mplusTest (label, x, y, expect) = TestLabel label $ TestCase $ do
+ val <- runRequest $ x `mplus` y
+ assertEqual "" expect val
+
+err = Request $ fail ""
diff --git a/test/Spec/ReqAgree.hs b/test/Spec/ReqAgree.hs
new file mode 100644
index 0000000..5bb24d3
--- /dev/null
+++ b/test/Spec/ReqAgree.hs
@@ -0,0 +1,25 @@
+module Spec.ReqAgree (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "reqAgree" $ TestList $ map test'
+ [ ( "yes", Nothing, Just True )
+ , ( " yes", Nothing, Just True )
+ , ( "Yes", Nothing, Just True )
+ , ( "yes", Just False, Just True )
+ , ( "no", Nothing, Just False )
+ , ( " no", Nothing, Just False )
+ , ( "No", Nothing, Just False )
+ , ( "no", Just True, Just False )
+ , ( "foo", Nothing, Nothing )
+ , ( "foo", Just True, Just True )
+ , ( "foo", Just False, Just False )
+ ]
+
+test' (str, def, expect) = TestLabel label $ TestCase assertion where
+ label = "input = " ++ show str ++ ", default = " ++ show def
+ assertion = do
+ val <- runRequest $ reqAgree def $ return str
+ assertEqual "" val expect
diff --git a/test/Spec/ReqDefault.hs b/test/Spec/ReqDefault.hs
new file mode 100644
index 0000000..34cc60e
--- /dev/null
+++ b/test/Spec/ReqDefault.hs
@@ -0,0 +1,15 @@
+module Spec.ReqDefault (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "reqDefault" $ TestList $ map test'
+ [ ( "success", makeReq 1, 2, 1 )
+ , ( "failure", reqFail, 2, 2 )
+ , ( "error", Request $ fail "", 2, 2 )
+ ]
+
+test' (label, req, def, expect) = TestLabel label $ TestCase $ do
+ val <- runRequest $ reqDefault req def
+ assertEqual "" (Just expect) val
diff --git a/test/Spec/ReqMaybe.hs b/test/Spec/ReqMaybe.hs
new file mode 100644
index 0000000..981a1fd
--- /dev/null
+++ b/test/Spec/ReqMaybe.hs
@@ -0,0 +1,15 @@
+module Spec.ReqMaybe (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "reqMaybe" $ TestList $ map test'
+ [ ( "success", makeReq 1, 2 )
+ , ( "failire", reqFail, 0 )
+ , ( "error", Request $ fail "", 0 )
+ ]
+
+test' (label, x, expect) = TestLabel label $ TestCase $ do
+ val <- runRequest $ reqMaybe x (makeReq 0) (makeReq . succ)
+ assertEqual "" (Just expect) val
diff --git a/test/Spec/ReqWhich.hs b/test/Spec/ReqWhich.hs
new file mode 100644
index 0000000..f8b1875
--- /dev/null
+++ b/test/Spec/ReqWhich.hs
@@ -0,0 +1,15 @@
+module Spec.ReqWhich (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+tests = TestLabel "reqWhich" $ TestList $ map test'
+ [ ( "success", makeReq (), Right () )
+ , ( "failire", reqFail, Left () )
+ , ( "error", Request $ fail "", Left () )
+ ]
+
+test' (label, x, expect) = TestLabel label $ TestCase $ do
+ val <- runRequest $ reqWhich x
+ assertEqual "" (Just expect) val