diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /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 --- 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 @@ 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 @@ 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 --- a/src/System/Console/HCL.hs +++ b/src/System/Console/HCL.hs @@ -350,7 +350,7 @@ 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 @@ 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 @@ 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 @@ _ -> 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 @@ 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 @@ {- | @&&@ 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 @@ 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 @@ 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 @@ 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 @@ 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 = [] {- | -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 @@ 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 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,11 +6,17 @@ 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 @@ , 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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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