{-|
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 { forall (m :: * -> *) r. TLT m r -> StateT TLTstate m r
unwrap :: StateT TLTstate m r }
  deriving (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
<$ :: forall a b. a -> TLT m b -> TLT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> TLT m b -> TLT m a
fmap :: forall a b. (a -> b) -> TLT m a -> TLT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TLT m a -> TLT m b
Functor, 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
<* :: forall a b. 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
*> :: forall a b. 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 :: forall a b c. (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
<*> :: forall a b. 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 :: forall a. a -> TLT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> TLT m a
Applicative, 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 :: forall a. a -> TLT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TLT m a
>> :: forall a b. 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
>>= :: forall a 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
Monad, 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 :: forall (m :: * -> *) a. Monad m => m a -> TLT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> TLT m a
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 :: forall a. TLT m a -> TLT m a
liftTLT = forall a. a -> a
id

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

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

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

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

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

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

instance MonadTLT m n => MonadTLT (ExceptT e m) n where
  liftTLT :: forall a. TLT n a -> ExceptT e m a
liftTLT = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. TLT n a -> StateT s m a
liftTLT = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT

instance MonadTLT m n => MonadTLT (STT s m) n where
  liftTLT :: forall a. TLT n a -> STT s m a
liftTLT = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. TLT n a -> WriterT w m a
liftTLT = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. TLT n a -> WriterT w m a
liftTLT = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
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 :: forall (m :: * -> *) r.
Monad m =>
TLT m r -> m (TLTopts, [TestResult])
runTLT (TLT StateT TLTstate m r
t) = do
  (r
_, (TLTopts
opts, TRBuf
resultsBuf)) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT TLTstate m r
t forall a b. (a -> b) -> a -> b
$ (TLTopts
defaultOpts, Int -> Int -> [TestResult] -> TRBuf
Top Int
0 Int
0 [])
  forall (m :: * -> *) a. Monad m => a -> m a
return (TLTopts
opts, TRBuf -> [TestResult]
closeTRBuf TRBuf
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 :: forall (m :: * -> *) (n :: * -> *). MonadTLT m n => Bool -> m ()
reportAllTestResults Bool
b = forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
tr) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ (TLTopts
opts TLTopts -> Bool -> TLTopts
`withShowPasses` Bool
b, TRBuf
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 :: forall (m :: * -> *) (n :: * -> *). MonadTLT m n => Bool -> m ()
setExitAfterFailDisplay Bool
b = forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
tr) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put 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 :: forall (m :: * -> *) (n :: * -> *).
MonadTLT m n =>
String -> String -> m ()
`tltFail` String
detail = forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
before) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  let after :: TRBuf
after = TRBuf -> TestResult -> TRBuf
addResult TRBuf
before forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
desc [String -> TestFail
Asserted String
detail]
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (TLTopts
opts, TRBuf
after)

-- |Report a success.  Useful in default cases.
tltPass :: MonadTLT m n => String -> m ()
tltPass :: forall (m :: * -> *) (n :: * -> *). MonadTLT m n => String -> m ()
tltPass String
desc = forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ do
  (TLTopts
opts, TRBuf
before) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  let after :: TRBuf
after = TRBuf -> TestResult -> TRBuf
addResult TRBuf
before forall a b. (a -> b) -> a -> b
$ String -> [TestFail] -> TestResult
Test String
desc []
  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 :: forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
String -> m a -> m a
inGroup String
name m a
group = do
  (TLTopts
opts, TRBuf
before) <- forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put 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) <- forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) (n :: * -> *) a.
MonadTLT m n =>
TLT n a -> m a
liftTLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. StateT TLTstate m r -> TLT m r
TLT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ (TLTopts
opts', TRBuf -> TRBuf
popGroup TRBuf
after)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: forall a. ExceptT e m a -> ExceptT e m a
liftTLTExcept = forall a. a -> a
id
  runToExcept :: forall a. ExceptT e m a -> ExceptT e m a
runToExcept = forall a. a -> a
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 :: forall a. ExceptT e ne a -> IdentityT m a
liftTLTExcept = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept
  runToExcept :: forall a. IdentityT m a -> ExceptT e ne a
runToExcept = forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
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 :: forall a. ExceptT e ne a -> WriterT w m a
liftTLTExcept = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept
  runToExcept :: forall a. WriterT w m a -> ExceptT e ne a
runToExcept WriterT w m a
m = forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept forall a b. (a -> b) -> a -> b
$ do (a
res, w
_) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
WL.runWriterT WriterT w m a
m
                                   forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: forall a. ExceptT e ne a -> WriterT w m a
liftTLTExcept = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept
  runToExcept :: forall a. WriterT w m a -> ExceptT e ne a
runToExcept WriterT w m a
m = forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept forall a b. (a -> b) -> a -> b
$ do (a
res, w
_) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
WS.runWriterT WriterT w m a
m
                                   forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Ensure that a computation in `ExceptT` completes without an
-- uncaught exception.
noUncaught_ :: MonadTLTExcept m e nt ne => String -> m a -> m ()
noUncaught_ :: forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
String -> m a -> m ()
noUncaught_ String
loc m a
m = do
  let label :: String
label = String
"No uncaught exception from " forall a. [a] -> [a] -> [a]
++ String
loc
  forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (do forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept m a
m
                             forall (m :: * -> *) (n :: * -> *). MonadTLT m n => String -> m ()
tltPass String
label)
                         (\e
_ -> String
label forall (m :: * -> *) (n :: * -> *).
MonadTLT m n =>
String -> String -> m ()
`tltFail` String
"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 :: forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
(MonadTLTExcept m e nt ne, Show e) =>
String -> m a -> m ()
noUncaught String
loc m a
m = do
  let label :: String
label = String
"No uncaught exception from " forall a. [a] -> [a] -> [a]
++ String
loc
  forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (do forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept m a
m
                             forall (m :: * -> *) (n :: * -> *). MonadTLT m n => String -> m ()
tltPass String
label)
                         (\e
ex -> String
label forall (m :: * -> *) (n :: * -> *).
MonadTLT m n =>
String -> String -> m ()
`tltFail`
                                   (String
"Uncaught exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
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 :: forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
String -> m a -> (e -> ExceptT e ne ()) -> m ()
uncaughtWith String
loc m a
m e -> ExceptT e ne ()
handler =
  forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
ExceptT e ne a -> m a
liftTLTExcept forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (do forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
m a -> ExceptT e ne a
runToExcept m a
m
                             (String
"Expected uncaught exception from " forall a. [a] -> [a] -> [a]
++ String
loc)
                               forall (m :: * -> *) (n :: * -> *).
MonadTLT m n =>
String -> String -> m ()
`tltFail` String
"Did not throw exception")
                         e -> ExceptT e ne ()
handler

-- | Ensure that a computation in `ExceptT` does throw an uncaught
-- exception.
uncaught :: String -> m a -> m ()
uncaught String
loc m a
m = forall (m :: * -> *) e (nt :: * -> *) (ne :: * -> *) a.
MonadTLTExcept m e nt ne =>
String -> m a -> (e -> ExceptT e ne ()) -> m ()
uncaughtWith String
loc m a
m forall a b. (a -> b) -> a -> b
$ \e
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()