packages feed

TLT 0.1.0.1 → 0.5.0.0

raw patch · 13 files changed

Files

ChangeLog.md view
@@ -1,3 +1,26 @@ # Changelog for TLT +- 0.5.0 :: Add a variation of @noUncaught@ to disguish @Show@ and+  non-@Show@ exception types in TLT failure reporting.+  +  Various improvement to the documentation.++- 0.4.0 :: Adding a class, instance declarations, and functions for+  inspecting exceptions thrown from an `ExceptT` transformer layer.+  +  Corrections to the Haddock documentation.++- 0.3.0 :: Significant refactoring, organizing the contents of the+  module @Test.TLT@ into submodules, with @Test.TLT@ only re-exporting+  the core functionality.++- 0.2.0 :: Divided the `tlt` function for running tests, to separate+  `tltCore` for just running tests from formatted output of test+  results.  The former is intended for running TLT in other+  frameworks.  Also prunes some unneeded dependencies.++- 0.1.0 :: First release.  Patch 1 re-arranged documentation.+ ## Unreleased changes++None in this version.
README.md view
@@ -84,12 +84,39 @@ terms of organizing the output you see in the final report of tests run. -Finally, it is straightforward to write new `Assertion`s for-project-specific test criteria: they are simply functions returning-monadic values.  There are several functions in the final section of-this document which transform pure predicates into `Assertion`s, or-which transform one form of `Assertion` into another.+It is straightforward to write new `Assertion`s for project-specific+test criteria: they are simply functions returning monadic values.+There are several functions in the final section of this document+which transform pure predicates into `Assertion`s, or which transform+one form of `Assertion` into another. +There are also special forms for validating the normal termination of+computations including an `ExceptT` monad transformer layer:++ - `noUncaught` and `noUncaught_` each take an `ExceptT` computation+   (which may itself contain additional TLT tests) as an argument, and+   expects that computation to finish without finding an uncaught+   exception thrown from it.  The `noUncaught` function requires the+   exception type to be an instance of `Show`; the `noUncaught_`+   function operates on any exception.++ - `uncaught` also takes an `ExceptT` computation as an argument, but+   does expects it to throw an uncaught exception.  This computation+   may contain additional TLT tests, but it should be noted that any+   tests which would have been executed after a `throwE` will either+   be executed, nor be recorded for test result reporting.++ - `uncaughtWith` is like `uncaught`, but takes an additional function+   argument which receives the thrown exception for additional+   examination.+   +These three functions generally require a declaration of an instance+of `MonadTLTExcept` for the monadic type under test.  This class+decribes the relationship among the overall monad stack, the `ExceptT`+layer with it, and the TLT transformer within the `ExceptT` layer.+With these inclusion requirements, these functions do require a more+specific monad stack structure than the rest of TLT.+ # Examples  These examples are from the sample executables and test suite of@@ -221,3 +248,47 @@ from the executions of the `MnT`s for assembly into an overall test declaration. +## Testing with exceptions++These tests will pass:++    do+      noUncaught "extest1" $ do+        "6 is 6 as pure assertion" ~: 6 @==- 6+        "7 is 7 as pure assertion" ~: 7 @==- 7+      uncaught "extest2" $ do+        "8 is 8 as pure assertion" ~: 8 @==- 8+        throwE "Boom"+        "9 is 9 as pure assertion" ~: 9 @==- 9+      uncaughtWith "extest3"+	    (do "10 is 10 as pure assertion" ~: 10 @==- 10+            throwE "Boom"+            11 is 11 as pure assertion" ~: 11 @==- 11) h+        (\e -> "The exception should be \"Boom\""+                 ~: "Boom" @==- e)++This test will fail because it expects no thrown exceptions, but does+observe one:++    noUncaught "extest1x" $ do+      "6 is 6 as pure assertion" ~: 6 @==- 6+      throwE "Boom"+      "7 is 7 as pure assertion" ~: 7 @==- 7++This test will fail because it expects a thrown exception, but the+subcomputation ends normally:++    uncaught "extest2x" $ do+      "8 is 8 as pure assertion" ~: 8 @==- 8+      "9 is 9 as pure assertion" ~: 9 @==- 9++Finally, this test will record an error +against `"The exception should be \"Boom\""`,+although no error will be logged against `"extest3x"`+since only the absence of an exception would be logged at that point.++    uncaughtWith "extest3x"+	  (do throwE "Bang"+          "10 is 10 as pure assertion" ~: 10 @==- 10+          "11 is 11 as pure assertion" ~: 11 @==- 11)+	  (\e -> lift ("The exception should be \"Boom\"" ~: "Boom" @==- e)
TLT.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           TLT-version:        0.1.0.1+version:        0.5.0.0 synopsis:       Testing in monads and transformers without explicit specs-description:    A small unit test system oriented with an emphasis on examining intermediate results of computations in monad transformers.  The Test.TLT Haddock page is the main piece of documentation; or see also the GitHub repository <https://github.com/jphmrst/TLT/>.+description:    A quick-and-dirty unit test system without test specifications, motivated by easy examination of intermediate results of computations in monad transformers.  See the GitHub repository <https://github.com/jphmrst/TLT/> for documentation, or the Haddock page for additional examples. category:       Test homepage:       https://github.com/jphmrst/TLT#readme bug-reports:    https://github.com/jphmrst/TLT/issues@@ -28,20 +28,24 @@ library   exposed-modules:       Test.TLT+      Test.TLT.Assertion+      Test.TLT.Buffer+      Test.TLT.Class+      Test.TLT.Options+      Test.TLT.Report+      Test.TLT.Results+      Test.TLT.Standard   other-modules:       Paths_TLT   hs-source-dirs:       src   build-depends:-      HUnit >=1.6.2 && <1.7-    , STMonadTrans >=0.4.6 && <0.5+      STMonadTrans >=0.4.6 && <0.5     , ansi-terminal >=0.11.1 && <0.12-    , base (>=4.14.1 && <4.15) || (>=4.15.1 && <4.16) || (>=4.16.0 && <4.17)-    , either >=5.0.1 && <5.1+    , base >=4.14.1 && <4.15 || >=4.15.1 && <4.16 || >=4.16.0 && <4.17     , free >=5.1.7 && <5.2     , mtl >=2.2.2 && <2.3     , resourcet >=1.2.4 && <1.3-    , symbol >=0.2.4 && <0.3     , transformers >=0.5.6 && <0.6   default-language: Haskell2010 @@ -53,16 +57,13 @@       app   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      HUnit >=1.6.2 && <1.7-    , STMonadTrans >=0.4.6 && <0.5+      STMonadTrans >=0.4.6 && <0.5     , TLT     , ansi-terminal >=0.11.1 && <0.12-    , base (>=4.14.1 && <4.15) || (>=4.15.1 && <4.16) || (>=4.16.0 && <4.17)-    , either >=5.0.1 && <5.1+    , base >=4.14.1 && <4.15 || >=4.15.1 && <4.16 || >=4.16.0 && <4.17     , free >=5.1.7 && <5.2     , mtl >=2.2.2 && <2.3     , resourcet >=1.2.4 && <1.3-    , symbol >=0.2.4 && <0.3     , transformers >=0.5.6 && <0.6   default-language: Haskell2010 @@ -75,15 +76,12 @@       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      HUnit >=1.6.2 && <1.7-    , STMonadTrans >=0.4.6 && <0.5+      STMonadTrans >=0.4.6 && <0.5     , TLT     , ansi-terminal >=0.11.1 && <0.12-    , base (>=4.14.1 && <4.15) || (>=4.15.1 && <4.16) || (>=4.16.0 && <4.17)-    , either >=5.0.1 && <5.1+    , base >=4.14.1 && <4.15 || >=4.15.1 && <4.16 || >=4.16.0 && <4.17     , free >=5.1.7 && <5.2     , mtl >=2.2.2 && <2.3     , resourcet >=1.2.4 && <1.3-    , symbol >=0.2.4 && <0.3     , transformers >=0.5.6 && <0.6   default-language: Haskell2010
app/Failing.hs view
@@ -1,10 +1,14 @@ import Test.TLT+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans+import Control.Monad  main :: IO () main = do-  tlt test+  tlt $ runExceptT test -test :: Monad m => TLT m ()+test :: ExceptT String (TLT IO) () test = do   "True passes" ~::- True   "2 is 3 as single Bool" ~::- 2 == 3@@ -21,3 +25,26 @@     "2 not 2" ~: 2 @/=- 2   "2 not 3 as result" ~: 2 @/= return 3   "2 not 2 as result" ~: 2 @/= return 2+  noUncaught "extest1" $ do+    "6 is 6 as pure assertion" ~: 6 @==- 6+    "7 is 7 as pure assertion" ~: 7 @==- 7++  noUncaught "extest1x" $ do+    "6 is 6 as pure assertion" ~: 6 @==- 6+    throwE "Boom"+    "7 is 7 as pure assertion" ~: 7 @==- 7+  uncaught "extest2" $ do+    "8 is 8 as pure assertion" ~: 8 @==- 8+    throwE "Boom"+    "9 is 9 as pure assertion" ~: 9 @==- 9+  uncaught "extest2x" $ do+    "8 is 8 as pure assertion" ~: 8 @==- 8+    "9 is 9 as pure assertion" ~: 9 @==- 9++  uncaughtWith "extest3" (do "10 is 10 as pure assertion" ~: 10 @==- 10+                             throwE "Boom"+                             "11 is 11 as pure assertion" ~: 11 @==- 11) h+  uncaughtWith "extest3x" (do "10 is 10 as pure assertion" ~: 10 @==- 10+                              "11 is 11 as pure assertion" ~: 11 @==- 11) h+  where h :: String -> ExceptT String (TLT IO) ()+        h e = lift ("The exception should be \"Boom\"" ~: "Boom" @==- e)
src/Test/TLT.hs view
@@ -14,607 +14,203 @@ tests are simply commands in a monad stack which includes the transformer layer @Test.TLT@. -This Haddock page is the main piece of documentation; or see also the-GitHub repository <https://github.com/jphmrst/TLT/>.+This module is a re-exporter for the various @Test.TLT.*@+modules which define distinct portions of the TLT system.  These+exports are oriented towards the simple use of TLT as a test+framework.  When using TLT more programmatically, such as when+integrating TLT into another test framework, it may be necessary+to import the more internally-oriented functions of the+individual modules.  -} -{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module Test.TLT (-  -- * The TLT transformer-  TLT, tlt, MonadTLT, liftTLT,-  -- ** Session options-  reportAllTestResults, setExitAfterFailDisplay,-  -- * Writing tests-  Assertion,-  -- ** `TLT` commands-  (~:), (~::), (~::-), tltFail, inGroup,-  -- ** Assertions-  -- *** About the values of pure expressions of `Eq`- and `Ord`-type-  (@==),  (@/=),  (@<),  (@>),  (@<=),  (@>=),-  -- *** About monadic computations returing `Eq`s and `Ord`s-  (@==-), (@/=-), (@<-), (@>-), (@<=-), (@>=-),-  -- *** About list values-  empty, nonempty, emptyP, nonemptyP,-  -- *** About `Maybe` values-  nothing, nothingP, assertFailed, assertSuccess,-  -- ** Building new assertions-  -- *** Unary assertions-  liftAssertionPure, assertionPtoM, liftAssertionM,-  -- *** Binary assertions-  liftAssertion2Pure, assertion2PtoM, liftAssertion2M -  ) where--import Data.Maybe-import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.ST.Trans-import Control.Monad.Trans.Class--- import Control.Monad.Trans.Either-import Control.Monad.Trans.Free-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Resource-import Control.Monad.Trans.State.Strict-import qualified Control.Monad.Trans.State.Lazy as SL-import qualified Control.Monad.Trans.Writer.Lazy as WL-import qualified Control.Monad.Trans.Writer.Strict as WS-import System.Console.ANSI-import System.Exit---- * Results of tests---- |Reasons why a test might fail.-data TestFail = Asserted String-                -- ^ A failure arising from an `Assertion` which is not met.-              | Erred String-                -- ^ A failure associated with a call to a Haskell-                -- function triggering an error.--formatFail :: TestFail -> String-formatFail (Asserted s) = s-formatFail (Erred s) = "Assertion raised exception: " ++ s---- |An assertion is a computation (typically in the monad wrapped by--- `TLT`) which returns a list of zero of more reasons for the failure--- of the assertion.  A successful computation returns an empty list:--- no reasons for failure, hence success.-type Assertion m = m [TestFail]---- |Hierarchical structure holding the result of running tests,--- possibly grouped into tests.-data TestResult = Test String [TestFail]-                | Group String Int Int [TestResult]-                  -- ^ The `Int`s are respectively the total number of-                  -- tests executed, and total number of failures-                  -- detected.---- |Return the number of failed tests reported in a `TestResult`.-failCount :: TestResult -> Int-failCount (Test _ []) = 0-failCount (Test _ _) = 1-failCount (Group _ _ n _) = n--testCount :: TestResult -> Int-testCount (Test _ _) = 1-testCount (Group _ n _ _) = n--totalFailCount :: [TestResult] -> Int-totalFailCount = foldr (+) 0 . map failCount--totalTestCount :: [TestResult] -> Int-totalTestCount = foldr (+) 0 . map testCount---- |Report the results of tests.-report :: TLTopts -> [TestResult] -> IO ()-report (TLTopts showPasses exitAfterFailDisplay) trs =-  let fails = totalFailCount trs-      tests = totalTestCount trs-  in do report' "" trs-        if fails > 0-          then do boldRed-                  putStrLn $-                    "Found " ++ show fails ++ " error"-                      ++ (if fails > 1 then "s" else "")-                      ++ " in " ++ show tests ++ " tests; exiting"-                  mediumBlack-                  when exitAfterFailDisplay exitFailure-          else do boldGreen-                  putStrLn $ show tests ++ " test"-                    ++ (if tests > 1 then "s" else "")-                    ++ " passing."-                  mediumBlack-  where report' ind trs = forM_ trs $ \ tr ->-          when (failCount tr > 0 || showPasses) $-            case tr of-              Test s r -> do-                putStr $ ind ++ "- " ++ s ++ ": "-                case r of-                  [] -> do-                    greenPass-                    putStrLn ""-                  x : [] -> do-                    redFail-                    putStrLn $ " " ++ formatFail x-                  _ -> do-                    redFail-                    putStrLn ":"-                    forM_ r $ \ f -> putStrLn $ ind ++ "- " ++ formatFail f-              Group s _ _ trs' -> do-                putStrLn $ ind ++ "- " ++ s ++ ":"-                report' ("  " ++ ind) trs'--boldBlack = setSGR [-  SetColor Foreground Vivid Black, SetConsoleIntensity BoldIntensity ]-boldRed = setSGR [-  SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity ]-boldGreen = setSGR [-  SetColor Foreground Vivid Green, SetConsoleIntensity BoldIntensity ]--mediumRed = setSGR [-  SetColor Foreground Vivid Red, SetConsoleIntensity NormalIntensity ]-mediumGreen = setSGR [-  SetColor Foreground Vivid Green, SetConsoleIntensity NormalIntensity ]-mediumBlue = setSGR [-  SetColor Foreground Vivid Blue, SetConsoleIntensity NormalIntensity ]-mediumBlack = setSGR [-  SetColor Foreground Vivid Black, SetConsoleIntensity NormalIntensity ]--greenPass = do-  mediumBlue-  putStr "Pass"-  mediumBlack--redFail = do-  boldRed-  putStr "FAIL"-  mediumBlack---- |Accumulator for test results, in the style of a simplified Huet's--- zipper which only ever adds to the end of the structure.-data TRBuf = Buf TRBuf Int Int String [TestResult] | Top Int Int [TestResult]---- |Add a single test result to a `TRBuf`.-addResult :: TRBuf -> TestResult -> TRBuf-addResult (Top tc fc trs) tr =-  Top (tc + testCount tr) (fc + failCount tr) $ tr : trs-addResult (Buf up tc fc s trs) tr =-  Buf up (tc + testCount tr) (fc + failCount tr) s $ tr : trs---- |Convert the topmost group of a bottom-up `TRBuf` into a completed--- top-down report about the group.-currentGroup :: TRBuf -> TestResult-currentGroup (Buf up tc fc s trs) = Group s tc fc (reverse trs)---- |Derive a new `TRBuf` corresponding to finishing the current group--- and continuing to accumulate results into its enclosure.-popGroup :: TRBuf -> TRBuf-popGroup trb@(Buf acc _ _ _ _) = addResult acc $ currentGroup trb---- |Convert a `TRBuf` into a list of top-down `TestResult`s.-closeTRBuf :: TRBuf -> [TestResult]-closeTRBuf (Top _ _ ts) = reverse ts-closeTRBuf b = closeTRBuf $ popGroup b---- |Record of options which may be specified for running and reporting--- TLT tests.-data TLTopts = TLTopts {-  optShowPasses :: Bool,-  optQuitAfterFailReport :: Bool-}---- |Default initial options-defaultOpts = TLTopts False True---- |Update the display of showing passes in a `TLTopts` record.-withShowPasses :: TLTopts -> Bool -> TLTopts-withShowPasses (TLTopts _ f) b = TLTopts b f---- |Update the display of showing passes in a `TLTopts` record.-withExitAfterFail :: TLTopts -> Bool -> TLTopts-withExitAfterFail (TLTopts p _) b = TLTopts p b---- |Synonym for the elements of the `TLT` state.-type TLTstate = (TLTopts, TRBuf)---- |Monad transformer for TLT tests.  This layer stores the results--- from tests as they are executed.-newtype Monad m => TLT m r = TLT { unwrap :: StateT TLTstate m r }-  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)--{- ------------------------------------------------------------ -}---- |Extending `TLT` operations across other monad transformers.  For--- easiest and most flexible testing, declare the monad transformers--- of your application as instances of this class.-class (Monad m, Monad n) => MonadTLT m n | m -> n where-  -- |Lift TLT operations within a monad transformer stack.  Note that-  -- with enough transformer types included in this class, the-  -- @liftTLT@ function should usually be unnecessary: the commands in-  -- this module which actually configure testing, or specify a test,-  -- already @liftTLT@ their own result.  So they will all act as-  -- top-level transformers in @MonadTLT@.-  liftTLT :: TLT n a -> m a--instance Monad m => MonadTLT (TLT m) m where-  liftTLT = id--instance (MonadTLT m n, Functor f) => MonadTLT (FreeT f m) n where-    liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (IdentityT m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (MaybeT m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (ReaderT r m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (ResourceT m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (StateT s m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (SL.StateT s m) n where-  liftTLT = lift . liftTLT--instance MonadTLT m n => MonadTLT (STT s m) n where-  liftTLT = lift . liftTLT--instance (MonadTLT m n, Monoid w) => MonadTLT (WL.WriterT w m) n where-  liftTLT = lift . liftTLT--instance (MonadTLT m n, Monoid w) => MonadTLT (WS.WriterT w m) n where-  liftTLT = lift . liftTLT--{- ------------------------------------------------------------ -}---- |Execute the tests specified in a `TLT` monad, and report the--- results.-tlt :: MonadIO m => TLT m r -> m ()-tlt (TLT t) = do-  liftIO $ putStrLn "Running tests:"-  (_, (opts, resultsBuf)) <- runStateT t $ (defaultOpts, Top 0 0 [])-  liftIO $ report opts $ closeTRBuf resultsBuf---- |This function controls whether `tlt` will report only tests which--- fail, suppressing any display of tests which pass, or else report--- the results of all tests.  The default is the former: the idea is--- that no news should be good news, with the programmer bothered only--- with problems which need fixing.-reportAllTestResults :: MonadTLT m n => Bool -> m ()-reportAllTestResults b = liftTLT $ TLT $ do-  (opts, tr) <- get-  put $ (opts `withShowPasses` b, tr)---- |This function controls whether `tlt` will exit after displaying--- test results which include at least one failing test.  By default,--- it will exit in this situation.  The idea is that a test suite can--- be broken into parts when it makes sense to run the latter parts--- only when the former parts all pass.-setExitAfterFailDisplay :: MonadTLT m n => Bool -> m ()-setExitAfterFailDisplay b = liftTLT $ TLT $ do-  (opts, tr) <- get-  put $ (opts `withExitAfterFail` b, tr)---- |Report a failure.  Useful in pattern-matching cases which are--- entirely not expected.-tltFail :: MonadTLT m n => String -> String -> m ()-desc `tltFail` detail = liftTLT $ TLT $ do-  (opts, before) <- get-  let after = addResult before $ Test desc [Asserted detail]-  put (opts, after)---- |Organize the tests in the given subcomputation as a separate group--- within the test results we will report.-inGroup :: MonadTLT m n => String -> m a -> m a-inGroup name group = do-  (opts, before) <- liftTLT $ TLT get-  liftTLT $ TLT $ put $ (opts, Buf before 0 0 name [])-  result <- group-  (opts', after) <- liftTLT $ TLT $ get-  liftTLT $ TLT $ put $ (opts', popGroup after)-  return result---- * Specifying individual tests--infix 0 ~:, ~::, ~::----- |Label and perform a test of an `Assertion`.------ ===== Example------ > test :: Monad m => TLT m ()--- > test = do--- >   "2 is 2 as result" ~: 2 @== return 2    -- This test passes.--- >   "2 not 3" ~: 2 @/=- 3                   -- This test fails.-(~:) :: MonadTLT m n => String -> Assertion m -> m ()-s ~: a = do-  (opts, oldState) <- liftTLT $ TLT $ get-  assessment <- a-  liftTLT $ TLT $ put (opts, addResult oldState $ Test s assessment)---- |Label and perform a test of a (pure) boolean value.------ ===== Example------ > test :: Monad m => TLT m ()--- > test = do--- >   "True passes" ~::- return True                 -- This test passes.--- >   "2 is 2 as single Bool" ~::- return (2 == 2)   -- This test passes.--- >   "2 is 3!?" ~::- myFn 4 "Hammer"                -- Passes if myFn (which--- >                                                  -- must be monadic)--- >                                                  -- returns True.-(~::-) :: MonadTLT m n => String -> Bool -> m ()-s ~::- b = do-  (opts, oldState) <- liftTLT $ TLT $ get-  liftTLT $ TLT $ put (opts, addResult oldState $ Test s $-        if b then [] else [Asserted $ "Expected True but got False"])---- |Label and perform a test of a boolean value returned by a--- computation in the wrapped monad @m@.------ ===== Example------ > test :: Monad m => TLT m ()--- > test = do--- >   "True passes" ~::- True               -- This test passes.--- >   "2 is 2 as single Bool" ~::- 2 == 2   -- This test passes.--- >   "2 is 3!?" ~::- 2 == 2                -- This test fails.-(~::) :: MonadTLT m n => String -> m Bool -> m ()-s ~:: bM = do-  b <- bM-  (opts, oldState) <- liftTLT $ TLT $ get-  liftTLT $ TLT $ put (opts, addResult oldState $ Test s $-        if b then [] else [Asserted $ "Expected True but got False"])--infix 1 @==,  @/=,  @<,  @>,  @<=,  @>=-infix 1 @==-, @/=-, @<-, @>-, @<=-, @>=----- |Transform a binary function on an expected and an actual value--- (plus a binary generator of a failure message) into an `Assertion`--- for a pure given actual value.------ ===== Example------ TLT's scalar-testing operators like @\@==-@ are defined with this--- function:------ > (@==-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m--- > (@==-) = liftAssertion2Pure (==) $--- >   \ exp actual -> "Expected " ++ show exp ++ " but got " ++ show actual------ The `(==)` operator tests equality, and the result here allows the--- assertion that a value should be exactly equal to a target.  The--- second argument formats the detail reported when the assertion--- fails.-liftAssertion2Pure ::-  (Monad m) => (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m-liftAssertion2Pure tester explainer exp actual = return $-  if (tester exp actual) then [] else [Asserted $ explainer exp actual]---- |Given an `Assertion` for two pure values (expected and actual),--- lift it to an `Assertion` expecting the actual value to be returned--- from a computation.------ ===== Examples------ The TLT assertion `(@==)` lifts `(@==-)` from expecting a pure--- actual result to expecting a computation returning a value to test.------ > (@==) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m--- > (@==) = assertion2PtoM (@==-)-assertion2PtoM ::-  (Monad m) => (a -> a -> Assertion m) -> a -> m a -> Assertion m-assertion2PtoM pa exp actualM = do actual <- actualM-                                   pa exp actual---- |Transform a binary function on expected and actual values (plus--- a generator of a failure message) into an `Assertion` where the--- actual value is to be returned from a subcomputation.-liftAssertion2M ::-  (Monad m) => (a -> a -> Bool) -> (a -> a -> String) -> a -> m a -> Assertion m-liftAssertion2M tester explainer exp actualM =-  let assertPure = liftAssertion2Pure tester explainer exp-  in do actual <- actualM-        assertPure actual---- |Assert that two values are equal.  This assertion takes an--- expected and an actual /value/; see `(@==)` to compare the result--- of a /monadic computation/ to an expected value.------ ===== Examples------ > test :: Monad m => TLT m ()--- > test = do--- >   "Make sure that 2 is still equal to itself" ~: 2 @==- 2--- >   "Make sure that there are four lights" ~: 4 @==- length lights-(@==-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m-(@==-) = liftAssertion2Pure (==) $-  \ exp actual -> "Expected " ++ show exp ++ " but got " ++ show actual---- |Assert that a calculated value is as expected.  This assertion--- compare the result of a /monadic computation/ to an expected value;--- see `(@==-)` to compare an /actual value/ to the expected value.------ ===== Examples------ > test :: Monad m => TLT m ()--- > test = do--- >   "Make sure that 2 is still equal to itself" ~: 2 @== return 2--- >   "Make sure that there are four lights" ~: 4 @== countLights--- >                                             -- where countLights :: m Int-(@==) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m-(@==) = assertion2PtoM (@==-)---- |Assert that two values are not equal.  This assertion takes an--- expected and an actual /value/; see `(@/=)` to compare the result--- of a /monadic computation/ to an expected value.-(@/=-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m-(@/=-) = liftAssertion2Pure (/=) $-  \ exp actual ->-    "Expected other than " ++ show exp ++ " but got " ++ show actual---- |Assert that a calculated value differs from some known value.--- This assertion compares the result of a /monadic computation/ to an--- expected value; see `(@/=-)` to compare an /actual value/ to the--- expected value.-(@/=) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m-(@/=) = assertion2PtoM (@/=-)---- |Assert that a given boundary is strictly less than some value.--- This assertion takes an expected and an actual /value/; see `(@<)`--- to compare the result of a /monadic computation/ to an expected--- value.-(@<-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m-(@<-) = liftAssertion2Pure (<) $-  \ exp actual ->-    "Lower bound (open) is " ++ show exp ++ " but got " ++ show actual---- |Assert that a given, constant boundary is strictly less than some--- calculated value.  This assertion compares the result of a /monadic--- computation/ to an expected value; see `(@<-)` to compare an--- /actual value/ to the expected value.-(@<) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m-(@<) = assertion2PtoM (@<-)---- |Assert that a given boundary is strictly less than some value.--- This assertion takes an expected and an actual /value/; see `(@>)`--- to compare the result of a /monadic computation/ to an expected--- value.-(@>-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m-(@>-) = liftAssertion2Pure (>) $-  \ exp actual ->-    "Upper bound (open) is " ++ show exp ++ " but got " ++ show actual---- |Assert that a given, constant boundary is strictly less than some--- calculated value.  This assertion compares the result of a /monadic--- computation/ to an expected value; see `(@>-)` to compare an--- /actual value/ to the expected value.-(@>) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m-(@>) = assertion2PtoM (@>-)+  -- * Introduction and basic use --- |Assert that a given boundary is strictly less than some value.--- This assertion takes an expected and an actual /value/; see `(@<=)`--- to compare the result of a /monadic computation/ to an expected--- value.-(@<=-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m-(@<=-) = liftAssertion2Pure (<=) $-  \ exp actual ->-    "Lower bound (closed) is " ++ show exp ++ " but got " ++ show actual+  -- | The basic use of TLT is a call to @tlt@ in the @main@ function+  -- of a program, followed by a monadic computation which asserts+  -- various properties about the results it calculates.  For example:+  --+  -- > main :: IO ()+  -- > main = tlt $ runExceptT test+  -- >   "True passes" ~::- True+  -- >   "1 and 1 make 2" ~: 2 @== return (1 + 1) --- |Assert that a given, constant boundary is strictly less than some--- calculated value.  This assertion compares the result of a /monadic--- computation/ to an expected value; see `(@<=-)` to compare an--- /actual value/ to the expected value.-(@<=) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m-(@<=) = assertion2PtoM (@<=-)+  tlt, --- |Assert that a given boundary is strictly less than some value.--- This assertion takes an expected and an actual /value/; see `(@>=)`--- to compare the result of a /monadic computation/ to an expected--- value.-(@>=-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m-(@>=-) = liftAssertion2Pure (>=) $-  \ exp actual ->-    "Upper bound (closed) is " ++ show exp ++ " but got " ++ show actual+  -- ** Writing tests --- |Assert that a given, constant boundary is strictly less than some--- calculated value.  This assertion compares the result of a /monadic--- computation/ to an expected value; see `(@>=-)` to compare an--- /actual value/ to the expected value.-(@>=) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m-(@>=) = assertion2PtoM (@>=-)+  -- | The two tests in the example above have the common form of one+  -- individual TLT test:+  --+  -- >  LABLE TEST-OPERATOR EXPRESSION+  --+  -- There are three @TEST-OPERATOR@s, corresponding to three+  -- different forms of @EXPRESSION@:+  --+  -- +----------+----------------------------------------------------++  -- | OPERATOR | EXPRESSION                                         |+  -- +==========+====================================================++  -- | `~:`     | The expression is an assertion written with one of |+  -- |          | the several operators below.                       |+  -- +----------+----------------------------------------------------++  -- | `~::`    | The expression is a monadic computation returning  |+  -- |          | a boolean value, where @True@ corresponds to the   |+  -- |          | test passing.                                      |+  -- +----------+----------------------------------------------------++  -- | `~::-`   | The expression is a simple boolean value, where    |+  -- |          | again @True@ corresponds to the test passing.      |+  -- +----------+----------------------------------------------------++  --+  -- The last two of these test-introducung operations show a pattern+  -- that recrus throughout TLT: where two operators differ only where+  -- one has a trailing hyphen, the version __without__ the hyphen+  -- refers to a monadic computation, and the version __with__ the+  -- hyphen refers to a pure expression. --- |This assertion always fails with the given message.-assertFailed :: Monad m => String -> Assertion m-assertFailed msg = return [Asserted msg]+  -- | There are a number of special forms of test, and commands for+  -- setting session options.+  --+  --    * The `tltFail` function introduces a test which always fails.+  --      This function is useful in pattern matches, for wholly+  --      unacceptable combinations.+  --+  --    * The `reportAllTestResults` function controls whether TLT+  --      (when invoked with `tlt` as described above) should display+  --      only tests which fails, or should display all passing tests+  --      as well.  The former is the default, since the latter can be+  --      quite verbose.+  --+  --    * The `setExitAfterFailDisplay` function directs `tlt` to exit+  --      after displaying a set of test results which include at *+  --      least one failing test. The idea of this default is that a *+  --      test suite can be broken into parts when it makes sense to *+  --      run the latter parts only when the former parts all pass.+  --+  --    * The `inGroup` function groups several tests together as a+  --      single group.  The `tlt` function displays the tests of a+  --      group indented, which helps to visually group related tests+  --      together.+  --+  -- All of these test and option forms are formally documented below. --- |This assertion always succeeds.-assertSuccess :: Monad m => Assertion m-assertSuccess = return []+  -- ** Writing standard assertions --- |Transform a unary function on a value (plus a generator of a--- failure message) into a unary function returning an `Assertion` for--- a pure given actual value.------ ===== Example------ The TLT assertion `emptyP` is built from the `Traversable` predicate--- `null`------ > emptyP :: (Monad m, Traversable t) => t a -> Assertion m--- > emptyP = liftAssertionPure null--- >            (\ _ -> "Expected empty structure but got non-empty")+  -- | There are a number of pre-defined forms of assertion imported+  -- automatically from @Test.TLT@.  Note that more operators are in+  -- pairs, with one comparison for monadic results, and one for pure+  -- values.+  --+  -- +-------------------------+---------------------------------------++  -- | `@==`, `@==-`           | Asserts equality of two `Eq` values.  |+  -- +-------------------------+---------------------------------------++  -- | `@/=`, `@/=-`           | Asserts inequality of two `Eq`        |+  -- |                         | values.                               |+  -- +-------------------------+---------------------------------------++  -- | `@<`, `@<-`             | Asserts a less-than relation between  |+  -- |                         | two `Ord` values.                     |+  -- +-------------------------+---------------------------------------++  -- | `@>`, `@>-`             | Asserts a greater-than relation       |+  -- |                         | between two`Ord` values.              |+  -- +-------------------------+---------------------------------------++  -- | `@<=`, `@<=-`           | Asserts a less-than-or-equal-to       |+  -- |                         | relation between two `Ord` values.    |+  -- +-------------------------+---------------------------------------++  -- | `@>=`, `@>=-`           | Asserts a greater-than-or-equal-to    |+  -- |                         | relation between two `Ord` values.    |+  -- +-------------------------+---------------------------------------++  -- | `empty`, `emptyP`       | Asserts the emptiness of a            |+  -- |                         | traversable structure.                |+  -- +-------------------------+---------------------------------------++  -- | `nonempty`, `nonemptyP` | Asserts the non-emptiness of a        |+  -- |                         | traversable structure.                |+  -- +-------------------------+---------------------------------------++  -- + `nothing`, `nothingP`   | Asserts that a `Maybe` value is       |+  -- |                         | `Nothing`.                            |+  -- +-------------------------+---------------------------------------++  --+  -- The predefined operators, along with functions for defining new+  -- `Assertion` operators, are documented more formally below. -liftAssertionPure ::-  (Monad m) => (a -> Bool) -> (a -> String) -> a -> Assertion m-liftAssertionPure tester explainer actual = return $-  if (tester actual) then [] else [Asserted $ explainer actual]+  -- ** Dealing with exceptions --- |Given an `Assertion` for a pure (actual) value, lift it to an--- `Assertion` expecting the value to be returned from a computation.------ ===== Example------ The TLT assertion `empty` on monadic computations returning lists--- is defined in terms of the corresponging assertion on pure--- list-valued expressions.------ > empty :: (Monad m, Traversable t) => m (t a) -> Assertion m--- > empty = assertionPtoM emptyP-assertionPtoM :: (Monad m) => (a -> Assertion m) -> m a -> Assertion m-assertionPtoM pa actualM = do actual <- actualM-                              pa actual+  -- | TLT's interaction with exceptions thrown from the `Except`+  -- monad or from an `ExceptT` transformer layer is subtle.  Because+  -- TLT does not have a specification of tests separate from the+  -- tests' execution, TLT will notice test failures only it actually+  -- runs them.  Tests which may be viewed by the human programmer as+  -- implicitly failing because a thrown exception prevented them from+  -- running are __not__ recorded or reported as failures.  TLT+  -- provides three functions for checking for thrown exceptions.  The+  -- first argument of each is a @TLT@ monad of tests which has been+  -- declared to take an `ExceptT` layer.+  --+  --  [`noUncaught` and `noUncaught_`]: Both assert that /no/ uncaught+  --  exceptions should be thrown from its argument computation, and+  --  fails if one is.  The `noUncaught_` function accepts any type of+  --  exception, but cannot report any details about them except that+  --  /something/ was thrown.  The `noUncaught` function demands that+  --  the exception type be of class `Show`, and does report exception+  --  details in the case of failure.+  --+  --  [`uncaught`]: Asserts that an uncaught exception /should/ be+  --  thrown from its argument computation, and fails if none are+  --  thrown.+  --+  --  [`uncaughtWith`]: Asserts that an uncaught exception /should/ be+  --  thrown from its argument computation, fails if none are thrown,+  --  and passes the thrown exception to its second argument for+  --  further inspection.+  --+  -- The declaration that a monadic value includes an `ExceptT` layer+  -- to be checked is made by declaring instances of the+  -- `MonadTLTExcept` class.  The use of these exception-checking+  -- functions requires that the `TLT` transformer layer be contained+  -- within the `ExceptT` layer.  The generated documentation for this+  -- class and its predefined instances, as well as the above+  -- functions, are all below. --- |Transform a unary function on an actual value (plus a generator of--- a failure message) into an `Assertion` where the value is to be--- returned from a subcomputation.-liftAssertionM ::-  (Monad m) => (a -> Bool) -> (a -> String) -> m a -> Assertion m-liftAssertionM tester explainer actualM =-  let assertPure = liftAssertionPure tester explainer-  in do actual <- actualM-        assertPure actual+  -- * The TLT transformer+  TLT, MonadTLT(liftTLT),+  -- ** Session options+  reportAllTestResults, setExitAfterFailDisplay, --- |Assert that a pure traversable structure (such as a list) is--- empty.-emptyP :: (Monad m, Traversable t) => t a -> Assertion m-emptyP = liftAssertionPure null-           (\ _ -> "Expected empty structure but got non-empty")+  -- * Tests+  (~:), (~::), (~::-), tltFail, inGroup, --- |Assert that a traversable structure (such as a list) returned from--- a computation is empty.-empty :: (Monad m, Traversable t) => m (t a) -> Assertion m-empty = assertionPtoM emptyP+  -- * Assertions+  Assertion,+  -- *** About the values of pure expressions of `Eq`- and `Ord`-type+  (@==-), (@/=-), (@<-), (@>-), (@<=-), (@>=-),+  -- *** About monadic computations returing `Eq`s and `Ord`s+  (@==),  (@/=),  (@<),  (@>),  (@<=),  (@>=),+  -- *** About list values+  empty, nonempty, emptyP, nonemptyP,+  -- *** About `Maybe` values+  nothing, nothingP,+  -- *** Unconditional assertions+  assertFailed, assertSuccess, --- |Assert that a pure traversable structure (such as a list) is--- nonempty.-nonemptyP :: (Monad m, Traversable t) => t a -> Assertion m-nonemptyP = liftAssertionPure (not . null)-              (\ _ -> "Expected non-empty structure but got empty")+  -- ** Building new assertions+  -- *** Unary assertions+  liftAssertionPure, assertionPtoM, liftAssertionM,+  -- *** Binary assertions+  liftAssertion2Pure, assertion2PtoM, liftAssertion2M,+  -- * Dealing with exceptions in an `ExceptT` layer+  MonadTLTExcept(liftTLTExcept, runToExcept),+  noUncaught, noUncaught_, uncaught, uncaughtWith --- |Assert that a traversable structure (such as a list) returned from--- a computation is non-empty.-nonempty :: (Monad m, Traversable t) => m (t a) -> Assertion m-nonempty = assertionPtoM nonemptyP+  ) where --- |Assert that a `Maybe` value is `Nothing`.-nothingP :: Monad m => Maybe a -> Assertion m-nothingP = liftAssertionPure isNothing-           (\ _ -> "Expected empty Maybe value but got non-Nothing")+-- This package does not actually define any functions; it merely+-- re-exports from the internal packages. --- |Assert that a `Maybe` result ofa computation is `Nothing`.-nothing :: Monad m => m (Maybe a) -> Assertion m-nothing = assertionPtoM nothingP+import Test.TLT.Options+import Test.TLT.Results+import Test.TLT.Buffer+import Test.TLT.Class+import Test.TLT.Report+import Test.TLT.Assertion+import Test.TLT.Standard+import Control.Monad.Trans.Except -- For Haddock links
+ src/Test/TLT/Assertion.hs view
@@ -0,0 +1,179 @@+{-|+Module      : Assertion+Description : Assertions and related utilities for TLT+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Assertion infrastructure for the @TLT@ testing system.  See `Test.TLT`+for more information.++-}++module Test.TLT.Assertion where++import Control.Monad.Trans.State.Strict+import Test.TLT.Results+import Test.TLT.Buffer+import Test.TLT.Class++-- * Specifying individual tests++-- |An assertion is a computation (typically in the monad wrapped by+-- `TLT`) which returns a list of zero of more reasons for the failure+-- of the assertion.  A successful computation returns an empty list:+-- no reasons for failure, hence success.+type Assertion m = m [TestFail]++-- |This assertion always fails with the given message.+assertFailed :: Monad m => String -> Assertion m+assertFailed msg = return [Asserted msg]++-- |This assertion always succeeds.+assertSuccess :: Monad m => Assertion m+assertSuccess = return []++infix 0 ~:, ~::, ~::-++-- |Label and perform a test of an `Assertion`.+--+-- ===== Example+--+-- > test :: Monad m => TLT m ()+-- > test = do+-- >   "2 is 2 as result" ~: 2 @== return 2    -- This test passes.+-- >   "2 not 3" ~: 2 @/=- 3                   -- This test fails.+(~:) :: MonadTLT m n => String -> Assertion m -> m ()+s ~: a = do+  (opts, oldState) <- liftTLT $ TLT $ get+  assessment <- a+  liftTLT $ TLT $ put (opts, addResult oldState $ Test s assessment)++-- |Label and perform a test of a (pure) boolean value.+--+-- ===== Example+--+-- > test :: Monad m => TLT m ()+-- > test = do+-- >   "True passes" ~::- return True                 -- This test passes.+-- >   "2 is 2 as single Bool" ~::- return (2 == 2)   -- This test passes.+-- >   "2 is 3!?" ~::- myFn 4 "Hammer"                -- Passes if myFn (which+-- >                                                  -- must be monadic)+-- >                                                  -- returns True.+(~::-) :: MonadTLT m n => String -> Bool -> m ()+s ~::- b = do+  (opts, oldState) <- liftTLT $ TLT $ get+  liftTLT $ TLT $ put (opts, addResult oldState $ Test s $+        if b then [] else [Asserted $ "Expected True but got False"])++-- |Label and perform a test of a boolean value returned by a+-- computation in the wrapped monad @m@.+--+-- ===== Example+--+-- > test :: Monad m => TLT m ()+-- > test = do+-- >   "True passes" ~::- True               -- This test passes.+-- >   "2 is 2 as single Bool" ~::- 2 == 2   -- This test passes.+-- >   "2 is 3!?" ~::- 2 == 2                -- This test fails.+(~::) :: MonadTLT m n => String -> m Bool -> m ()+s ~:: bM = do+  b <- bM+  (opts, oldState) <- liftTLT $ TLT $ get+  liftTLT $ TLT $ put (opts, addResult oldState $ Test s $+        if b then [] else [Asserted $ "Expected True but got False"])++-- |Transform a binary function on an expected and an actual value+-- (plus a binary generator of a failure message) into an `Assertion`+-- for a pure given actual value.+--+-- ===== Example+--+-- TLT's scalar-testing operators like @\@==-@ are defined with this+-- function:+--+-- > (@==-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m+-- > (@==-) = liftAssertion2Pure (==) $+-- >   \ exp actual -> "Expected " ++ show exp ++ " but got " ++ show actual+--+-- The `(==)` operator tests equality, and the result here allows the+-- assertion that a value should be exactly equal to a target.  The+-- second argument formats the detail reported when the assertion+-- fails.+liftAssertion2Pure ::+  (Monad m) => (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m+liftAssertion2Pure tester explainer exp actual = return $+  if (tester exp actual) then [] else [Asserted $ explainer exp actual]++-- |Given an `Assertion` for two pure values (expected and actual),+-- lift it to an `Assertion` expecting the actual value to be returned+-- from a computation.+--+-- ===== Examples+--+-- The TLT assertion `Test.TLT.(@==)` lifts `Test.TLT.(@==-)` (both+-- defined in `Test.TLT.Standard`) from expecting a pure actual result+-- to expecting a computation returning a value to test.+--+-- > (@==) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m+-- > (@==) = assertion2PtoM (@==-)+assertion2PtoM ::+  (Monad m) => (a -> a -> Assertion m) -> a -> m a -> Assertion m+assertion2PtoM pa exp actualM = do actual <- actualM+                                   pa exp actual++-- |Transform a binary function on expected and actual values (plus+-- a generator of a failure message) into an `Assertion` where the+-- actual value is to be returned from a subcomputation.+liftAssertion2M ::+  (Monad m) => (a -> a -> Bool) -> (a -> a -> String) -> a -> m a -> Assertion m+liftAssertion2M tester explainer exp actualM =+  let assertPure = liftAssertion2Pure tester explainer exp+  in do actual <- actualM+        assertPure actual++-- |Transform a unary function on a value (plus a generator of a+-- failure message) into a unary function returning an `Assertion` for+-- a pure given actual value.+--+-- ===== Example+--+-- The TLT assertion `Test.TLT.emptyP` (defined in+-- `Test.TLT.Standard`) is built from the `Traversable` predicate+-- `null`+--+-- > emptyP :: (Monad m, Traversable t) => t a -> Assertion m+-- > emptyP = liftAssertionPure null+-- >            (\ _ -> "Expected empty structure but got non-empty")++liftAssertionPure ::+  (Monad m) => (a -> Bool) -> (a -> String) -> a -> Assertion m+liftAssertionPure tester explainer actual = return $+  if (tester actual) then [] else [Asserted $ explainer actual]++-- |Given an `Assertion` for a pure (actual) value, lift it to an+-- `Assertion` expecting the value to be returned from a computation.+--+-- ===== Example+--+-- The TLT assertion `Test.TLT.empty` (defined in `Test.TLT.Standard`)+-- on monadic computations returning lists is defined in terms of the+-- corresponging assertion on pure list-valued expressions.+--+-- > empty :: (Monad m, Traversable t) => m (t a) -> Assertion m+-- > empty = assertionPtoM emptyP+assertionPtoM :: (Monad m) => (a -> Assertion m) -> m a -> Assertion m+assertionPtoM pa actualM = do actual <- actualM+                              pa actual++-- |Transform a unary function on an actual value (plus a generator of+-- a failure message) into an `Assertion` where the value is to be+-- returned from a subcomputation.+liftAssertionM ::+  (Monad m) => (a -> Bool) -> (a -> String) -> m a -> Assertion m+liftAssertionM tester explainer actualM =+  let assertPure = liftAssertionPure tester explainer+  in do actual <- actualM+        assertPure actual
+ src/Test/TLT/Buffer.hs view
@@ -0,0 +1,42 @@+{-|+Module      : Buffer+Description : Testing in a monad transformer layer+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Buffer for accumulating test results in the @TLT@ testing system.  See+`Test.TLT` for more information.++-}++module Test.TLT.Buffer where+import Test.TLT.Results++-- |Accumulator for test results, in the style of a simplified Huet's+-- zipper which only ever adds to the end of the structure.+data TRBuf = Buf TRBuf Int Int String [TestResult] | Top Int Int [TestResult]++-- |Add a single test result to a `TRBuf`.+addResult :: TRBuf -> TestResult -> TRBuf+addResult (Top tc fc trs) tr =+  Top (tc + testCount tr) (fc + failCount tr) $ tr : trs+addResult (Buf up tc fc s trs) tr =+  Buf up (tc + testCount tr) (fc + failCount tr) s $ tr : trs++-- |Convert the topmost group of a bottom-up `TRBuf` into a completed+-- top-down report about the group.+currentGroup :: TRBuf -> TestResult+currentGroup (Buf up tc fc s trs) = Group s tc fc (reverse trs)++-- |Derive a new `TRBuf` corresponding to finishing the current group+-- and continuing to accumulate results into its enclosure.+popGroup :: TRBuf -> TRBuf+popGroup trb@(Buf acc _ _ _ _) = addResult acc $ currentGroup trb++-- |Convert a `TRBuf` into a list of top-down `TestResult`s.+closeTRBuf :: TRBuf -> [TestResult]+closeTRBuf (Top _ _ ts) = reverse ts+closeTRBuf b = closeTRBuf $ popGroup b
+ src/Test/TLT/Class.hs view
@@ -0,0 +1,275 @@+{-|+Module      : Class+Description : Testing in a monad transformer layer+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Main state and monad definitions for the @TLT@ testing system.  See+`Test.TLT` for more information.++-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Test.TLT.Class where++import Control.Exception+import Control.Monad+import Control.Monad.Except+import Control.Monad.ST.Trans+import Control.Monad.Trans.Class+-- import Control.Monad.Trans.Either+import Control.Monad.Trans.Except+import Control.Monad.Trans.Free+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Control.Monad.Trans.State.Strict+import qualified Control.Monad.Trans.State.Lazy as SL+import qualified Control.Monad.Trans.Writer.Lazy as WL+import qualified Control.Monad.Trans.Writer.Strict as WS+import Test.TLT.Options+import Test.TLT.Results+import Test.TLT.Buffer++-- |Synonym for the elements of the `TLT` state.+type TLTstate = (TLTopts, TRBuf)++-- |Monad transformer for TLT tests.  This layer stores the results+-- from tests as they are executed.+newtype {- Monad m => -} TLT (m :: * -> *) r = TLT { unwrap :: StateT TLTstate m r }+  deriving (Functor, Applicative, Monad, MonadTrans)++-- |Extending `TLT` operations across other monad transformers.  For+-- easiest and most flexible testing, declare the monad transformers+-- of your application as instances of this class.+class (Monad m, Monad n) => MonadTLT m n | m -> n where+  -- |Lift TLT operations within a monad transformer stack.  Note that+  -- with enough transformer types included in this class, the+  -- @liftTLT@ function should usually be unnecessary: the commands in+  -- this module which actually configure testing, or specify a test,+  -- already @liftTLT@ their own result.  So they will all act as+  -- top-level transformers in @MonadTLT@.+  liftTLT :: TLT n a -> m a++instance Monad m => MonadTLT (TLT m) m where+  liftTLT = id++instance (MonadTLT m n, Functor f) => MonadTLT (FreeT f m) n where+    liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (IdentityT m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (MaybeT m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (ReaderT r m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (ResourceT m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (StateT s m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (ExceptT e m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (SL.StateT s m) n where+  liftTLT = lift . liftTLT++instance MonadTLT m n => MonadTLT (STT s m) n where+  liftTLT = lift . liftTLT++instance (MonadTLT m n, Monoid w) => MonadTLT (WL.WriterT w m) n where+  liftTLT = lift . liftTLT++instance (MonadTLT m n, Monoid w) => MonadTLT (WS.WriterT w m) n where+  liftTLT = lift . liftTLT++{- ----------------------------------------------------------------- -}++-- |Execute the tests specified in a `TLT` monad without output+-- side-effects, returning the final options and result reports.+--+-- This function is primarily useful when calling TLT from some other+-- package.  If you are using TLT itself as your test framework, and+-- wishing to see its human-oriented output directly, consider using+-- `Test.TLT.tlt` instead.+runTLT :: Monad m => TLT m r -> m (TLTopts, [TestResult])+runTLT (TLT t) = do+  (_, (opts, resultsBuf)) <- runStateT t $ (defaultOpts, Top 0 0 [])+  return (opts, closeTRBuf resultsBuf)++-- |This function controls whether `Test.TLT.tlt` will report only+-- tests which fail, suppressing any display of tests which pass, or+-- else report the results of all tests.  The default is the former:+-- the idea is that no news should be good news, with the programmer+-- bothered only with problems which need fixing.+reportAllTestResults :: MonadTLT m n => Bool -> m ()+reportAllTestResults b = liftTLT $ TLT $ do+  (opts, tr) <- get+  put $ (opts `withShowPasses` b, tr)++-- |This function controls whether the main `Test.TLT.tlt` executable+-- should exit after displaying test results which include at least+-- one failing test.  By default, it will exit in this situation.  The+-- idea is that a test suite can be broken into parts when it makes+-- sense to run the latter parts only when the former parts all pass.+setExitAfterFailDisplay :: MonadTLT m n => Bool -> m ()+setExitAfterFailDisplay b = liftTLT $ TLT $ do+  (opts, tr) <- get+  put $ (opts `withExitAfterFail` b, tr)++-- |Report a failure.  Useful in pattern-matching cases which are+-- entirely not expected.+tltFail :: MonadTLT m n => String -> String -> m ()+desc `tltFail` detail = liftTLT $ TLT $ do+  (opts, before) <- get+  let after = addResult before $ Test desc [Asserted detail]+  put (opts, after)++-- |Report a success.  Useful in default cases.+tltPass :: MonadTLT m n => String -> m ()+tltPass desc = liftTLT $ TLT $ do+  (opts, before) <- get+  let after = addResult before $ Test desc []+  put (opts, after)++-- |Organize the tests in the given subcomputation as a separate group+-- within the test results we will report.+inGroup :: MonadTLT m n => String -> m a -> m a+inGroup name group = do+  (opts, before) <- liftTLT $ TLT get+  liftTLT $ TLT $ put $ (opts, Buf before 0 0 name [])+  result <- group+  (opts', after) <- liftTLT $ TLT $ get+  liftTLT $ TLT $ put $ (opts', popGroup after)+  return result++{- --------------------------------------------------------------- -}++-- | Enabling TLT checking of the completion of computations with- or+-- without uncaught exceptions in a (possibly embedded) `ExceptT` or+-- `Except` monad.+--+-- In general, it is more difficult to automatically deduce+-- @MonadTLTExcept@ instances than @MonadTLT@ because `runToExcept`+-- instances bodies will frequently require additional parameters to+-- functions such as `runReaderT`, or values corresponding to+-- `Nothing`, which are specific to a particular scenario.+--+-- Note that using @MonadTLTExcept@ imposes the restriction that the+-- `TLT` transformer layer must be wrapped within the `ExceptT`+-- transformer layer.+class (MonadTLT m nt, Monad m, MonadTLT ne nt) => MonadTLTExcept m e nt ne+      | m -> e, m -> ne where+  -- | Encodes how an embedded `ExceptT` monad can be lifted to the+  -- top-level monad stack type @m@.+  liftTLTExcept :: ExceptT e ne a -> m a+  -- | Runs the layers of the monad stack above the `ExceptT` layer,+  -- exposing that latter layer.  Serves as an inverse of+  -- `liftTLTExcept`.+  runToExcept :: m a -> ExceptT e ne a++-- | The `ExceptT` instance is a base case; here the lift/run+-- functions are simply `id`.+instance MonadTLT m nt => MonadTLTExcept (ExceptT e m) e nt m where+  liftTLTExcept = id+  runToExcept = id++{-+-- I don't understand the FreeT transformer well enough to build this.+instance (MonadTLTExcept m e nt ne, Functor f) =>+         MonadTLTExcept (FreeT f m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept = ???+-}++-- | We can infer general instances for other monad transformer types+-- when their @run@ function does not take some initializing argument.+instance MonadTLTExcept m e nt ne => MonadTLTExcept (IdentityT m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept = runToExcept . runIdentityT++{-+instance (MonadTLTExcept m e nt ne) =>+         MonadTLTExcept (MaybeT m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept m = runToExcept $ do res <- runMaybeT m+                                   case res of+                                     Nothing -> return "???"+                                     Just j -> return j++instance MonadTLTExcept m e nt ne => MonadTLTExcept (ReaderT r m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept++instance MonadTLTExcept m e nt ne => MonadTLTExcept (ResourceT m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept++instance MonadTLTExcept m e nt ne =>+         MonadTLTExcept (SL.StateT s m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept++instance MonadTLTExcept m e nt ne => MonadTLTExcept (STT s m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept = runToExcept . runSTT+-}++-- | The `runToExcept` function in this case simply discards any+-- output.+instance (MonadTLTExcept m e nt ne, Monoid w) =>+         MonadTLTExcept (WL.WriterT w m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept m = runToExcept $ do (res, _) <- WL.runWriterT m+                                   return res++-- | The `runToExcept` function in this case simply discards any+-- output.+instance (MonadTLTExcept m e nt ne, Monoid w) =>+         MonadTLTExcept (WS.WriterT w m) e nt ne where+  liftTLTExcept = lift . liftTLTExcept+  runToExcept m = runToExcept $ do (res, _) <- WS.runWriterT m+                                   return res++-- | Ensure that a computation in `ExceptT` completes without an+-- uncaught exception.+noUncaught_ :: MonadTLTExcept m e nt ne => String -> m a -> m ()+noUncaught_ loc m = do+  let label = "No uncaught exception from " ++ loc+  liftTLTExcept $ catchE (do runToExcept m+                             tltPass label)+                         (\_ -> label `tltFail` "Uncaught exception")++-- | Ensure that a computation in `ExceptT` completes without an+-- uncaught exception.+noUncaught :: (MonadTLTExcept m e nt ne, Show e) => String -> m a -> m ()+noUncaught loc m = do+  let label = "No uncaught exception from " ++ loc+  liftTLTExcept $ catchE (do runToExcept m+                             tltPass label)+                         (\ex -> label `tltFail`+                                   ("Uncaught exception: " ++ show ex))++-- | Ensure that a computation in `ExceptT` does throw an uncaught+-- exception, allowing further testing of the exception.+uncaughtWith ::+  (MonadTLTExcept m e nt ne) => String -> m a -> (e -> ExceptT e ne ()) -> m ()+uncaughtWith loc m handler =+  liftTLTExcept $ catchE (do runToExcept m+                             ("Expected uncaught exception from " ++ loc)+                               `tltFail` "Did not throw exception")+                         handler++-- | Ensure that a computation in `ExceptT` does throw an uncaught+-- exception.+uncaught loc m = uncaughtWith loc m $ \_ -> return ()
+ src/Test/TLT/Options.hs view
@@ -0,0 +1,33 @@+{-|+Module      : Options+Description : Option spec for TLT+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Options representation for the @TLT@ testing system.  See `Test.TLT`+for more information.++-}++module Test.TLT.Options where++-- |Record of options which may be specified for running and reporting+-- TLT tests.+data TLTopts = TLTopts {+  optShowPasses :: Bool,+  optQuitAfterFailReport :: Bool+}++-- |Default initial options.+defaultOpts = TLTopts False True++-- |Update the display of showing passes in a `TLTopts` record.+withShowPasses :: TLTopts -> Bool -> TLTopts+withShowPasses (TLTopts _ f) b = TLTopts b f++-- |Update the display of showing passes in a `TLTopts` record.+withExitAfterFail :: TLTopts -> Bool -> TLTopts+withExitAfterFail (TLTopts p _) b = TLTopts p b
+ src/Test/TLT/Report.hs view
@@ -0,0 +1,117 @@+{-|+Module      : Report+Description : Testing in a monad transformer layer+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Default results reporting for the @TLT@ testing system.  See+`Test.TLT` for more information.++-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Test.TLT.Report where+import Control.Monad+import Control.Monad.IO.Class+import System.Console.ANSI+import System.Exit+import Test.TLT.Options+import Test.TLT.Results+import Test.TLT.Class++-- |Execute the tests specified in a `TLT` monad, and report the+-- results as text output.+--+-- When using TLT from some other package (as opposed to using TLT+-- itself as your test framework, and wishing to see its+-- human-oriented output directly), consider using `runTLT` instead.+tlt :: MonadIO m => TLT m r -> m ()+tlt tlt = do+  liftIO $ putStrLn "Running tests:"+  (opts, results) <- runTLT tlt+  liftIO $ report opts $ results++-- |Report the results of tests.+report :: TLTopts -> [TestResult] -> IO ()+report (TLTopts showPasses exitAfterFailDisplay) trs =+  let fails = totalFailCount trs+      tests = totalTestCount trs+  in do report' "" trs+        if fails > 0+          then do boldRed+                  putStrLn $+                    "Found " ++ show fails ++ " error"+                      ++ (if fails > 1 then "s" else "")+                      ++ " in " ++ show tests ++ " tests; exiting"+                  mediumBlack+                  when exitAfterFailDisplay exitFailure+          else do boldGreen+                  putStrLn $ show tests ++ " test"+                    ++ (if tests > 1 then "s" else "")+                    ++ " passing."+                  mediumBlack+  where report' ind trs = forM_ trs $ \ tr ->+          when (failCount tr > 0 || showPasses) $+            case tr of+              Test s r -> do+                putStr $ ind ++ "- " ++ s ++ ": "+                case r of+                  [] -> do+                    greenPass+                    putStrLn ""+                  x : [] -> do+                    redFail+                    putStrLn $ " " ++ formatFail x+                  _ -> do+                    redFail+                    putStrLn ":"+                    forM_ r $ \ f -> putStrLn $ ind ++ "- " ++ formatFail f+              Group s _ _ trs' -> do+                putStrLn $ ind ++ "- " ++ s ++ ":"+                report' ("  " ++ ind) trs'++-- |Command to set an ANSI terminal to boldface black.+boldBlack = setSGR [+  SetColor Foreground Vivid Black, SetConsoleIntensity BoldIntensity ]+-- |Command to set an ANSI terminal to boldface red.+boldRed = setSGR [+  SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity ]+-- |Command to set an ANSI terminal to boldface green.+boldGreen = setSGR [+  SetColor Foreground Vivid Green, SetConsoleIntensity BoldIntensity ]++-- |Command to set an ANSI terminal to medium-weight red.+mediumRed = setSGR [+  SetColor Foreground Vivid Red, SetConsoleIntensity NormalIntensity ]+-- |Command to set an ANSI terminal to medium-weight green.+mediumGreen = setSGR [+  SetColor Foreground Vivid Green, SetConsoleIntensity NormalIntensity ]+-- |Command to set an ANSI terminal to medium-weight blue.+mediumBlue = setSGR [+  SetColor Foreground Vivid Blue, SetConsoleIntensity NormalIntensity ]+-- |Command to set an ANSI terminal to medium-weight black.+mediumBlack = setSGR [+  SetColor Foreground Vivid Black, SetConsoleIntensity NormalIntensity ]++-- |Command to set an ANSI terminal to the standard TLT weight and+-- color for a passing test.+greenPass = do+  mediumBlue+  putStr "Pass"+  mediumBlack++-- |Command to set an ANSI terminal to the standard TLT weight and+-- color for a failing test.+redFail = do+  boldRed+  putStr "FAIL"+  mediumBlack
+ src/Test/TLT/Results.hs view
@@ -0,0 +1,58 @@+{-|+Module      : Results+Description : Results representation for TLT+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Results representation for the @TLT@ testing system.  See `Test.TLT`+for more information.++-}++module Test.TLT.Results where++-- * Results of tests++-- |Reasons why a test might fail.+data TestFail = Asserted String+                -- ^ A failure arising from an `Test.TLT.Assertion`+                -- which is not met.+              | Erred String+                -- ^ A failure associated with a call to a Haskell+                -- function triggering an error.++-- |Default conversion of a `TestFail` to a descriptive string.+formatFail :: TestFail -> String+formatFail (Asserted s) = s+formatFail (Erred s) = "Assertion raised exception: " ++ s++-- |Hierarchical structure holding the result of running tests,+-- possibly grouped into tests.+data TestResult = Test String [TestFail]+                | Group String Int Int [TestResult]+                  -- ^ The `Int`s are respectively the total number of+                  -- tests executed, and total number of failures+                  -- detected.++-- |Return the number of failed tests reported in a `TestResult`.+failCount :: TestResult -> Int+failCount (Test _ []) = 0+failCount (Test _ _) = 1+failCount (Group _ _ n _) = n++-- |Return the number of tests described by a `TestResult`.+testCount :: TestResult -> Int+testCount (Test _ _) = 1+testCount (Group _ n _ _) = n++-- |Return the number of failed tests described in a list of+-- `TestResult`s.+totalFailCount :: [TestResult] -> Int+totalFailCount = foldr (+) 0 . map failCount++-- |Return the number of tests described in a list of `TestResult`s.+totalTestCount :: [TestResult] -> Int+totalTestCount = foldr (+) 0 . map testCount
+ src/Test/TLT/Standard.hs view
@@ -0,0 +1,159 @@+{-|+Module      : Standard+Description : Standard test operations for TLT+Copyright   : (c) John Maraist, 2022+License     : GPL3+Maintainer  : haskell-tlt@maraist.org+Stability   : experimental+Portability : POSIX++Standard assertion vocabulary for the @TLT@ testing system.  See+`Test.TLT` for more information.++-}++module Test.TLT.Standard where+import Data.Maybe+import Test.TLT.Assertion+import Control.Monad.Trans.Except++infix 1 @==,  @/=,  @<,  @>,  @<=,  @>=+infix 1 @==-, @/=-, @<-, @>-, @<=-, @>=-++-- |Assert that two values are equal.  This assertion takes an+-- expected and an actual /value/; see `(@==)` to compare the result+-- of a /monadic computation/ to an expected value.+--+-- ===== Examples+--+-- > test :: Monad m => TLT m ()+-- > test = do+-- >   "Make sure that 2 is still equal to itself" ~: 2 @==- 2+-- >   "Make sure that there are four lights" ~: 4 @==- length lights+(@==-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m+(@==-) = liftAssertion2Pure (==) $+  \ exp actual -> "Expected " ++ show exp ++ " but got " ++ show actual++-- |Assert that a calculated value is as expected.  This assertion+-- compare the result of a /monadic computation/ to an expected value;+-- see `(@==-)` to compare an /actual value/ to the expected value.+--+-- ===== Examples+--+-- > test :: Monad m => TLT m ()+-- > test = do+-- >   "Make sure that 2 is still equal to itself" ~: 2 @== return 2+-- >   "Make sure that there are four lights" ~: 4 @== countLights+-- >                                             -- where countLights :: m Int+(@==) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m+(@==) = assertion2PtoM (@==-)++-- |Assert that two values are not equal.  This assertion takes an+-- expected and an actual /value/; see `(@/=)` to compare the result+-- of a /monadic computation/ to an expected value.+(@/=-) :: (Monad m, Eq a, Show a) => a -> a -> Assertion m+(@/=-) = liftAssertion2Pure (/=) $+  \ exp actual ->+    "Expected other than " ++ show exp ++ " but got " ++ show actual++-- |Assert that a calculated value differs from some known value.+-- This assertion compares the result of a /monadic computation/ to an+-- expected value; see `(@/=-)` to compare an /actual value/ to the+-- expected value.+(@/=) :: (Monad m, Eq a, Show a) => a -> m a -> Assertion m+(@/=) = assertion2PtoM (@/=-)++-- |Assert that a given boundary is strictly less than some value.+-- This assertion takes an expected and an actual /value/; see `(@<)`+-- to compare the result of a /monadic computation/ to an expected+-- value.+(@<-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m+(@<-) = liftAssertion2Pure (<) $+  \ exp actual ->+    "Lower bound (open) is " ++ show exp ++ " but got " ++ show actual++-- |Assert that a given, constant boundary is strictly less than some+-- calculated value.  This assertion compares the result of a /monadic+-- computation/ to an expected value; see `(@<-)` to compare an+-- /actual value/ to the expected value.+(@<) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m+(@<) = assertion2PtoM (@<-)++-- |Assert that a given boundary is strictly less than some value.+-- This assertion takes an expected and an actual /value/; see `(@>)`+-- to compare the result of a /monadic computation/ to an expected+-- value.+(@>-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m+(@>-) = liftAssertion2Pure (>) $+  \ exp actual ->+    "Upper bound (open) is " ++ show exp ++ " but got " ++ show actual++-- |Assert that a given, constant boundary is strictly less than some+-- calculated value.  This assertion compares the result of a /monadic+-- computation/ to an expected value; see `(@>-)` to compare an+-- /actual value/ to the expected value.+(@>) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m+(@>) = assertion2PtoM (@>-)++-- |Assert that a given boundary is strictly less than some value.+-- This assertion takes an expected and an actual /value/; see `(@<=)`+-- to compare the result of a /monadic computation/ to an expected+-- value.+(@<=-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m+(@<=-) = liftAssertion2Pure (<=) $+  \ exp actual ->+    "Lower bound (closed) is " ++ show exp ++ " but got " ++ show actual++-- |Assert that a given, constant boundary is strictly less than some+-- calculated value.  This assertion compares the result of a /monadic+-- computation/ to an expected value; see `(@<=-)` to compare an+-- /actual value/ to the expected value.+(@<=) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m+(@<=) = assertion2PtoM (@<=-)++-- |Assert that a given boundary is strictly less than some value.+-- This assertion takes an expected and an actual /value/; see `(@>=)`+-- to compare the result of a /monadic computation/ to an expected+-- value.+(@>=-) :: (Monad m, Ord a, Show a) => a -> a -> Assertion m+(@>=-) = liftAssertion2Pure (>=) $+  \ exp actual ->+    "Upper bound (closed) is " ++ show exp ++ " but got " ++ show actual++-- |Assert that a given, constant boundary is strictly less than some+-- calculated value.  This assertion compares the result of a /monadic+-- computation/ to an expected value; see `(@>=-)` to compare an+-- /actual value/ to the expected value.+(@>=) :: (Monad m, Ord a, Show a) => a -> m a -> Assertion m+(@>=) = assertion2PtoM (@>=-)++-- |Assert that a pure traversable structure (such as a list) is+-- empty.+emptyP :: (Monad m, Traversable t) => t a -> Assertion m+emptyP = liftAssertionPure null+           (\ _ -> "Expected empty structure but got non-empty")++-- |Assert that a traversable structure (such as a list) returned from+-- a computation is empty.+empty :: (Monad m, Traversable t) => m (t a) -> Assertion m+empty = assertionPtoM emptyP++-- |Assert that a pure traversable structure (such as a list) is+-- nonempty.+nonemptyP :: (Monad m, Traversable t) => t a -> Assertion m+nonemptyP = liftAssertionPure (not . null)+              (\ _ -> "Expected non-empty structure but got empty")++-- |Assert that a traversable structure (such as a list) returned from+-- a computation is non-empty.+nonempty :: (Monad m, Traversable t) => m (t a) -> Assertion m+nonempty = assertionPtoM nonemptyP++-- |Assert that a `Maybe` value is `Nothing`.+nothingP :: Monad m => Maybe a -> Assertion m+nothingP = liftAssertionPure isNothing+           (\ _ -> "Expected empty Maybe value but got non-Nothing")++-- |Assert that a `Maybe` result of a computation is `Nothing`.+nothing :: Monad m => m (Maybe a) -> Assertion m+nothing = assertionPtoM nothingP
test/Passing.hs view
@@ -4,13 +4,16 @@ {-# LANGUAGE UndecidableInstances #-}  import Test.TLT+import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans+import Control.Monad  main :: IO () main = do   tlt test   tlt ttest+  tlt $ runExceptT extest  test :: Monad m => TLT m () test = do@@ -82,3 +85,18 @@   "5 is 5 as pure assertion" ~: 5 @==- 5   "6 is 6 as pure assertion" ~: 6 @==- 6 +extest :: ExceptT String (TLT IO) ()+extest = do+  noUncaught "extest1" $ do+    "6 is 6 as pure assertion" ~: 6 @==- 6+    "7 is 7 as pure assertion" ~: 7 @==- 7+  uncaught "extest2" $ do+    "8 is 8 as pure assertion" ~: 8 @==- 8+    throwE "Boom"+    "9 is 9 as pure assertion" ~: 9 @==- 9+  uncaughtWith "extest3"+    (do "10 is 10 as pure assertion" ~: 10 @==- 10+        throwE "Boom"+        "11 is 11 as pure assertion" ~: 11 @==- 11)+    (\e -> "The exception should be \"Boom\""+             ~: "Boom" @==- e)