HCL 1.5.1 → 1.6

raw patch · 11 files changed

+225/−19 lines, 11 filesdep +HCLdep +HUnitPVP ok

version bump matches the API change (PVP)

Dependencies added: HCL, HUnit

API changes (from Hackage documentation)

Files

• HCL.cabal +21/−5
• src/System/Console/HCL.hs +33/−14
• test/Spec.hs +28/−0
• test/Spec/AndReq.hs +23/−0
• test/Spec/Common.hs +9/−0
• test/Spec/Constructors.hs +17/−0
• test/Spec/NotReq.hs +18/−0
• test/Spec/OrReq.hs +23/−0
• test/Spec/ReqIf.hs +18/−0
• test/Spec/ReqLift.hs +16/−0
• test/Spec/ReqLift2.hs +19/−0

@@ -1,5 +1,5 @@ Name:           HCL-Version:        1.5.1+Version:        1.6 License:        BSD3 Author:         Justin Bailey Homepage:       http://github.com/m4dc4p/hcl/tree/master@@ -14,8 +14,7 @@   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.-cabal-version: >= 1.6-+cabal-version: >= 1.8 Data-files: hangman/2of12.txt  Library@@ -24,6 +23,23 @@   Hs-Source-Dirs: src  Executable hangman-  Build-Depends:  base >= 4.7 && < 5, QuickCheck == 2.*, mtl, random, containers+  Build-Depends:  base >= 4.7 && < 5, QuickCheck == 2.*, mtl, random, containers, HCL   Main-Is:        Hangman.hs-  Hs-Source-Dirs: hangman, src+  Hs-Source-Dirs: hangman+  other-modules:  Paths_HCL++test-suite HCL-test+  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+  other-modules:+    Spec.AndReq+    Spec.Constructors+    Spec.Common+    Spec.NotReq+    Spec.OrReq+    Spec.ReqIf+    Spec.ReqLift+    Spec.ReqLift2

@@ -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:
 
@@ -14,7 +14,7 @@ 
  * '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.
+ * 'reqPassword' - Like 'reqResp', but doesn't echo the user's input to the console.
 
  * 'reqRead' - Requests "Read"-able values.
 
@@ -305,7 +305,8 @@ import System.IO.Unsafe (unsafePerformIO)
 import System.Random
 import Data.Maybe (isNothing, isJust)
-import Control.Monad (when)
+import Control.Applicative (Alternative (..))
+import Control.Monad (when, MonadPlus)
 import Control.Monad.Trans 
 
 {- |
@@ -332,21 +333,21 @@ runRequest (Request r) = r
 
 {- |
-Because we have defined @Request@ as @Applicative@,
-we must also define it as @Functor@. -}
+Because we have defined @'Request'@ as @"Applicative"@,
+we must also define it as @"Functor"@. -}
 instance Functor Request where
   fmap = reqLift
 
 {- |
-Because we have defined @Request@ as @Monad@,
-we must also define it as @Applicative@. -}
+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@ 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. -}
@@ -355,6 +356,22 @@   fail _ = reqFail
 
 {- |
+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
+
+{- |
+'Request' behaviour as a @"MonadPlus"@ allows for successive fallback
+requests to be used on failure. -}
+instance MonadPlus Request
+
+{- |
 Takes a value and makes it into a request. Should
 not be an @IO (Maybe a)@ type value, unless
 multiply nested values is desired. -}
@@ -628,7 +645,8 @@       Nothing -> return $ Just def
       v -> return v
 
--- Ask a request forever -- until failure. 
+{- |
+Ask a request forever -- until failure. -}
 reqForever :: Request a -- ^ Request to ask forever.
               -> Request a -- ^ Result.
 reqForever req =
@@ -727,10 +745,10 @@       Left _ -> cont
       Right val -> return val
 
-{-
-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
+{- |
+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. -}
 reqWhich :: Request a -- ^ Request to evaluate.
             -> Request (Either () a) -- ^ Result.
@@ -802,7 +820,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
 

@@ -0,0 +1,28 @@+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.NotReq as NotReq
+import qualified Spec.OrReq as OrReq
+import qualified Spec.ReqIf as ReqIf
+import qualified Spec.ReqLift as ReqLift
+import qualified Spec.ReqLift2 as ReqLift2
+
+main = do
+  counts <- runTestTT tests
+  when (failures counts > 0 || errors counts > 0)
+    exitFailure
+
+tests = TestList
+  [ Constructors.tests
+  , AndReq.tests
+  , OrReq.tests
+  , NotReq.tests
+  , ReqIf.tests
+  , ReqLift.tests
+  , ReqLift2.tests
+  ]

@@ -0,0 +1,23 @@+module Spec.AndReq (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+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 $ req x `andReq` req y
+    assertEqual "" val expect

@@ -0,0 +1,9 @@+module Spec.Common where++import Test.HUnit++import System.Console.HCL++req x = case x of+  Just x  -> makeReq x+  Nothing -> reqFail

@@ -0,0 +1,17 @@+module Spec.Constructors (tests) where++import Test.HUnit++import System.Console.HCL++tests = TestLabel "constructors" $ TestList [makeReqTests, reqFailTest]++makeReqTests = TestLabel "makeReq" $ TestList $ map test' [ True, False ]++test' 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

@@ -0,0 +1,18 @@+module Spec.NotReq (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+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 $ req x
+    assertEqual "" expect val

@@ -0,0 +1,23 @@+module Spec.OrReq (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+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 $ req x `orReq` req y
+    assertEqual "" val expect

@@ -0,0 +1,18 @@+module Spec.ReqIf (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+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 (req x) (return 'a') (return 'b')
+    assertEqual "" expect val

@@ -0,0 +1,16 @@+module Spec.ReqLift (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+tests = TestLabel "reqLift" $ TestList $ map test'
+  [ ( Nothing, Nothing )
+  , ( Just 1,  Just 2  )
+  ]
+
+test' (x, expect) = TestLabel (show x) $ TestCase $ do
+  val <- runRequest $ reqLift succ $ req x
+  assertEqual "" expect val

@@ -0,0 +1,19 @@+module Spec.ReqLift2 (tests) where
+
+import Test.HUnit
+
+import System.Console.HCL
+
+import Spec.Common
+
+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 (+) (req x) (req y)
+    assertEqual "" expect val