HCL 1.4 → 1.9
raw patch · 19 files changed
Files
- ChangeLog.md +44/−0
- HCL.cabal +39/−9
- LICENSE +1/−1
- src/System/Console/HCL.hs +194/−187
- test/Spec.hs +42/−0
- test/Spec/AndReq.hs +21/−0
- test/Spec/Constructors.hs +38/−0
- test/Spec/Monad.hs +20/−0
- test/Spec/MonadCatch.hs +26/−0
- test/Spec/MonadPlus.hs +30/−0
- test/Spec/NotReq.hs +16/−0
- test/Spec/OrReq.hs +21/−0
- test/Spec/ReqAgree.hs +25/−0
- test/Spec/ReqDefault.hs +15/−0
- test/Spec/ReqIf.hs +16/−0
- test/Spec/ReqLift.hs +14/−0
- test/Spec/ReqLift2.hs +17/−0
- test/Spec/ReqMaybe.hs +15/−0
- test/Spec/ReqWhich.hs +15/−0
+ ChangeLog.md view
@@ -0,0 +1,44 @@+# HCL Change Log + +## v.1.9 +* Updated to a more recent Haskell Stack snapshot +* Implemented `MonadThrow` and `MonadCatch` on `Request` + +## v.1.8 + +* updated to haskell stack +* implemented MonadFail +* better documentation + +## 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.
HCL.cabal view
@@ -1,13 +1,11 @@ Name: HCL-Version: 1.4+Version: 1.9 License: BSD3 Author: Justin Bailey Homepage: http://github.com/m4dc4p/hcl/tree/master-Maintainer: jgbailey _ gmail _ com+Maintainer: Jonathan Lamothe <jlamothe1980@gmail.com> Category: User Interfaces License-File: LICENSE-License: BSD3-Build-Depends: base, QuickCheck < 2, mtl, random, containers Build-type: Simple Synopsis: High-level library for building command line interfaces. Description:@@ -16,10 +14,42 @@ 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.-Exposed-modules: System.Console.HCL-Hs-Source-Dirs: src+cabal-version: >= 1.10+extra-source-files: ChangeLog.md Data-files: hangman/2of12.txt -Executable: hangman-Main-Is: Hangman.hs-Hs-Source-Dirs: hangman, src+Library+ default-language: Haskell2010+ Build-Depends: base >= 4.9.0.0 && < 5, QuickCheck == 2.*, mtl, random, containers, exceptions >= 0.10.7 && < 0.11+ Exposed-modules: System.Console.HCL+ Hs-Source-Dirs: src++Executable hangman+ default-language: Haskell2010+ Build-Depends: base >= 4.7 && < 5, QuickCheck == 2.*, mtl, random, containers, HCL+ Main-Is: Hangman.hs+ Hs-Source-Dirs: hangman+ other-modules: Paths_HCL++test-suite HCL-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ Build-Depends: base >= 4.7 && < 5, QuickCheck == 2.*, mtl, random, containers, HCL, HUnit, exceptions >= 0.10.7 && < 0.11+ other-modules:+ Spec.AndReq+ Spec.Constructors+ Spec.ReqMaybe+ Spec.Monad+ Spec.MonadCatch+ Spec.MonadPlus+ Spec.NotReq+ Spec.OrReq+ Spec.ReqAgree+ Spec.ReqDefault+ Spec.ReqIf+ Spec.ReqLift+ Spec.ReqLift2+ Spec.ReqWhich
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Justin Bailey <jgbailey@gmail.com>+Copyright (c) 2009, 2018, 2021 Justin Bailey <jgbailey@gmail.com> All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
src/System/Console/HCL.hs view
@@ -4,7 +4,7 @@ /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 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: @@ -12,6 +12,10 @@ * '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 @@ -275,13 +279,15 @@ -} +{-# LANGUAGE ScopedTypeVariables #-} + module System.Console.HCL ( -- * Request type and related functions - Request, - runRequest, execReq, reqIO, makeReq, + Request (..), + runRequest, execReq, reqIO, reqLiftMaybe, makeReq, -- * Request building blocks - reqResp, reqInteger, reqInt, reqRead, + reqResp, reqInteger, reqInt, reqRead, reqChar, reqPassword, -- * Functions lifted into Requests andReq, orReq, notReq, reqIf, reqConst, reqLift, reqLift2, reqMaybe, @@ -296,12 +302,16 @@ ) where import Data.Char (isSpace, toLower, isPrint) -import System.IO (hFlush, stdout) +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 +import qualified Control.Monad.Catch as C {- | The @Request@ data type represents a value requested interactively. The @@ -326,59 +336,97 @@ -> IO (Maybe a) -- ^ Result of the request. runRequest (Request r) = r +{- | +Because we have defined @'Request'@ as @"Applicative"@, +we must also define it as @"Functor"@. -} +instance Functor Request where + fmap = reqLift {- | -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. -} +Because we have defined @'Request'@ as @"Monad"@, +we must also define it as @"Applicative"@. -} +instance Applicative Request where + pure = makeReq + f <*> x = f `andMaybe` \f' -> + fmap f' 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 - return x = makeReq x f >>= g = f `andMaybe` g {- | +Request behavior as a @MonadFail@ covers failure - when +a request results in @Nothing@, -} +instance MonadFail Request where + fail _ = reqFail + +{- | +Because we have defined @'Request'@ as @"MonadPlus"@, we must also +define it as @"Alternative"@. -} +instance Alternative Request where + empty = reqFail + (<|>) = 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 +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 ioVal - where - ioVal = - do - val <- io - return $ Just val +reqIO io = Request $ catch (fmap Just io) $ + \(_ :: IOException) -> return Nothing +-- | Allow throwing exceptions compatible with the exceptions package +instance C.MonadThrow Request where + throwM = Request . C.throwM + +-- | Allow catching exceptions compatible with the exceptions package +instance C.MonadCatch Request where + catch happy exceptional = + Request $ C.catch (runRequest happy) $ runRequest . exceptional + {- | +Lifts a @"Maybe" a@ into a @'Request' a@. -} +reqLiftMaybe :: Maybe a -- ^ the value to lift + -> Request a -- ^ the resulting 'Request' +reqLiftMaybe = Request . 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. @@ -392,19 +440,19 @@ 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. @@ -417,21 +465,42 @@ ((v, _):[]) -> return $ Just v _ -> return 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 $ do + mode <- hGetBuffering stdin + hSetBuffering stdin NoBuffering + val <- getChar + when (val /= '\n') $ putStrLn "" + hSetBuffering stdin mode + return $ Just val {- | +@'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 + hSetEcho stdin False + val <- runRequest reqResp + putStrLn "" + hSetEcho stdin echo + return val + +{- | @&&@ 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@ @@ -439,38 +508,32 @@ 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. @@ -480,9 +543,9 @@ 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. @@ -498,18 +561,14 @@ 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 @@ -521,77 +580,59 @@ 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. +{- | +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 @@ -622,10 +663,10 @@ choice -- | Used to add an individual entry to a menu that is being built. -reqMenuItem :: String - -> Request a - -> [(String, Request a)] - -> [(String, Request a)] +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 label item = (:) (label, item) -- | Creates a submenu within a menu. When the submenu exits, control returns to the item specified. @@ -637,9 +678,9 @@ reqSubMenu prevMenu label subMenu = (:) (label, reqForever $ reqCont (reqMenu subMenu) prevMenu) -- | Causes the program to exit from the current menu. -reqMenuExit :: String - -> [(String, Request a)] - -> [(String, Request a)] +reqMenuExit :: String -- ^ the label, e.g.: @\"quit\"@ + -> [(String, Request a)] -- ^ the menu being built + -> [(String, Request a)] -- ^ the resulting menu reqMenuExit label = (:) (label, reqFail) -- | Ends a list of menu item definitions. @@ -647,15 +688,16 @@ 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 @@ -665,64 +707,43 @@ 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 -produce a value. Though the value returned is itself a request, it -will always be valid. -} +{- | +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 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 @@ -761,7 +782,8 @@ in prompt msgWithDefault (reqDefault req def) --- ^ Deprecated name for prompt1. +{- | +Deprecated name for 'prompt1'. -} promptWithDefault :: (Show a) => String -> Request a -> a -> Request a promptWithDefault = prompt1 @@ -803,7 +825,6 @@ do val <- arbitrary return (RandomRequest $ random val) - coarbitrary = undefined {- | Creates a request which will return a random value or Nothing. The @@ -816,20 +837,6 @@ if rnd then return $ Request (return (Just val)) else return $ Request (return Nothing) - coarbitrary = undefined - --- | QuickCheck does not define arbitrary for Chars for some reason ... -instance Arbitrary Char where - arbitrary = - choose' - where - choose' = - do - val <- choose (minBound, maxBound) - if isPrint val - then return val - else choose' - coarbitrary = undefined -- | Show for random requests. instance (Show a) => Show (RandomRequest a) where
+ test/Spec.hs view
@@ -0,0 +1,42 @@+module Main where + +import Control.Monad +import System.Exit +import Test.HUnit + +import qualified Spec.AndReq as AndReq +import qualified Spec.Constructors as Constructors +import qualified Spec.Monad as Monad +import qualified Spec.MonadCatch as MonadCatch +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 + when (failures counts > 0 || errors counts > 0) + exitFailure + +tests = TestList + [ Constructors.tests + , AndReq.tests + , OrReq.tests + , NotReq.tests + , ReqDefault.tests + , ReqMaybe.tests + , ReqWhich.tests + , ReqIf.tests + , ReqLift.tests + , ReqLift2.tests + , ReqAgree.tests + , Monad.tests + , MonadCatch.tests + , MonadPlus.tests + ]
+ test/Spec/AndReq.hs view
@@ -0,0 +1,21 @@+module Spec.AndReq (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "andReq" $ TestList $ map test' + [ ( Nothing, Nothing, Nothing ) + , ( Just False, Nothing, Just False ) + , ( Just True, Nothing, Nothing ) + , ( Nothing, Just True, Nothing ) + , ( Just False, Just False, Just False ) + , ( Just False, Just True, Just False ) + , ( Just True, Just False, Just False ) + , ( Just True, Just True, Just True ) + ] + +test' (x, y, expect) = let label = show x ++ " andReq " ++ show y + in TestLabel label $ TestCase $ do + val <- runRequest $ reqLiftMaybe x `andReq` reqLiftMaybe y + assertEqual "" val expect
+ test/Spec/Constructors.hs view
@@ -0,0 +1,38 @@+module Spec.Constructors (tests) where++import Test.HUnit++import System.Console.HCL++tests = TestLabel "constructors" $ TestList+ [ makeReqTests+ , reqFailTest+ , reqLiftMaybeTests+ , reqIOTests+ ]++makeReqTests = TestLabel "makeReq" $ TestList $ map makeReqTest [ True, False ]++makeReqTest x = TestLabel (show x) $ TestCase $ do+ val <- runRequest $ makeReq x+ assertEqual "" (Just x) val++reqFailTest = TestLabel "reqFail" $ TestCase $ do+ val <- runRequest (reqFail :: Request ())+ assertEqual "" Nothing val++reqLiftMaybeTests = TestLabel "reqMaybe" $ TestList $ map reqLiftMaybeTest+ [Nothing, Just ()]++reqLiftMaybeTest x = TestLabel (show x) $ TestCase $ do+ val <- runRequest $ reqLiftMaybe x+ assertEqual "" x val++reqIOTests = TestLabel "reqIO" $ TestList $ map reqIOTest+ [ ( "success", return (), Just () )+ , ( "failure", fail "", Nothing )+ ]++reqIOTest (label, x, expect) = TestLabel label $ TestCase $ do+ val <- runRequest $ reqIO x+ assertEqual "" expect val
+ test/Spec/Monad.hs view
@@ -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
+ test/Spec/MonadCatch.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Spec.MonadCatch (tests) where++import Control.Monad.Catch+import Test.HUnit++import System.Console.HCL++tests = TestLabel "Control.Monad.Catch" $ TestList+ [ catchTest+ , noThrowTest+ ]++catchTest = TestLabel "catch" $ TestCase $ do+ val <- runRequest $ catch (throwM TestException >> return False) $+ \(_ :: TestException) -> return True+ assertEqual "" (Just True) val++noThrowTest = TestLabel "catch" $ TestCase $ do+ val <- runRequest $ catch (return False) $+ \(_ :: TestException) -> return True+ assertEqual "" (Just False) val++data TestException = TestException deriving Show+instance Exception TestException
+ test/Spec/MonadPlus.hs view
@@ -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 ""
+ test/Spec/NotReq.hs view
@@ -0,0 +1,16 @@+module Spec.NotReq (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "notReq" $ TestList $ map test' + [ ( Nothing, Nothing ) + , ( Just False, Just True ) + , ( Just True, Just False ) + ] + +test' (x, expect) = let label = "notReq " ++ show x in + TestLabel label $ TestCase $ do + val <- runRequest $ notReq $ reqLiftMaybe x + assertEqual "" expect val
+ test/Spec/OrReq.hs view
@@ -0,0 +1,21 @@+module Spec.OrReq (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "orReq" $ TestList $ map test' + [ ( Nothing, Nothing, Nothing ) + , ( Just True, Nothing, Just True ) + , ( Just False, Nothing, Nothing ) + , ( Nothing, Just True, Nothing ) + , ( Just False, Just False, Just False ) + , ( Just False, Just True, Just True ) + , ( Just True, Just False, Just True ) + , ( Just True, Just True, Just True ) + ] + +test' (x, y, expect) = let label = show x ++ " orReq " ++ show y + in TestLabel label $ TestCase $ do + val <- runRequest $ reqLiftMaybe x `orReq` reqLiftMaybe y + assertEqual "" val expect
+ test/Spec/ReqAgree.hs view
@@ -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
+ test/Spec/ReqDefault.hs view
@@ -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
+ test/Spec/ReqIf.hs view
@@ -0,0 +1,16 @@+module Spec.ReqIf (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "reqIf" $ TestList $ map test' + [ ( Nothing, Nothing ) + , ( Just True, Just 'a' ) + , ( Just False, Just 'b' ) + ] + +test' (x, expect) = let label = "reqIf " ++ show x in + TestLabel label $ TestCase $ do + val <- runRequest $ reqIf (reqLiftMaybe x) (return 'a') (return 'b') + assertEqual "" expect val
+ test/Spec/ReqLift.hs view
@@ -0,0 +1,14 @@+module Spec.ReqLift (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "reqLift" $ TestList $ map test' + [ ( Nothing, Nothing ) + , ( Just 1, Just 2 ) + ] + +test' (x, expect) = TestLabel (show x) $ TestCase $ do + val <- runRequest $ reqLift succ $ reqLiftMaybe x + assertEqual "" expect val
+ test/Spec/ReqLift2.hs view
@@ -0,0 +1,17 @@+module Spec.ReqLift2 (tests) where + +import Test.HUnit + +import System.Console.HCL + +tests = TestLabel "reqLift2" $ TestList $ map test' + [ ( Nothing, Nothing, Nothing ) + , ( Just 1, Nothing, Nothing ) + , ( Nothing, Just 1, Nothing ) + , ( Just 1, Just 1, Just 2 ) + ] + +test' (x, y, expect) = let label = show x ++ " + " ++ show y in + TestLabel label $ TestCase $ do + val <- runRequest $ reqLift2 (+) (reqLiftMaybe x) (reqLiftMaybe y) + assertEqual "" expect val
+ test/Spec/ReqMaybe.hs view
@@ -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
+ test/Spec/ReqWhich.hs view
@@ -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