{-|
Module      : TLT
Description : Testing in a monad transformer layer
Copyright   : (c) John Maraist, 2022
License     : GPL3
Maintainer  : haskell-tlt@maraist.org
Stability   : experimental
Portability : POSIX

TLT is a small unit test system oriented towards examining
intermediate results of computations in monad transformers.  It is
intended to be lightweight for the programmer, and does not require
tests to be specified in some sort of formal list of tests.  Rather,
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/>.

-}

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Test.TLT (
  -- * The TLT transformer
  TLT, tlt, MonadTLT, liftTLT, tltCore,
  -- ** 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 :: TestFail -> String
formatFail (Asserted String
s) = String
s
formatFail (Erred String
s) = String
"Assertion raised exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: TestResult -> Int
failCount (Test String
_ []) = Int
0
failCount (Test String
_ [TestFail]
_) = Int
1
failCount (Group String
_ Int
_ Int
n [TestResult]
_) = Int
n

testCount :: TestResult -> Int
testCount :: TestResult -> Int
testCount (Test String
_ [TestFail]
_) = Int
1
testCount (Group String
_ Int
n Int
_ [TestResult]
_) = Int
n

totalFailCount :: [TestResult] -> Int
totalFailCount :: [TestResult] -> Int
totalFailCount = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ([Int] -> Int) -> ([TestResult] -> [Int]) -> [TestResult] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestResult -> Int) -> [TestResult] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TestResult -> Int
failCount

totalTestCount :: [TestResult] -> Int
totalTestCount :: [TestResult] -> Int
totalTestCount = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ([Int] -> Int) -> ([TestResult] -> [Int]) -> [TestResult] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestResult -> Int) -> [TestResult] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TestResult -> Int
testCount

-- |Report the results of tests.
report :: TLTopts -> [TestResult] -> IO ()
report :: TLTopts -> [TestResult] -> IO ()
report (TLTopts Bool
showPasses Bool
exitAfterFailDisplay) [TestResult]
trs =
  let fails :: Int
fails = [TestResult] -> Int
totalFailCount [TestResult]
trs
      tests :: Int
tests = [TestResult] -> Int
totalTestCount [TestResult]
trs
  in do String -> [TestResult] -> IO ()
report' String
"" [TestResult]
trs
        if Int
fails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
          then do IO ()
boldRed
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fails String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" error"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
fails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tests String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests; exiting"
                  IO ()
mediumBlack
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exitAfterFailDisplay IO ()
forall a. IO a
exitFailure
          else do IO ()
boldGreen
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
tests String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" test"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
tests Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" passing."
                  IO ()
mediumBlack
  where report' :: String -> [TestResult] -> IO ()
report' String
ind [TestResult]
trs = [TestResult] -> (TestResult -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestResult]
trs ((TestResult -> IO ()) -> IO ()) -> (TestResult -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TestResult
tr ->
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestResult -> Int
failCount TestResult
tr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
showPasses) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            case TestResult
tr of
              Test String
s [TestFail]
r -> do
                String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
                case [TestFail]
r of
                  [] -> do
                    IO ()
greenPass
                    String -> IO ()
putStrLn String
""
                  TestFail
x : [] -> do
                    IO ()
redFail
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
x
                  [TestFail]
_ -> do
                    IO ()
redFail
                    String -> IO ()
putStrLn String
":"
                    [TestFail] -> (TestFail -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestFail]
r ((TestFail -> IO ()) -> IO ()) -> (TestFail -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TestFail
f -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestFail -> String
formatFail TestFail
f
              Group String
s Int
_ Int
_ [TestResult]
trs' -> do
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
                String -> [TestResult] -> IO ()
report' (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ind) [TestResult]
trs'

boldBlack :: IO ()
boldBlack = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
boldRed :: IO ()
boldRed = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]
boldGreen :: IO ()
boldGreen = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity ]

mediumRed :: IO ()
mediumRed = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumGreen :: IO ()
mediumGreen = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumBlue :: IO ()
mediumBlue = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]
mediumBlack :: IO ()
mediumBlack = [SGR] -> IO ()
setSGR [
  ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Black, ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity ]

greenPass :: IO ()
greenPass = do
  IO ()
mediumBlue
  String -> IO ()
putStr String
"Pass"
  IO ()
mediumBlack

redFail :: IO ()
redFail = do
  IO ()
boldRed
  String -> IO ()
putStr String
"FAIL"
  IO ()
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 :: TRBuf -> TestResult -> TRBuf
addResult (Top Int
tc Int
fc [TestResult]
trs) TestResult
tr =
  Int -> Int -> [TestResult] -> TRBuf
Top (Int
tc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestResult -> Int
testCount TestResult
tr) (Int
fc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestResult -> Int
failCount TestResult
tr) ([TestResult] -> TRBuf) -> [TestResult] -> TRBuf
forall a b. (a -> b) -> a -> b
$ TestResult
tr TestResult -> [TestResult] -> [TestResult]
forall a. a -> [a] -> [a]
: [TestResult]
trs
addResult (Buf TRBuf
up Int
tc Int
fc String
s [TestResult]
trs) TestResult
tr =
  TRBuf -> Int -> Int -> String -> [TestResult] -> TRBuf
Buf TRBuf
up (Int
tc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestResult -> Int
testCount TestResult
tr) (Int
fc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TestResult -> Int
failCount TestResult
tr) String
s ([TestResult] -> TRBuf) -> [TestResult] -> TRBuf
forall a b. (a -> b) -> a -> b
$ TestResult
tr TestResult -> [TestResult] -> [TestResult]
forall a. a -> [a] -> [a]
: [TestResult]
trs

-- |Convert the topmost group of a bottom-up `TRBuf` into a completed
-- top-down report about the group.
currentGroup :: TRBuf -> TestResult
currentGroup :: TRBuf -> TestResult
currentGroup (Buf TRBuf
up Int
tc Int
fc String
s [TestResult]
trs) = String -> Int -> Int -> [TestResult] -> TestResult
Group String
s Int
tc Int
fc ([TestResult] -> [TestResult]
forall a. [a] -> [a]
reverse [TestResult]
trs)

-- |Derive a new `TRBuf` corresponding to finishing the current group
-- and continuing to accumulate results into its enclosure.
popGroup :: TRBuf -> TRBuf
popGroup :: TRBuf -> TRBuf
popGroup trb :: TRBuf
trb@(Buf TRBuf
acc Int
_ Int
_ String
_ [TestResult]
_) = TRBuf -> TestResult -> TRBuf
addResult TRBuf
acc (TestResult -> TRBuf) -> TestResult -> TRBuf
forall a b. (a -> b) -> a -> b
$ TRBuf -> TestResult
currentGroup TRBuf
trb

-- |Convert a `TRBuf` into a list of top-down `TestResult`s.
closeTRBuf :: TRBuf -> [TestResult]
closeTRBuf :: TRBuf -> [TestResult]
closeTRBuf (Top Int
_ Int
_ [TestResult]
ts) = [TestResult] -> [TestResult]
forall a. [a] -> [a]
reverse [TestResult]
ts
closeTRBuf TRBuf
b = TRBuf -> [TestResult]
closeTRBuf (TRBuf -> [TestResult]) -> TRBuf -> [TestResult]
forall a b. (a -> b) -> a -> b
$ TRBuf -> TRBuf
popGroup TRBuf
b

-- |Record of options which may be specified for running and reporting
-- TLT tests.
data TLTopts = TLTopts {
  TLTopts -> Bool
optShowPasses :: Bool,
  TLTopts -> Bool
optQuitAfterFailReport :: Bool
}

-- |Default initial options
defaultOpts :: TLTopts
defaultOpts = Bool -> Bool -> TLTopts
TLTopts Bool
False Bool
True

-- |Update the display of showing passes in a `TLTopts` record.
withShowPasses :: TLTopts -> Bool -> TLTopts
withShowPasses :: TLTopts -> Bool -> TLTopts
withShowPasses (TLTopts Bool
_ Bool
f) Bool
b = Bool -> Bool -> TLTopts
TLTopts Bool
b Bool
f

-- |Update the display of showing passes in a `TLTopts` record.
withExitAfterFail :: TLTopts -> Bool -> TLTopts
withExitAfterFail :: TLTopts -> Bool -> TLTopts
withExitAfterFail (TLTopts Bool
p Bool
_) Bool
b = Bool -> Bool -> TLTopts
TLTopts Bool
p Bool
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 { TLT m r -> StateT TLTstate m r
unwrap :: StateT TLTstate m r }
  deriving (a -> TLT m b -> TLT m a
(a -> b) -> TLT m a -> TLT m b
(forall a b. (a -> b) -> TLT m a -> TLT m b)
-> (forall a b. a -> TLT m b -> TLT m a) -> Functor (TLT m)
forall a b. a -> TLT m b -> TLT m a
forall a b. (a -> b) -> TLT m a -> TLT m b
forall (m :: * -> *) a b. Functor m => a -> TLT m b -> TLT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TLT m a -> TLT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TLT m b -> TLT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> TLT m b -> TLT m a
fmap :: (a -> b) -> TLT m a -> TLT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TLT m a -> TLT m b
Functor, Functor (TLT m)
a -> TLT m a
Functor (TLT m)
-> (forall a. a -> TLT m a)
-> (forall a b. TLT m (a -> b) -> TLT m a -> TLT m b)
-> (forall a b c. (a -> b -> c) -> TLT m a -> TLT m b -> TLT m c)
-> (forall a b. TLT m a -> TLT m b -> TLT m b)
-> (forall a b. TLT m a -> TLT m b -> TLT m a)
-> Applicative (TLT m)
TLT m a -> TLT m b -> TLT m b
TLT m a -> TLT m b -> TLT m a
TLT m (a -> b) -> TLT m a -> TLT m b
(a -> b -> c) -> TLT m a -> TLT m b -> TLT m c
forall a. a -> TLT m a
forall a b. TLT m a -> TLT m b -> TLT m a
forall a b. TLT m a -> TLT m b -> TLT m b
forall a b. TLT m (a -> b) -> TLT m a -> TLT m b
forall a b c. (a -> b -> c) -> TLT m a -> TLT m b -> TLT m c
forall (m :: * -> *). Monad m => Functor (TLT m)
forall (m :: * -> *) a. Monad m => a -> TLT m a
forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m a
forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m b
forall (m :: * -> *) a b.
Monad m =>
TLT m (a -> b) -> TLT m a -> TLT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TLT m a -> TLT m b -> TLT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: TLT m a -> TLT m b -> TLT m a
$c<* :: forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m a
*> :: TLT m a -> TLT m b -> TLT m b
$c*> :: forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m b
liftA2 :: (a -> b -> c) -> TLT m a -> TLT m b -> TLT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TLT m a -> TLT m b -> TLT m c
<*> :: TLT m (a -> b) -> TLT m a -> TLT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
TLT m (a -> b) -> TLT m a -> TLT m b
pure :: a -> TLT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> TLT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (TLT m)
Applicative, Applicative (TLT m)
a -> TLT m a
Applicative (TLT m)
-> (forall a b. TLT m a -> (a -> TLT m b) -> TLT m b)
-> (forall a b. TLT m a -> TLT m b -> TLT m b)
-> (forall a. a -> TLT m a)
-> Monad (TLT m)
TLT m a -> (a -> TLT m b) -> TLT m b
TLT m a -> TLT m b -> TLT m b
forall a. a -> TLT m a
forall a b. TLT m a -> TLT m b -> TLT m b
forall a b. TLT m a -> (a -> TLT m b) -> TLT m b
forall (m :: * -> *). Monad m => Applicative (TLT m)
forall (m :: * -> *) a. Monad m => a -> TLT m a
forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m b
forall (m :: * -> *) a b.
Monad m =>
TLT m a -> (a -> TLT m b) -> TLT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TLT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TLT m a
>> :: TLT m a -> TLT m b -> TLT m b
$c>> :: forall (m :: * -> *) a b. Monad m => TLT m a -> TLT m b -> TLT m b
>>= :: TLT m a -> (a -> TLT m b) -> TLT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TLT m a -> (a -> TLT m b) -> TLT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TLT m)
Monad, m a -> TLT m a
(forall (m :: * -> *) a. Monad m => m a -> TLT m a)
-> MonadTrans TLT
forall (m :: * -> *) a. Monad m => m a -> TLT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> TLT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> TLT m a
MonadTrans, Monad (TLT m)
Monad (TLT m) -> (forall a. IO a -> TLT m a) -> MonadIO (TLT m)
IO a -> TLT m a
forall a. IO a -> TLT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TLT m)
forall (m :: * -> *) a. MonadIO m => IO a -> TLT m a
liftIO :: IO a -> TLT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TLT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (TLT m)
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 :: TLT m a -> TLT m a
liftTLT = TLT m a -> TLT m a
forall a. a -> a
id

instance (MonadTLT m n, Functor f) => MonadTLT (FreeT f m) n where
    liftTLT :: TLT n a -> FreeT f m a
liftTLT = m a -> FreeT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FreeT f m a) -> (TLT n a -> m a) -> TLT n a -> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (IdentityT m) n where
  liftTLT :: TLT n a -> IdentityT m a
liftTLT = m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> IdentityT m a)
-> (TLT n a -> m a) -> TLT n a -> IdentityT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (MaybeT m) n where
  liftTLT :: TLT n a -> MaybeT m a
liftTLT = m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> MaybeT m a) -> (TLT n a -> m a) -> TLT n a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (ReaderT r m) n where
  liftTLT :: TLT n a -> ReaderT r m a
liftTLT = m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT r m a)
-> (TLT n a -> m a) -> TLT n a -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (ResourceT m) n where
  liftTLT :: TLT n a -> ResourceT m a
liftTLT = m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a)
-> (TLT n a -> m a) -> TLT n a -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (StateT s m) n where
  liftTLT :: TLT n a -> StateT s m a
liftTLT = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a)
-> (TLT n a -> m a) -> TLT n a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (SL.StateT s m) n where
  liftTLT :: TLT n a -> StateT s m a
liftTLT = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a)
-> (TLT n a -> m a) -> TLT n a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (STT s m) n where
  liftTLT :: TLT n a -> STT s m a
liftTLT = m a -> STT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> STT s m a) -> (TLT n a -> m a) -> TLT n a -> STT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance (MonadTLT m n, Monoid w) => MonadTLT (WL.WriterT w m) n where
  liftTLT :: TLT n a -> WriterT w m a
liftTLT = m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT w m a)
-> (TLT n a -> m a) -> TLT n a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance (MonadTLT m n, Monoid w) => MonadTLT (WS.WriterT w m) n where
  liftTLT :: TLT n a -> WriterT w m a
liftTLT = m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT w m a)
-> (TLT n a -> m a) -> TLT n a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLT n a -> m a
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

{- ------------------------------------------------------------ -}

-- |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 `tltCore` instead.
tlt :: MonadIO m => TLT m r -> m ()
tlt :: TLT m r -> m ()
tlt TLT m r
tlt = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Running tests:"
  (TLTopts
opts, [TestResult]
results) <- TLT m r -> m (TLTopts, [TestResult])
forall (m :: * -> *) r.
MonadIO m =>
TLT m r -> m (TLTopts, [TestResult])
tltCore TLT m r
tlt
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TLTopts -> [TestResult] -> IO ()
report TLTopts
opts ([TestResult] -> IO ()) -> [TestResult] -> IO ()
forall a b. (a -> b) -> a -> b
$ [TestResult]
results

-- |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
-- `tlt` instead.
tltCore :: MonadIO m => TLT m r -> m (TLTopts, [TestResult])
tltCore :: TLT m r -> m (TLTopts, [TestResult])
tltCore (TLT StateT TLTstate m r
t) = do
  (r
_, (TLTopts
opts, TRBuf
resultsBuf)) <- StateT TLTstate m r -> TLTstate -> m (r, TLTstate)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT TLTstate m r
t (TLTstate -> m (r, TLTstate)) -> TLTstate -> m (r, TLTstate)
forall a b. (a -> b) -> a -> b
$ (TLTopts
defaultOpts, Int -> Int -> [TestResult] -> TRBuf
Top Int
0 Int
0 [])
  (TLTopts, [TestResult]) -> m (TLTopts, [TestResult])
forall (m :: * -> *) a. Monad m => a -> m a
return (TLTopts
opts, TRBuf -> [TestResult]
closeTRBuf TRBuf
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 :: Bool -> m ()
reportAllTestResults Bool
b = TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
tr) <- StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTstate -> StateT TLTstate n ())
-> TLTstate -> StateT TLTstate n ()
forall a b. (a -> b) -> a -> b
$ (TLTopts
opts TLTopts -> Bool -> TLTopts
`withShowPasses` Bool
b, TRBuf
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 :: Bool -> m ()
setExitAfterFailDisplay Bool
b = TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
tr) <- StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTstate -> StateT TLTstate n ())
-> TLTstate -> StateT TLTstate n ()
forall a b. (a -> b) -> a -> b
$ (TLTopts
opts TLTopts -> Bool -> TLTopts
`withExitAfterFail` Bool
b, TRBuf
tr)

-- |Report a failure.  Useful in pattern-matching cases which are
-- entirely not expected.
tltFail :: MonadTLT m n => String -> String -> m ()
String
desc tltFail :: String -> String -> m ()
`tltFail` String
detail = TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
before) <- StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let after :: TRBuf
after = TRBuf -> TestResult -> TRBuf
addResult TRBuf
before (TestResult -> TRBuf) -> TestResult -> TRBuf
forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
desc [String -> TestFail
Asserted String
detail]
  TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTopts
opts, TRBuf
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 :: String -> m a -> m a
inGroup String
name m a
group = do
  (TLTopts
opts, TRBuf
before) <- TLT n TLTstate -> m TLTstate
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n TLTstate -> m TLTstate) -> TLT n TLTstate -> m TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate -> TLT n TLTstate
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTstate -> StateT TLTstate n ())
-> TLTstate -> StateT TLTstate n ()
forall a b. (a -> b) -> a -> b
$ (TLTopts
opts, TRBuf -> Int -> Int -> String -> [TestResult] -> TRBuf
Buf TRBuf
before Int
0 Int
0 String
name [])
  a
result <- m a
group
  (TLTopts
opts', TRBuf
after) <- TLT n TLTstate -> m TLTstate
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n TLTstate -> m TLTstate) -> TLT n TLTstate -> m TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate -> TLT n TLTstate
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n TLTstate -> TLT n TLTstate)
-> StateT TLTstate n TLTstate -> TLT n TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTstate -> StateT TLTstate n ())
-> TLTstate -> StateT TLTstate n ()
forall a b. (a -> b) -> a -> b
$ (TLTopts
opts', TRBuf -> TRBuf
popGroup TRBuf
after)
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 ()
String
s ~: :: String -> Assertion m -> m ()
~: Assertion m
a = do
  (TLTopts
opts, TRBuf
oldState) <- TLT n TLTstate -> m TLTstate
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n TLTstate -> m TLTstate) -> TLT n TLTstate -> m TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate -> TLT n TLTstate
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n TLTstate -> TLT n TLTstate)
-> StateT TLTstate n TLTstate -> TLT n TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  [TestFail]
assessment <- Assertion m
a
  TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTopts
opts, TRBuf -> TestResult -> TRBuf
addResult TRBuf
oldState (TestResult -> TRBuf) -> TestResult -> TRBuf
forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
s [TestFail]
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 ()
String
s ~::- :: String -> Bool -> m ()
~::- Bool
b = do
  (TLTopts
opts, TRBuf
oldState) <- TLT n TLTstate -> m TLTstate
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n TLTstate -> m TLTstate) -> TLT n TLTstate -> m TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate -> TLT n TLTstate
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n TLTstate -> TLT n TLTstate)
-> StateT TLTstate n TLTstate -> TLT n TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTopts
opts, TRBuf -> TestResult -> TRBuf
addResult TRBuf
oldState (TestResult -> TRBuf) -> TestResult -> TRBuf
forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
s ([TestFail] -> TestResult) -> [TestFail] -> TestResult
forall a b. (a -> b) -> a -> b
$
        if Bool
b then [] else [String -> TestFail
Asserted (String -> TestFail) -> String -> TestFail
forall a b. (a -> b) -> a -> b
$ String
"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 ()
String
s ~:: :: String -> m Bool -> m ()
~:: m Bool
bM = do
  Bool
b <- m Bool
bM
  (TLTopts
opts, TRBuf
oldState) <- TLT n TLTstate -> m TLTstate
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n TLTstate -> m TLTstate) -> TLT n TLTstate -> m TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate -> TLT n TLTstate
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n TLTstate -> TLT n TLTstate)
-> StateT TLTstate n TLTstate -> TLT n TLTstate
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n TLTstate
forall (m :: * -> *) s. Monad m => StateT s m s
get
  TLT n () -> m ()
forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT (TLT n () -> m ()) -> TLT n () -> m ()
forall a b. (a -> b) -> a -> b
$ StateT TLTstate n () -> TLT n ()
forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT (StateT TLTstate n () -> TLT n ())
-> StateT TLTstate n () -> TLT n ()
forall a b. (a -> b) -> a -> b
$ TLTstate -> StateT TLTstate n ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTopts
opts, TRBuf -> TestResult -> TRBuf
addResult TRBuf
oldState (TestResult -> TRBuf) -> TestResult -> TRBuf
forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
s ([TestFail] -> TestResult) -> [TestFail] -> TestResult
forall a b. (a -> b) -> a -> b
$
        if Bool
b then [] else [String -> TestFail
Asserted (String -> TestFail) -> String -> TestFail
forall a b. (a -> b) -> a -> b
$ String
"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 :: (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
tester a -> a -> String
explainer a
exp a
actual = [TestFail] -> Assertion m
forall (m :: * -> *) a. Monad m => a -> m a
return ([TestFail] -> Assertion m) -> [TestFail] -> Assertion m
forall a b. (a -> b) -> a -> b
$
  if (a -> a -> Bool
tester a
exp a
actual) then [] else [String -> TestFail
Asserted (String -> TestFail) -> String -> TestFail
forall a b. (a -> b) -> a -> b
$ a -> a -> String
explainer a
exp a
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 :: (a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
pa a
exp m a
actualM = do a
actual <- m a
actualM
                                   a -> a -> Assertion m
pa a
exp a
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 :: (a -> a -> Bool) -> (a -> a -> String) -> a -> m a -> Assertion m
liftAssertion2M a -> a -> Bool
tester a -> a -> String
explainer a
exp m a
actualM =
  let assertPure :: a -> Assertion m
assertPure = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
tester a -> a -> String
explainer a
exp
  in do a
actual <- m a
actualM
        a -> Assertion m
assertPure a
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
@==- :: a -> a -> Assertion m
(@==-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual -> String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@== :: a -> m a -> Assertion m
(@==) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Eq a, Show a) =>
a -> a -> Assertion m
(@==-)

-- |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
@/=- :: a -> a -> Assertion m
(@/=-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual ->
    String
"Expected other than " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@/= :: a -> m a -> Assertion m
(@/=) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Eq a, Show a) =>
a -> a -> Assertion m
(@/=-)

-- |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
@<- :: a -> a -> Assertion m
(@<-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual ->
    String
"Lower bound (open) is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@< :: a -> m a -> Assertion m
(@<) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Ord a, Show a) =>
a -> a -> Assertion m
(@<-)

-- |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
@>- :: a -> a -> Assertion m
(@>-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual ->
    String
"Upper bound (open) is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@> :: a -> m a -> Assertion m
(@>) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Ord a, Show a) =>
a -> a -> Assertion m
(@>-)

-- |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
@<=- :: a -> a -> Assertion m
(@<=-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual ->
    String
"Lower bound (closed) is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@<= :: a -> m a -> Assertion m
(@<=) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Ord a, Show a) =>
a -> a -> Assertion m
(@<=-)

-- |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
@>=- :: a -> a -> Assertion m
(@>=-) = (a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Bool) -> (a -> a -> String) -> a -> a -> Assertion m
liftAssertion2Pure a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) ((a -> a -> String) -> a -> a -> Assertion m)
-> (a -> a -> String) -> a -> a -> Assertion m
forall a b. (a -> b) -> a -> b
$
  \ a
exp a
actual ->
    String
"Upper bound (closed) is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
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
@>= :: a -> m a -> Assertion m
(@>=) = (a -> a -> Assertion m) -> a -> m a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> a -> Assertion m) -> a -> m a -> Assertion m
assertion2PtoM a -> a -> Assertion m
forall (m :: * -> *) a.
(Monad m, Ord a, Show a) =>
a -> a -> Assertion m
(@>=-)

-- |This assertion always fails with the given message.
assertFailed :: Monad m => String -> Assertion m
assertFailed :: String -> Assertion m
assertFailed String
msg = [TestFail] -> Assertion m
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> TestFail
Asserted String
msg]

-- |This assertion always succeeds.
assertSuccess :: Monad m => Assertion m
assertSuccess :: Assertion m
assertSuccess = [TestFail] -> Assertion m
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- |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")

liftAssertionPure ::
  (Monad m) => (a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure :: (a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure a -> Bool
tester a -> String
explainer a
actual = [TestFail] -> Assertion m
forall (m :: * -> *) a. Monad m => a -> m a
return ([TestFail] -> Assertion m) -> [TestFail] -> Assertion m
forall a b. (a -> b) -> a -> b
$
  if (a -> Bool
tester a
actual) then [] else [String -> TestFail
Asserted (String -> TestFail) -> String -> TestFail
forall a b. (a -> b) -> a -> b
$ a -> String
explainer a
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 `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 :: (a -> Assertion m) -> m a -> Assertion m
assertionPtoM a -> Assertion m
pa m a
actualM = do a
actual <- m a
actualM
                              a -> Assertion m
pa a
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 :: (a -> Bool) -> (a -> String) -> m a -> Assertion m
liftAssertionM a -> Bool
tester a -> String
explainer m a
actualM =
  let assertPure :: a -> Assertion m
assertPure = (a -> Bool) -> (a -> String) -> a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure a -> Bool
tester a -> String
explainer
  in do a
actual <- m a
actualM
        a -> Assertion m
assertPure a
actual

-- |Assert that a pure traversable structure (such as a list) is
-- empty.
emptyP :: (Monad m, Traversable t) => t a -> Assertion m
emptyP :: t a -> Assertion m
emptyP = (t a -> Bool) -> (t a -> String) -> t a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
           (\ t a
_ -> String
"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 :: m (t a) -> Assertion m
empty = (t a -> Assertion m) -> m (t a) -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Assertion m) -> m a -> Assertion m
assertionPtoM t a -> Assertion m
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
t a -> Assertion m
emptyP

-- |Assert that a pure traversable structure (such as a list) is
-- nonempty.
nonemptyP :: (Monad m, Traversable t) => t a -> Assertion m
nonemptyP :: t a -> Assertion m
nonemptyP = (t a -> Bool) -> (t a -> String) -> t a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure (Bool -> Bool
not (Bool -> Bool) -> (t a -> Bool) -> t a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
              (\ t a
_ -> String
"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 :: m (t a) -> Assertion m
nonempty = (t a -> Assertion m) -> m (t a) -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Assertion m) -> m a -> Assertion m
assertionPtoM t a -> Assertion m
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
t a -> Assertion m
nonemptyP

-- |Assert that a `Maybe` value is `Nothing`.
nothingP :: Monad m => Maybe a -> Assertion m
nothingP :: Maybe a -> Assertion m
nothingP = (Maybe a -> Bool) -> (Maybe a -> String) -> Maybe a -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (a -> String) -> a -> Assertion m
liftAssertionPure Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing
           (\ Maybe a
_ -> String
"Expected empty Maybe value but got non-Nothing")

-- |Assert that a `Maybe` result ofa computation is `Nothing`.
nothing :: Monad m => m (Maybe a) -> Assertion m
nothing :: m (Maybe a) -> Assertion m
nothing = (Maybe a -> Assertion m) -> m (Maybe a) -> Assertion m
forall (m :: * -> *) a.
Monad m =>
(a -> Assertion m) -> m a -> Assertion m
assertionPtoM Maybe a -> Assertion m
forall (m :: * -> *) a. Monad m => Maybe a -> Assertion m
nothingP