{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Test.TLT.Class where
import Control.Exception
import Control.Monad
import Control.Monad.ST.Trans
import Control.Monad.Trans.Class
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
type TLTstate = (TLTopts, TRBuf)
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)
class (Monad m, Monad n) => MonadTLT m n | m -> n where
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
runTLT :: Monad m => TLT m r -> m (TLTopts, [TestResult])
runTLT :: TLT m r -> m (TLTopts, [TestResult])
runTLT (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)
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)
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)
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)
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