{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.ImpSpec.Internal where

import Control.DeepSeq (NFData)
import Control.Monad (void)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)
import Control.Monad.State.Strict (MonadState (..))
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack)
import Prettyprinter (
  Doc,
  Pretty (..),
  annotate,
  defaultLayoutOptions,
  hcat,
  indent,
  layoutPretty,
  line,
  vsep,
 )
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, renderLazy)
import System.Random (randomR, split)
import System.Random.Stateful (IOGenM, applyIOGen, newIOGenM)
import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
import Test.Hspec (Spec, SpecWith, beforeAll, beforeAllWith)
import Test.Hspec.Core.Spec (
  Example (..),
  Result (..),
  paramsQuickCheckArgs,
 )
import qualified Test.Hspec.Core.Spec as H
import Test.ImpSpec.Expectations
import Test.ImpSpec.Random
import Test.QuickCheck (Arbitrary, Args (chatty, replay), Testable (..), counterexample, ioProperty)
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.GenT (MonadGen (..))
import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen)
import UnliftIO (MonadIO (liftIO), MonadUnliftIO (..))
import UnliftIO.Exception (
  Exception (..),
  SomeException (..),
  catchAny,
  catchAnyDeep,
  throwIO,
 )
import UnliftIO.IORef
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif

data ImpState t = ImpState
  { forall t. ImpState t -> ImpSpecState t
impStateSpecState :: !(ImpSpecState t)
  , forall t. ImpState t -> Doc AnsiStyle
impStateLog :: !(Doc AnsiStyle)
  }

data ImpEnv t = ImpEnv
  { forall t. ImpEnv t -> ImpSpecEnv t
impEnvSpecEnv :: !(ImpSpecEnv t)
  , forall t. ImpEnv t -> IORef (ImpState t)
impEnvStateRef :: !(IORef (ImpState t))
  , forall t. ImpEnv t -> IOGenM QCGen
impEnvQCGenRef :: !(IOGenM QCGen)
  , forall t. ImpEnv t -> Int
impEnvQCSize :: !Int
  }

class ImpSpec t where
  type ImpSpecEnv t = (r :: Type) | r -> t
  type ImpSpecEnv t = Proxy t
  type ImpSpecState t = (r :: Type) | r -> t
  type ImpSpecState t = Proxy t

  impInitIO :: QCGen -> IO (ImpInit t)
  default impInitIO :: (ImpSpecEnv t ~ Proxy t, ImpSpecState t ~ Proxy t) => QCGen -> IO (ImpInit t)
  impInitIO QCGen
_ = ImpInit t -> IO (ImpInit t)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImpInit t -> IO (ImpInit t)) -> ImpInit t -> IO (ImpInit t)
forall a b. (a -> b) -> a -> b
$ ImpSpecEnv t -> ImpSpecState t -> ImpInit t
forall t. ImpSpecEnv t -> ImpSpecState t -> ImpInit t
ImpInit Proxy t
ImpSpecEnv t
forall {k} (t :: k). Proxy t
Proxy Proxy t
ImpSpecState t
forall {k} (t :: k). Proxy t
Proxy

  -- | This will be the very first action that will run in all `ImpM` specs.
  impPrepAction :: ImpM t ()
  impPrepAction = () -> ImpM t ()
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data ImpInit t = ImpInit
  { forall t. ImpInit t -> ImpSpecEnv t
impInitEnv :: ImpSpecEnv t
  , forall t. ImpInit t -> ImpSpecState t
impInitState :: ImpSpecState t
  }
deriving instance (Eq (ImpSpecEnv t), Eq (ImpSpecState t)) => Eq (ImpInit t)
deriving instance (Ord (ImpSpecEnv t), Ord (ImpSpecState t)) => Ord (ImpInit t)
deriving instance (Show (ImpSpecEnv t), Show (ImpSpecState t)) => Show (ImpInit t)

-- | Stores extra information about the failure of the unit test
data ImpException = ImpException
  { ImpException -> [Doc AnsiStyle]
ieAnnotation :: [Doc AnsiStyle]
  -- ^ Description of the IO action that caused the failure
  , ImpException -> SomeException
ieThrownException :: SomeException
  -- ^ Exception that caused the test to fail
  }
  deriving (Int -> ImpException -> ShowS
[ImpException] -> ShowS
ImpException -> String
(Int -> ImpException -> ShowS)
-> (ImpException -> String)
-> ([ImpException] -> ShowS)
-> Show ImpException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImpException -> ShowS
showsPrec :: Int -> ImpException -> ShowS
$cshow :: ImpException -> String
show :: ImpException -> String
$cshowList :: [ImpException] -> ShowS
showList :: [ImpException] -> ShowS
Show)

instance Exception ImpException where
  displayException :: ImpException -> String
displayException = Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String)
-> (ImpException -> Doc AnsiStyle) -> ImpException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpException -> Doc AnsiStyle
prettyImpException

prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException (ImpException [Doc AnsiStyle]
ann SomeException
e) =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
    [[Doc AnsiStyle]] -> [Doc AnsiStyle]
forall a. Monoid a => [a] -> a
mconcat
      [ [Doc AnsiStyle
"Annotations:"]
      , (Int -> Doc AnsiStyle -> Doc AnsiStyle)
-> [Int] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent [Int
0, Int
2 ..] [Doc AnsiStyle]
ann
      , [Doc AnsiStyle
"Failed with Exception:", Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)]
      ]

newtype ImpM t a = ImpM {forall t a. ImpM t a -> ReaderT (ImpEnv t) IO a
unImpM :: ReaderT (ImpEnv t) IO a}
  deriving
    ( (forall a b. (a -> b) -> ImpM t a -> ImpM t b)
-> (forall a b. a -> ImpM t b -> ImpM t a) -> Functor (ImpM t)
forall a b. a -> ImpM t b -> ImpM t a
forall a b. (a -> b) -> ImpM t a -> ImpM t b
forall t a b. a -> ImpM t b -> ImpM t a
forall t a b. (a -> b) -> ImpM t a -> ImpM t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall t a b. (a -> b) -> ImpM t a -> ImpM t b
fmap :: forall a b. (a -> b) -> ImpM t a -> ImpM t b
$c<$ :: forall t a b. a -> ImpM t b -> ImpM t a
<$ :: forall a b. a -> ImpM t b -> ImpM t a
Functor
    , Functor (ImpM t)
Functor (ImpM t) =>
(forall a. a -> ImpM t a)
-> (forall a b. ImpM t (a -> b) -> ImpM t a -> ImpM t b)
-> (forall a b c.
    (a -> b -> c) -> ImpM t a -> ImpM t b -> ImpM t c)
-> (forall a b. ImpM t a -> ImpM t b -> ImpM t b)
-> (forall a b. ImpM t a -> ImpM t b -> ImpM t a)
-> Applicative (ImpM t)
forall t. Functor (ImpM t)
forall a. a -> ImpM t a
forall t a. a -> ImpM t a
forall a b. ImpM t a -> ImpM t b -> ImpM t a
forall a b. ImpM t a -> ImpM t b -> ImpM t b
forall a b. ImpM t (a -> b) -> ImpM t a -> ImpM t b
forall t a b. ImpM t a -> ImpM t b -> ImpM t a
forall t a b. ImpM t a -> ImpM t b -> ImpM t b
forall t a b. ImpM t (a -> b) -> ImpM t a -> ImpM t b
forall a b c. (a -> b -> c) -> ImpM t a -> ImpM t b -> ImpM t c
forall t a b c. (a -> b -> c) -> ImpM t a -> ImpM t b -> ImpM t 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
$cpure :: forall t a. a -> ImpM t a
pure :: forall a. a -> ImpM t a
$c<*> :: forall t a b. ImpM t (a -> b) -> ImpM t a -> ImpM t b
<*> :: forall a b. ImpM t (a -> b) -> ImpM t a -> ImpM t b
$cliftA2 :: forall t a b c. (a -> b -> c) -> ImpM t a -> ImpM t b -> ImpM t c
liftA2 :: forall a b c. (a -> b -> c) -> ImpM t a -> ImpM t b -> ImpM t c
$c*> :: forall t a b. ImpM t a -> ImpM t b -> ImpM t b
*> :: forall a b. ImpM t a -> ImpM t b -> ImpM t b
$c<* :: forall t a b. ImpM t a -> ImpM t b -> ImpM t a
<* :: forall a b. ImpM t a -> ImpM t b -> ImpM t a
Applicative
    , Applicative (ImpM t)
Applicative (ImpM t) =>
(forall a b. ImpM t a -> (a -> ImpM t b) -> ImpM t b)
-> (forall a b. ImpM t a -> ImpM t b -> ImpM t b)
-> (forall a. a -> ImpM t a)
-> Monad (ImpM t)
forall t. Applicative (ImpM t)
forall a. a -> ImpM t a
forall t a. a -> ImpM t a
forall a b. ImpM t a -> ImpM t b -> ImpM t b
forall a b. ImpM t a -> (a -> ImpM t b) -> ImpM t b
forall t a b. ImpM t a -> ImpM t b -> ImpM t b
forall t a b. ImpM t a -> (a -> ImpM t b) -> ImpM t 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
$c>>= :: forall t a b. ImpM t a -> (a -> ImpM t b) -> ImpM t b
>>= :: forall a b. ImpM t a -> (a -> ImpM t b) -> ImpM t b
$c>> :: forall t a b. ImpM t a -> ImpM t b -> ImpM t b
>> :: forall a b. ImpM t a -> ImpM t b -> ImpM t b
$creturn :: forall t a. a -> ImpM t a
return :: forall a. a -> ImpM t a
Monad
    , Monad (ImpM t)
Monad (ImpM t) => (forall a. IO a -> ImpM t a) -> MonadIO (ImpM t)
forall t. Monad (ImpM t)
forall a. IO a -> ImpM t a
forall t a. IO a -> ImpM t a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall t a. IO a -> ImpM t a
liftIO :: forall a. IO a -> ImpM t a
MonadIO
    , MonadIO (ImpM t)
MonadIO (ImpM t) =>
(forall b. ((forall a. ImpM t a -> IO a) -> IO b) -> ImpM t b)
-> MonadUnliftIO (ImpM t)
forall t. MonadIO (ImpM t)
forall b. ((forall a. ImpM t a -> IO a) -> IO b) -> ImpM t b
forall t b. ((forall a. ImpM t a -> IO a) -> IO b) -> ImpM t b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall t b. ((forall a. ImpM t a -> IO a) -> IO b) -> ImpM t b
withRunInIO :: forall b. ((forall a. ImpM t a -> IO a) -> IO b) -> ImpM t b
MonadUnliftIO
    )

instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where
  ask :: ImpM t env
ask = ImpEnv t -> env
ImpEnv t -> ImpSpecEnv t
forall t. ImpEnv t -> ImpSpecEnv t
impEnvSpecEnv (ImpEnv t -> env) -> ImpM t (ImpEnv t) -> ImpM t env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (ImpEnv t) IO (ImpEnv t) -> ImpM t (ImpEnv t)
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM ReaderT (ImpEnv t) IO (ImpEnv t)
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (env -> env) -> ImpM t a -> ImpM t a
local env -> env
f = ReaderT (ImpEnv t) IO a -> ImpM t a
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO a -> ImpM t a)
-> (ImpM t a -> ReaderT (ImpEnv t) IO a) -> ImpM t a -> ImpM t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImpEnv t -> ImpEnv t)
-> ReaderT (ImpEnv t) IO a -> ReaderT (ImpEnv t) IO a
forall a.
(ImpEnv t -> ImpEnv t)
-> ReaderT (ImpEnv t) IO a -> ReaderT (ImpEnv t) IO a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ImpEnv t
e -> ImpEnv t
e{impEnvSpecEnv = f (impEnvSpecEnv e)}) (ReaderT (ImpEnv t) IO a -> ReaderT (ImpEnv t) IO a)
-> (ImpM t a -> ReaderT (ImpEnv t) IO a)
-> ImpM t a
-> ReaderT (ImpEnv t) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpM t a -> ReaderT (ImpEnv t) IO a
forall t a. ImpM t a -> ReaderT (ImpEnv t) IO a
unImpM

instance Fail.MonadFail (ImpM t) where
  fail :: forall a. String -> ImpM t a
fail = IO a -> ImpM t a
forall a. IO a -> ImpM t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ImpM t a) -> (String -> IO a) -> String -> ImpM t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall a. HasCallStack => String -> IO a
assertFailure

instance s ~ ImpSpecState t => MonadState s (ImpM t) where
  state :: forall a. (s -> (a, s)) -> ImpM t a
state s -> (a, s)
f = do
    ImpEnv{IORef (ImpState t)
impEnvStateRef :: forall t. ImpEnv t -> IORef (ImpState t)
impEnvStateRef :: IORef (ImpState t)
impEnvStateRef} <- ReaderT (ImpEnv t) IO (ImpEnv t) -> ImpM t (ImpEnv t)
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM ReaderT (ImpEnv t) IO (ImpEnv t)
forall r (m :: * -> *). MonadReader r m => m r
ask
    ImpState t
curState <- IORef (ImpState t) -> ImpM t (ImpState t)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (ImpState t)
impEnvStateRef
    let !(a
result, !s
newSpecState) = s -> (a, s)
f (s -> (a, s)) -> s -> (a, s)
forall a b. (a -> b) -> a -> b
$ ImpState t -> ImpSpecState t
forall t. ImpState t -> ImpSpecState t
impStateSpecState ImpState t
curState
    IORef (ImpState t) -> ImpState t -> ImpM t ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (ImpState t)
impEnvStateRef (ImpState t
curState{impStateSpecState = newSpecState})
    a -> ImpM t a
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
  get :: ImpM t s
get = (ImpState t -> s) -> ImpM t (ImpState t) -> ImpM t s
forall a b. (a -> b) -> ImpM t a -> ImpM t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ImpState t -> s
ImpState t -> ImpSpecState t
forall t. ImpState t -> ImpSpecState t
impStateSpecState (ImpM t (ImpState t) -> ImpM t s)
-> (ImpEnv t -> ImpM t (ImpState t)) -> ImpEnv t -> ImpM t s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (ImpState t) -> ImpM t (ImpState t)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (IORef (ImpState t) -> ImpM t (ImpState t))
-> (ImpEnv t -> IORef (ImpState t))
-> ImpEnv t
-> ImpM t (ImpState t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpEnv t -> IORef (ImpState t)
forall t. ImpEnv t -> IORef (ImpState t)
impEnvStateRef (ImpEnv t -> ImpM t s) -> ImpM t (ImpEnv t) -> ImpM t s
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT (ImpEnv t) IO (ImpEnv t) -> ImpM t (ImpEnv t)
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM ReaderT (ImpEnv t) IO (ImpEnv t)
forall r (m :: * -> *). MonadReader r m => m r
ask

instance MonadGen (ImpM t) where
  liftGen :: forall a. Gen a -> ImpM t a
liftGen (MkGen QCGen -> Int -> a
f) = do
    Int
qcSize <- ReaderT (ImpEnv t) IO Int -> ImpM t Int
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO Int -> ImpM t Int)
-> ReaderT (ImpEnv t) IO Int -> ImpM t Int
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> Int) -> ReaderT (ImpEnv t) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> Int
forall t. ImpEnv t -> Int
impEnvQCSize
    QCGen
qcGen <- (QCGen -> (QCGen, QCGen)) -> ImpM t QCGen
forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split
    a -> ImpM t a
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ImpM t a) -> a -> ImpM t a
forall a b. (a -> b) -> a -> b
$ QCGen -> Int -> a
f QCGen
qcGen Int
qcSize
  variant :: forall n a. Integral n => n -> ImpM t a -> ImpM t a
variant n
n ImpM t a
action = do
    (QCGen -> ((), QCGen)) -> ImpM t ()
forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen ((QCGen -> ((), QCGen)) -> ImpM t ())
-> (QCGen -> ((), QCGen)) -> ImpM t ()
forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen -> ((), Integer -> QCGen -> QCGen
forall a. Splittable a => Integer -> a -> a
integerVariant (n -> Integer
forall a. Integral a => a -> Integer
toInteger n
n) QCGen
qcGen)
    ImpM t a
action
  sized :: forall a. (Int -> ImpM t a) -> ImpM t a
sized Int -> ImpM t a
f = ReaderT (ImpEnv t) IO Int -> ImpM t Int
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM ((ImpEnv t -> Int) -> ReaderT (ImpEnv t) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> Int
forall t. ImpEnv t -> Int
impEnvQCSize) ImpM t Int -> (Int -> ImpM t a) -> ImpM t a
forall a b. ImpM t a -> (a -> ImpM t b) -> ImpM t b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ImpM t a
f
  resize :: forall a. Int -> ImpM t a -> ImpM t a
resize Int
n (ImpM ReaderT (ImpEnv t) IO a
f) = ReaderT (ImpEnv t) IO a -> ImpM t a
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO a -> ImpM t a)
-> ReaderT (ImpEnv t) IO a -> ImpM t a
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> ImpEnv t)
-> ReaderT (ImpEnv t) IO a -> ReaderT (ImpEnv t) IO a
forall a.
(ImpEnv t -> ImpEnv t)
-> ReaderT (ImpEnv t) IO a -> ReaderT (ImpEnv t) IO a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ImpEnv t
env -> ImpEnv t
env{impEnvQCSize = n}) ReaderT (ImpEnv t) IO a
f
  choose :: forall a. Random a => (a, a) -> ImpM t a
choose (a, a)
r = (QCGen -> (a, QCGen)) -> ImpM t a
forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen ((a, a) -> QCGen -> (a, QCGen)
forall g. RandomGen g => (a, a) -> g -> (a, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a, a)
r)

instance HasStatefulGen (IOGenM QCGen) (ImpM t) where
  askStatefulGen :: ImpM t (IOGenM QCGen)
askStatefulGen = ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen)
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen))
-> ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen)
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> IOGenM QCGen) -> ReaderT (ImpEnv t) IO (IOGenM QCGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> IOGenM QCGen
forall t. ImpEnv t -> IOGenM QCGen
impEnvQCGenRef

instance (ImpSpec t, Testable a) => Testable (ImpM t a) where
  property :: ImpM t a -> Property
property ImpM t a
m = Gen Property -> Property
forall prop. Testable prop => prop -> Property
property (Gen Property -> Property) -> Gen Property -> Property
forall a b. (a -> b) -> a -> b
$ (QCGen -> Int -> Property) -> Gen Property
forall a. (QCGen -> Int -> a) -> Gen a
MkGen ((QCGen -> Int -> Property) -> Gen Property)
-> (QCGen -> Int -> Property) -> Gen Property
forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSize ->
    IO a -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO a -> Property) -> IO a -> Property
forall a b. (a -> b) -> a -> b
$ do
      let (QCGen
qcGen1, QCGen
qcGen2) = QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split QCGen
qcGen
      ImpInit t
impInit <- QCGen -> IO (ImpInit t)
forall t. ImpSpec t => QCGen -> IO (ImpInit t)
impInitIO QCGen
qcGen1
      Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t a -> IO a
forall t b.
ImpSpec t =>
Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
evalImpM (QCGen -> Maybe QCGen
forall a. a -> Maybe a
Just QCGen
qcGen2) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
qcSize) ImpInit t
impInit ImpM t a
m

instance (ImpSpec t, Testable p) => Example (ImpM t p) where
  type Arg (ImpM t p) = ImpInit t

  evaluateExample :: ImpM t p
-> Params
-> (ActionWith (Arg (ImpM t p)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpM t p
impTest = (() -> ImpM t p)
-> Params
-> (ActionWith (Arg (() -> ImpM t p)) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> ImpM t p
impTest)

instance (Arbitrary a, Show a, ImpSpec t, Testable p) => Example (a -> ImpM t p) where
  type Arg (a -> ImpM t p) = ImpInit t

  evaluateExample :: (a -> ImpM t p)
-> Params
-> (ActionWith (Arg (a -> ImpM t p)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> ImpM t p
impTest Params
params ActionWith (Arg (a -> ImpM t p)) -> IO ()
hook ProgressCallback
progressCallback = do
    let runImpExample :: ImpInit t -> Property
runImpExample ImpInit t
impInit = (a -> IO ()) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> IO ()) -> Property) -> (a -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ \a
x -> do
          let args :: Args
args = Params -> Args
paramsQuickCheckArgs Params
params
              mQC :: Maybe (QCGen, Int)
mQC = Args -> Maybe (QCGen, Int)
replay (Params -> Args
paramsQuickCheckArgs Params
params)

          (Maybe (QCGen, Int)
r, p
testable, Doc AnsiStyle
logs) <- Maybe QCGen
-> Maybe Int
-> ImpInit t
-> ImpM t (Maybe (QCGen, Int), p, Doc AnsiStyle)
-> IO (Maybe (QCGen, Int), p, Doc AnsiStyle)
forall t b.
ImpSpec t =>
Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
evalImpM ((QCGen, Int) -> QCGen
forall a b. (a, b) -> a
fst ((QCGen, Int) -> QCGen) -> Maybe (QCGen, Int) -> Maybe QCGen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (QCGen, Int)
mQC) ((QCGen, Int) -> Int
forall a b. (a, b) -> b
snd ((QCGen, Int) -> Int) -> Maybe (QCGen, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (QCGen, Int)
mQC) ImpInit t
impInit (ImpM t (Maybe (QCGen, Int), p, Doc AnsiStyle)
 -> IO (Maybe (QCGen, Int), p, Doc AnsiStyle))
-> ImpM t (Maybe (QCGen, Int), p, Doc AnsiStyle)
-> IO (Maybe (QCGen, Int), p, Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ do
            p
t <- a -> ImpM t p
impTest a
x
            Int
qcSize <- ReaderT (ImpEnv t) IO Int -> ImpM t Int
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO Int -> ImpM t Int)
-> ReaderT (ImpEnv t) IO Int -> ImpM t Int
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> Int) -> ReaderT (ImpEnv t) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> Int
forall t. ImpEnv t -> Int
impEnvQCSize
            QCGen
qcGen <- (QCGen -> (QCGen, QCGen)) -> ImpM t QCGen
forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split
            Doc AnsiStyle
logs <- ImpM t (Doc AnsiStyle)
forall t. ImpM t (Doc AnsiStyle)
getLogs
            (Maybe (QCGen, Int), p, Doc AnsiStyle)
-> ImpM t (Maybe (QCGen, Int), p, Doc AnsiStyle)
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((QCGen, Int) -> Maybe (QCGen, Int)
forall a. a -> Maybe a
Just (QCGen
qcGen, Int
qcSize), p
t, Doc AnsiStyle
logs)
          let params' :: Params
params' = Params
params{paramsQuickCheckArgs = args{replay = r, chatty = False}}
          Result
res <-
            Property
-> Params
-> (ActionWith (Arg Property) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample
              (String -> p -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Doc AnsiStyle -> String
ansiDocToString Doc AnsiStyle
logs) p
testable)
              Params
params'
              (\ActionWith (Arg Property)
f -> ActionWith (Arg (a -> ImpM t p)) -> IO ()
hook (\Arg (a -> ImpM t p)
_st -> ActionWith (Arg Property)
f ()))
              ProgressCallback
progressCallback
          IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ ResultStatus -> IO Any
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ResultStatus -> IO Any) -> ResultStatus -> IO Any
forall a b. (a -> b) -> a -> b
$ Result -> ResultStatus
resultStatus Result
res
    (ImpInit t -> Property)
-> Params
-> (ActionWith (Arg (ImpInit t -> Property)) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ImpInit t -> Property
runImpExample Params
params ActionWith (Arg (a -> ImpM t p)) -> IO ()
ActionWith (Arg (ImpInit t -> Property)) -> IO ()
hook ProgressCallback
progressCallback

applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen :: forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen QCGen -> (b, QCGen)
f = do
  IOGenM QCGen
qcGenRef <- ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen)
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen))
-> ReaderT (ImpEnv t) IO (IOGenM QCGen) -> ImpM t (IOGenM QCGen)
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> IOGenM QCGen) -> ReaderT (ImpEnv t) IO (IOGenM QCGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> IOGenM QCGen
forall t. ImpEnv t -> IOGenM QCGen
impEnvQCGenRef
  (QCGen -> (b, QCGen)) -> IOGenM QCGen -> ImpM t b
forall (m :: * -> *) g a.
MonadIO m =>
(g -> (a, g)) -> IOGenM g -> m a
applyIOGen QCGen -> (b, QCGen)
f IOGenM QCGen
qcGenRef

getLogs :: ImpM t (Doc AnsiStyle)
getLogs :: forall t. ImpM t (Doc AnsiStyle)
getLogs = do
  IORef (ImpState t)
ref <- ReaderT (ImpEnv t) IO (IORef (ImpState t))
-> ImpM t (IORef (ImpState t))
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO (IORef (ImpState t))
 -> ImpM t (IORef (ImpState t)))
-> ReaderT (ImpEnv t) IO (IORef (ImpState t))
-> ImpM t (IORef (ImpState t))
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> IORef (ImpState t))
-> ReaderT (ImpEnv t) IO (IORef (ImpState t))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> IORef (ImpState t)
forall t. ImpEnv t -> IORef (ImpState t)
impEnvStateRef
  ImpState t -> Doc AnsiStyle
forall t. ImpState t -> Doc AnsiStyle
impStateLog (ImpState t -> Doc AnsiStyle)
-> ImpM t (ImpState t) -> ImpM t (Doc AnsiStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ImpState t) -> ImpM t (ImpState t)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (ImpState t)
ref

modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
modifyLogs :: forall t. (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
modifyLogs Doc AnsiStyle -> Doc AnsiStyle
f = do
  IORef (ImpState t)
ref <- ReaderT (ImpEnv t) IO (IORef (ImpState t))
-> ImpM t (IORef (ImpState t))
forall t a. ReaderT (ImpEnv t) IO a -> ImpM t a
ImpM (ReaderT (ImpEnv t) IO (IORef (ImpState t))
 -> ImpM t (IORef (ImpState t)))
-> ReaderT (ImpEnv t) IO (IORef (ImpState t))
-> ImpM t (IORef (ImpState t))
forall a b. (a -> b) -> a -> b
$ (ImpEnv t -> IORef (ImpState t))
-> ReaderT (ImpEnv t) IO (IORef (ImpState t))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpEnv t -> IORef (ImpState t)
forall t. ImpEnv t -> IORef (ImpState t)
impEnvStateRef
  IORef (ImpState t) -> (ImpState t -> ImpState t) -> ImpM t ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef (ImpState t)
ref ((ImpState t -> ImpState t) -> ImpM t ())
-> (ImpState t -> ImpState t) -> ImpM t ()
forall a b. (a -> b) -> a -> b
$ \ImpState t
s -> ImpState t
s{impStateLog = f (impStateLog s)}

-- | Override the QuickCheck generator using a fixed seed.
impSetSeed :: Int -> ImpM t ()
impSetSeed :: forall t. Int -> ImpM t ()
impSetSeed Int
seed = (QCGen -> ((), QCGen)) -> ImpM t ()
forall b t. (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen ((QCGen -> ((), QCGen)) -> ImpM t ())
-> (QCGen -> ((), QCGen)) -> ImpM t ()
forall a b. (a -> b) -> a -> b
$ \QCGen
_ -> ((), Int -> QCGen
mkQCGen Int
seed)

evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b)
evalImpGenM :: forall t b. ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b)
evalImpGenM ImpInit t
impInit = (IO (b, ImpState t) -> IO b)
-> Gen (IO (b, ImpState t)) -> Gen (IO b)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((b, ImpState t) -> b) -> IO (b, ImpState t) -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, ImpState t) -> b
forall a b. (a, b) -> a
fst) (Gen (IO (b, ImpState t)) -> Gen (IO b))
-> (ImpM t b -> Gen (IO (b, ImpState t))) -> ImpM t b -> Gen (IO b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
forall t b.
ImpSpec t =>
ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
runImpGenM ImpInit t
impInit

evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
evalImpM :: forall t b.
ImpSpec t =>
Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
evalImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit = ((b, ImpState t) -> b) -> IO (b, ImpState t) -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, ImpState t) -> b
forall a b. (a, b) -> a
fst (IO (b, ImpState t) -> IO b)
-> (ImpM t b -> IO (b, ImpState t)) -> ImpM t b -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
runImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit

execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t))
execImpGenM :: forall t b.
ImpSpec t =>
ImpInit t -> ImpM t b -> Gen (IO (ImpState t))
execImpGenM ImpInit t
impInit = (IO (b, ImpState t) -> IO (ImpState t))
-> Gen (IO (b, ImpState t)) -> Gen (IO (ImpState t))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((b, ImpState t) -> ImpState t)
-> IO (b, ImpState t) -> IO (ImpState t)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, ImpState t) -> ImpState t
forall a b. (a, b) -> b
snd) (Gen (IO (b, ImpState t)) -> Gen (IO (ImpState t)))
-> (ImpM t b -> Gen (IO (b, ImpState t)))
-> ImpM t b
-> Gen (IO (ImpState t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
forall t b.
ImpSpec t =>
ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
runImpGenM ImpInit t
impInit

execImpM ::
  ImpSpec t =>
  Maybe QCGen ->
  Maybe Int ->
  ImpInit t ->
  ImpM t b ->
  IO (ImpState t)
execImpM :: forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (ImpState t)
execImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit = ((b, ImpState t) -> ImpState t)
-> IO (b, ImpState t) -> IO (ImpState t)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, ImpState t) -> ImpState t
forall a b. (a, b) -> b
snd (IO (b, ImpState t) -> IO (ImpState t))
-> (ImpM t b -> IO (b, ImpState t)) -> ImpM t b -> IO (ImpState t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
runImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit

runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ())
runImpGenM_ :: forall t b. ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ())
runImpGenM_ ImpInit t
impInit = (IO (b, ImpState t) -> IO ())
-> Gen (IO (b, ImpState t)) -> Gen (IO ())
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IO (b, ImpState t) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Gen (IO (b, ImpState t)) -> Gen (IO ()))
-> (ImpM t b -> Gen (IO (b, ImpState t)))
-> ImpM t b
-> Gen (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
forall t b.
ImpSpec t =>
ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
runImpGenM ImpInit t
impInit

runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO ()
runImpM_ :: forall t b.
ImpSpec t =>
Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO ()
runImpM_ Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit = IO (b, ImpState t) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (b, ImpState t) -> IO ())
-> (ImpM t b -> IO (b, ImpState t)) -> ImpM t b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
runImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit t
impInit

runImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
runImpGenM :: forall t b.
ImpSpec t =>
ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
runImpGenM ImpInit t
impInit ImpM t b
m =
  (QCGen -> Int -> IO (b, ImpState t)) -> Gen (IO (b, ImpState t))
forall a. (QCGen -> Int -> a) -> Gen a
MkGen ((QCGen -> Int -> IO (b, ImpState t)) -> Gen (IO (b, ImpState t)))
-> (QCGen -> Int -> IO (b, ImpState t)) -> Gen (IO (b, ImpState t))
forall a b. (a -> b) -> a -> b
$ \QCGen
qcGen Int
qcSize -> Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
runImpM (QCGen -> Maybe QCGen
forall a. a -> Maybe a
Just QCGen
qcGen) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
qcSize) ImpInit t
impInit ImpM t b
m

runImpM ::
  ImpSpec t =>
  Maybe QCGen ->
  Maybe Int ->
  ImpInit t ->
  ImpM t b ->
  IO (b, ImpState t)
runImpM :: forall t b.
ImpSpec t =>
Maybe QCGen
-> Maybe Int -> ImpInit t -> ImpM t b -> IO (b, ImpState t)
runImpM Maybe QCGen
mQCGen Maybe Int
mQCSize ImpInit{ImpSpecEnv t
impInitEnv :: forall t. ImpInit t -> ImpSpecEnv t
impInitEnv :: ImpSpecEnv t
impInitEnv, ImpSpecState t
impInitState :: forall t. ImpInit t -> ImpSpecState t
impInitState :: ImpSpecState t
impInitState} ImpM t b
action = do
  let qcSize :: Int
qcSize = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
30 Maybe Int
mQCSize
      qcGen :: QCGen
qcGen = QCGen -> Maybe QCGen -> QCGen
forall a. a -> Maybe a -> a
fromMaybe (Int -> QCGen
mkQCGen Int
2024) Maybe QCGen
mQCGen
  IORef (ImpState t)
ioRef <-
    ImpState t -> IO (IORef (ImpState t))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (ImpState t -> IO (IORef (ImpState t)))
-> ImpState t -> IO (IORef (ImpState t))
forall a b. (a -> b) -> a -> b
$
      ImpState
        { impStateSpecState :: ImpSpecState t
impStateSpecState = ImpSpecState t
impInitState
        , impStateLog :: Doc AnsiStyle
impStateLog = Doc AnsiStyle
forall a. Monoid a => a
mempty
        }
  IOGenM QCGen
qcGenRef <- QCGen -> IO (IOGenM QCGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM QCGen
qcGen
  let
    env :: ImpEnv t
env =
      ImpEnv
        { impEnvSpecEnv :: ImpSpecEnv t
impEnvSpecEnv = ImpSpecEnv t
impInitEnv
        , impEnvStateRef :: IORef (ImpState t)
impEnvStateRef = IORef (ImpState t)
ioRef
        , impEnvQCGenRef :: IOGenM QCGen
impEnvQCGenRef = IOGenM QCGen
qcGenRef
        , impEnvQCSize :: Int
impEnvQCSize = Int
qcSize
        }
  b
res <-
    ReaderT (ImpEnv t) IO b -> ImpEnv t -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ImpM t b -> ReaderT (ImpEnv t) IO b
forall t a. ImpM t a -> ReaderT (ImpEnv t) IO a
unImpM (ImpM t ()
forall t. ImpSpec t => ImpM t ()
impPrepAction ImpM t () -> ImpM t b -> ImpM t b
forall a b. ImpM t a -> ImpM t b -> ImpM t b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ImpM t b
action)) ImpEnv t
env IO b -> (SomeException -> IO b) -> IO b
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
exc -> do
      Doc AnsiStyle
logs <- ImpState t -> Doc AnsiStyle
forall t. ImpState t -> Doc AnsiStyle
impStateLog (ImpState t -> Doc AnsiStyle)
-> IO (ImpState t) -> IO (Doc AnsiStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ImpState t) -> IO (ImpState t)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (ImpState t)
ioRef
      let [Doc ann]
x <?> :: [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe a
my = case Maybe a
my of
            Maybe a
Nothing -> [Doc ann]
x
            Just a
y -> [Doc ann]
x [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
y]
          uncaughtException :: [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header e
excThrown =
            String -> FailureReason
H.ColorizedReason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$
              Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$
                [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
                  [Doc AnsiStyle]
header [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc AnsiStyle) -> String -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String
"Uncaught Exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall e. Exception e => e -> String
displayException e
excThrown]
          fromHUnitFailure :: [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header (HUnitFailure Maybe SrcLoc
mSrcLoc FailureReason
failReason) =
            case FailureReason
failReason of
              Reason String
msg ->
                Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation (SrcLoc -> Location) -> Maybe SrcLoc -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$
                  String -> FailureReason
H.ColorizedReason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$
                    Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$
                      [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
                        [Doc AnsiStyle]
header [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
              ExpectedButGot Maybe String
mMsg String
expected String
got ->
                Maybe Location -> FailureReason -> ResultStatus
H.Failure (SrcLoc -> Location
srcLocToLocation (SrcLoc -> Location) -> Maybe SrcLoc -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SrcLoc
mSrcLoc) (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$
                  Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (String -> Maybe String
forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header [Doc AnsiStyle] -> Maybe String -> [Doc AnsiStyle]
forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mMsg))) String
expected String
got
          adjustFailureReason :: [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header = \case
            H.Failure Maybe Location
mLoc FailureReason
failureReason ->
              Maybe Location -> FailureReason -> ResultStatus
H.Failure Maybe Location
mLoc (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$
                case FailureReason
failureReason of
                  FailureReason
H.NoReason ->
                    String -> FailureReason
H.ColorizedReason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
"NoReason"]
                  H.Reason String
msg ->
                    String -> FailureReason
H.ColorizedReason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg)]
                  H.ColorizedReason String
msg ->
                    String -> FailureReason
H.ColorizedReason (String -> FailureReason) -> String -> FailureReason
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle]
header [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg]
                  H.ExpectedButGot Maybe String
mPreface String
expected String
actual ->
                    Maybe String -> String -> String -> FailureReason
H.ExpectedButGot (String -> Maybe String
forall a. a -> Maybe a
Just (Doc AnsiStyle -> String
ansiDocToString (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle]
header [Doc AnsiStyle] -> Maybe String -> [Doc AnsiStyle]
forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mPreface))) String
expected String
actual
                  H.Error Maybe String
mInfo SomeException
excThrown -> [Doc AnsiStyle] -> SomeException -> FailureReason
forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException ([Doc AnsiStyle]
header [Doc AnsiStyle] -> Maybe String -> [Doc AnsiStyle]
forall {a} {ann}. Pretty a => [Doc ann] -> Maybe a -> [Doc ann]
<?> Maybe String
mInfo) SomeException
excThrown
            ResultStatus
result -> ResultStatus
result
          newExc :: ResultStatus
newExc
            | Just HUnitFailure
hUnitExc <- SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle
logs] HUnitFailure
hUnitExc
            | Just ResultStatus
hspecFailure <- SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc = [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle
logs] ResultStatus
hspecFailure
            | Just (ImpException [Doc AnsiStyle]
ann SomeException
excThrown) <- SomeException -> Maybe ImpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc =
                let annLen :: Int
annLen = [Doc AnsiStyle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc AnsiStyle]
ann
                    header :: [Doc AnsiStyle]
header =
                      Doc AnsiStyle
logs
                        Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
: [ let prefix :: Doc AnsiStyle
prefix
                                  | Int
annLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = Doc AnsiStyle
"╺╸"
                                  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Doc AnsiStyle
"┏╸"
                                  | Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
annLen = Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗━╸"
                                  | Bool
otherwise = Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Doc AnsiStyle
"┗┳╸"
                             in AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) Doc AnsiStyle
prefix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) Doc AnsiStyle
a
                          | (Int
n, Doc AnsiStyle
a) <- [Int] -> [Doc AnsiStyle] -> [(Int, Doc AnsiStyle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Doc AnsiStyle]
ann
                          ]
                        [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. [a] -> [a] -> [a]
++ [Doc AnsiStyle
""]
                 in case SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
                      Just HUnitFailure
hUnitExc -> [Doc AnsiStyle] -> HUnitFailure -> ResultStatus
fromHUnitFailure [Doc AnsiStyle]
header HUnitFailure
hUnitExc
                      Maybe HUnitFailure
Nothing ->
                        case SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
excThrown of
                          Just ResultStatus
hspecFailure -> [Doc AnsiStyle] -> ResultStatus -> ResultStatus
adjustFailureReason [Doc AnsiStyle]
header ResultStatus
hspecFailure
                          Maybe ResultStatus
Nothing -> Maybe Location -> FailureReason -> ResultStatus
H.Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> SomeException -> FailureReason
forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle]
header SomeException
excThrown
            | Bool
otherwise = Maybe Location -> FailureReason -> ResultStatus
H.Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> SomeException -> FailureReason
forall {e}. Exception e => [Doc AnsiStyle] -> e -> FailureReason
uncaughtException [Doc AnsiStyle
logs] SomeException
exc
      ResultStatus -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ResultStatus
newExc
  ImpState t
endState <- IORef (ImpState t) -> IO (ImpState t)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (ImpState t)
ioRef
  (b, ImpState t) -> IO (b, ImpState t)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
res, ImpState t
endState)

ansiDocToString :: Doc AnsiStyle -> String
ansiDocToString :: Doc AnsiStyle -> String
ansiDocToString = Text -> String
TL.unpack (Text -> String)
-> (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream AnsiStyle -> Text
renderLazy (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec
withImpInit :: forall t. ImpSpec t => SpecWith (ImpInit t) -> Spec
withImpInit = IO (ImpInit t) -> SpecWith (ImpInit t) -> Spec
forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll (QCGen -> IO (ImpInit t)
forall t. ImpSpec t => QCGen -> IO (ImpInit t)
impInitIO (Int -> QCGen
mkQCGen Int
2024))

modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit :: forall t.
(ImpInit t -> ImpInit t)
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit ImpInit t -> ImpInit t
f = (ImpInit t -> IO (ImpInit t))
-> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
forall b a. HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b
beforeAllWith (ImpInit t -> IO (ImpInit t)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImpInit t -> IO (ImpInit t))
-> (ImpInit t -> ImpInit t) -> ImpInit t -> IO (ImpInit t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpInit t -> ImpInit t
f)

-- | Annotation for when failure happens. All the logging done within annotation will be
-- discarded if there no failures within the annotation.
impAnn :: NFData a => String -> ImpM t a -> ImpM t a
impAnn :: forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
msg = Doc AnsiStyle -> ImpM t a -> ImpM t a
forall a t. NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a
impAnnDoc (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg)

impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a
impAnnDoc :: forall a t. NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a
impAnnDoc Doc AnsiStyle
msg ImpM t a
m = do
  Doc AnsiStyle
logs <- ImpM t (Doc AnsiStyle)
forall t. ImpM t (Doc AnsiStyle)
getLogs
  a
res <- ImpM t a -> (SomeException -> ImpM t a) -> ImpM t a
forall a (m :: * -> *).
(NFData a, MonadUnliftIO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep ImpM t a
m ((SomeException -> ImpM t a) -> ImpM t a)
-> (SomeException -> ImpM t a) -> ImpM t a
forall a b. (a -> b) -> a -> b
$ \SomeException
exc ->
    ImpException -> ImpM t a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ImpException -> ImpM t a) -> ImpException -> ImpM t a
forall a b. (a -> b) -> a -> b
$
      case SomeException -> Maybe ImpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
        Just (ImpException [Doc AnsiStyle]
ann SomeException
origExc) -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException (Doc AnsiStyle
msg Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
: [Doc AnsiStyle]
ann) SomeException
origExc
        Maybe ImpException
Nothing -> [Doc AnsiStyle] -> SomeException -> ImpException
ImpException [Doc AnsiStyle
msg] SomeException
exc
  (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
forall t. (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
modifyLogs (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. a -> b -> a
const Doc AnsiStyle
logs)
  a -> ImpM t a
forall a. a -> ImpM t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- | Adds a source location and Doc to the log, which are only shown if the test fails
logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack :: forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack CallStack
callStack Doc AnsiStyle
entry =
  (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
forall t. (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
modifyLogs (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
stack Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc AnsiStyle
entry Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line)
  where
    prettySrcLoc' :: SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc{String
srcLocModule :: String
srcLocModule :: SrcLoc -> String
srcLocModule, Int
srcLocStartLine :: Int
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine} =
      [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
hcat
        [ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
c) Doc AnsiStyle
d
        | (Color
c, Doc AnsiStyle
d) <-
            [ (Color
Yellow, Doc AnsiStyle
"[")
            , (Color
Blue, String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocModule)
            , (Color
Yellow, Doc AnsiStyle
":")
            , (Color
Magenta, Int -> Doc AnsiStyle
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
srcLocStartLine)
            , (Color
Yellow, Doc AnsiStyle
"]")
            ]
        ]
    prefix :: Int -> Doc ann
prefix Int
n = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then Doc ann
"" else Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Doc ann
"└"
    stack :: Doc AnsiStyle
stack =
      [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep
        [Int -> Doc AnsiStyle
forall ann. Int -> Doc ann
prefix Int
n Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> SrcLoc -> Doc AnsiStyle
prettySrcLoc' SrcLoc
loc | (Int
n, (String
_, SrcLoc
loc)) <- [Int] -> [(String, SrcLoc)] -> [(Int, (String, SrcLoc))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0, Int
2 ..] ([(String, SrcLoc)] -> [(Int, (String, SrcLoc))])
-> ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> [(String, SrcLoc)]
-> [(Int, (String, SrcLoc))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse ([(String, SrcLoc)] -> [(Int, (String, SrcLoc))])
-> [(String, SrcLoc)] -> [(Int, (String, SrcLoc))]
forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
getCallStack CallStack
callStack]

-- | Adds a Doc to the log, which is only shown if the test fails
logDoc :: HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc :: forall t. HasCallStack => Doc AnsiStyle -> ImpM t ()
logDoc = CallStack -> Doc AnsiStyle -> ImpM t ()
forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
CallStack
?callStack

-- | Adds a Text to the log, which is only shown if the test fails
logText :: HasCallStack => Text -> ImpM t ()
logText :: forall t. HasCallStack => Text -> ImpM t ()
logText = CallStack -> Doc AnsiStyle -> ImpM t ()
forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
CallStack
?callStack (Doc AnsiStyle -> ImpM t ())
-> (Text -> Doc AnsiStyle) -> Text -> ImpM t ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty

-- | Adds a String to the log, which is only shown if the test fails
logString :: HasCallStack => String -> ImpM t ()
logString :: forall t. HasCallStack => String -> ImpM t ()
logString = CallStack -> Doc AnsiStyle -> ImpM t ()
forall t. CallStack -> Doc AnsiStyle -> ImpM t ()
logWithCallStack HasCallStack
CallStack
?callStack (Doc AnsiStyle -> ImpM t ())
-> (String -> Doc AnsiStyle) -> String -> ImpM t ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty