diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for TLT +- 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. diff --git a/TLT.cabal b/TLT.cabal --- a/TLT.cabal +++ b/TLT.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: TLT -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Testing in monads and transformers without explicit specs 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 for documentation, or the Haddock page for additional examples. category: Test diff --git a/app/Failing.hs b/app/Failing.hs --- a/app/Failing.hs +++ b/app/Failing.hs @@ -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) diff --git a/src/Test/TLT.hs b/src/Test/TLT.hs --- a/src/Test/TLT.hs +++ b/src/Test/TLT.hs @@ -26,28 +26,175 @@ module Test.TLT ( + -- * Introduction and basic use + + -- | 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) + + tlt, + + -- ** Writing tests + + -- | 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. + + -- | 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. + + -- ** Writing standard assertions + + -- | 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. + + -- ** Dealing with exceptions + + -- | 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`]: Asserts that /no/ uncaught exceptions should be + -- thrown from its argument computation, and fails if one is. + -- + -- [`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. + -- * The TLT transformer - TLT, tlt, MonadTLT, liftTLT, + TLT, MonadTLT, liftTLT, -- ** Session options reportAllTestResults, setExitAfterFailDisplay, - -- * Writing tests - Assertion, - -- ** `TLT` commands + + -- * Tests (~:), (~::), (~::-), tltFail, inGroup, - -- ** Assertions + + -- * Assertions + Assertion, -- *** About the values of pure expressions of `Eq`- and `Ord`-type - (@==), (@/=), (@<), (@>), (@<=), (@>=), - -- *** About monadic computations returing `Eq`s and `Ord`s (@==-), (@/=-), (@<-), (@>-), (@<=-), (@>=-), + -- *** About monadic computations returing `Eq`s and `Ord`s + (@==), (@/=), (@<), (@>), (@<=), (@>=), -- *** About list values empty, nonempty, emptyP, nonemptyP, -- *** About `Maybe` values - nothing, nothingP, assertFailed, assertSuccess, + nothing, nothingP, + -- *** Unconditional assertions + assertFailed, assertSuccess, + -- ** Building new assertions -- *** Unary assertions liftAssertionPure, assertionPtoM, liftAssertionM, -- *** Binary assertions - liftAssertion2Pure, assertion2PtoM, liftAssertion2M + liftAssertion2Pure, assertion2PtoM, liftAssertion2M, + -- * Dealing with exceptions in an `ExceptT` layer + MonadTLTExcept, liftTLTExcept, runToExcept, + noUncaught, uncaught, uncaughtWith ) where @@ -61,3 +208,4 @@ import Test.TLT.Report import Test.TLT.Assertion import Test.TLT.Standard +import Control.Monad.Trans.Except -- For Haddock links diff --git a/src/Test/TLT/Class.hs b/src/Test/TLT/Class.hs --- a/src/Test/TLT/Class.hs +++ b/src/Test/TLT/Class.hs @@ -15,15 +15,18 @@ {-# 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 @@ -42,7 +45,7 @@ -- |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 } +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 @@ -78,6 +81,9 @@ 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 @@ -90,6 +96,82 @@ instance (MonadTLT m n, Monoid w) => MonadTLT (WS.WriterT w m) n where liftTLT = lift . liftTLT +{- --------------------------------------------------------------- -} + +-- | 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 + liftTLTExcept :: ExceptT e ne a -> m a + runToExcept :: m a -> ExceptT e ne a + +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 = ??? +-} + +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 + -- |Execute the tests specified in a `TLT` monad without output -- side-effects, returning the final options and result reports. -- @@ -130,6 +212,13 @@ 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 @@ -140,3 +229,26 @@ (opts', after) <- liftTLT $ TLT $ get liftTLT $ TLT $ put $ (opts', popGroup after) return result + +-- | 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` 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 () diff --git a/src/Test/TLT/Standard.hs b/src/Test/TLT/Standard.hs --- a/src/Test/TLT/Standard.hs +++ b/src/Test/TLT/Standard.hs @@ -15,6 +15,7 @@ module Test.TLT.Standard where import Data.Maybe import Test.TLT.Assertion +import Control.Monad.Trans.Except infix 1 @==, @/=, @<, @>, @<=, @>= infix 1 @==-, @/=-, @<-, @>-, @<=-, @>=- diff --git a/test/Passing.hs b/test/Passing.hs --- a/test/Passing.hs +++ b/test/Passing.hs @@ -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) h + + where h :: String -> ExceptT String (TLT IO) () + h e = "The exception should be \"Boom\"" ~: "Boom" @==- e