input-output-hk / ImpSpec / 28

Committed 13 Sep 2025 12:56AM UTC coverage: 25.292%. Remained the same

Build # 28

Build Type

push

github

Committed by

web-flow

Commit Message

Merge 89228b3fc into cc23ab0cb

Run Details

3 of 9 new or added lines in 1 file covered. (33.33%)

5 existing lines in 2 files now uncovered.

65 of 257 relevant lines covered (25.29%)

0.44 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

26.56

/src/Test/ImpSpec/Internal.hs

{-# 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
  { impStateSpecState :: !(ImpSpecState t)
  , impStateLog :: !(Doc AnsiStyle)
  }

data ImpEnv t = ImpEnv
  { impEnvSpecEnv :: !(ImpSpecEnv t)
  , impEnvStateRef :: !(IORef (ImpState t))
  , impEnvQCGenRef :: !(IOGenM QCGen)
  , 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 _ = pure $ ImpInit Proxy Proxy

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

data ImpInit t = ImpInit
  { impInitEnv :: ImpSpecEnv 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
  { ieAnnotation :: [Doc AnsiStyle]
  -- ^ Description of the IO action that caused the failure
  , ieThrownException :: SomeException
  -- ^ Exception that caused the test to fail
  }
  deriving (Show)

instance Exception ImpException where
  displayException = ansiDocToString . prettyImpException

prettyImpException :: ImpException -> Doc AnsiStyle
prettyImpException (ImpException ann e) =
  vsep $
    mconcat
      [ ["Annotations:"]
      , zipWith indent [0, 2 ..] ann
      , ["Failed with Exception:", indent 4 $ pretty (displayException e)]
      ]

newtype ImpM t a = ImpM {unImpM :: ReaderT (ImpEnv t) IO a}
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadUnliftIO
    )

instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where
  ask = impEnvSpecEnv <$> ImpM ask
  local f = ImpM . local (\e -> e {impEnvSpecEnv = f (impEnvSpecEnv e)}) . unImpM

instance Fail.MonadFail (ImpM t) where
  fail = liftIO . assertFailure

instance s ~ ImpSpecState t => MonadState s (ImpM t) where
  state f = do
    ImpEnv {impEnvStateRef} <- ImpM ask
    curState <- readIORef impEnvStateRef
    let !(result, !newSpecState) = f $ impStateSpecState curState
    writeIORef impEnvStateRef (curState {impStateSpecState = newSpecState})
    pure result
  get = fmap impStateSpecState . readIORef . impEnvStateRef =<< ImpM ask

instance MonadGen (ImpM t) where
  liftGen (MkGen f) = do
    qcSize <- ImpM $ asks impEnvQCSize
    qcGen <- applyQCGen split
    pure $ f qcGen qcSize
  variant n action = do
    applyQCGen $ \qcGen -> ((), integerVariant (toInteger n) qcGen)
    action
  sized f = ImpM (asks impEnvQCSize) >>= f
  resize n (ImpM f) = ImpM $ local (\env -> env {impEnvQCSize = n}) f
  choose r = applyQCGen (randomR r)

instance HasStatefulGen (IOGenM QCGen) (ImpM t) where
  askStatefulGen = ImpM $ asks impEnvQCGenRef

instance (ImpSpec t, Testable a) => Testable (ImpM t a) where
  property m = property $ MkGen $ \qcGen qcSize ->
    ioProperty $ do
      let (qcGen1, qcGen2) = split qcGen
      impInit <- impInitIO qcGen1
      evalImpM (Just qcGen2) (Just qcSize) impInit m

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

  evaluateExample impTest = evaluateExample (\() -> 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 impTest params hook progressCallback = do
    let runImpExample impInit = property $ \x -> do
          let args = paramsQuickCheckArgs params
              mQC = replay (paramsQuickCheckArgs params)

          (r, testable, logs) <- evalImpM (fst <$> mQC) (snd <$> mQC) impInit $ do
            t <- impTest x
            qcSize <- ImpM $ asks impEnvQCSize
            qcGen <- applyQCGen split
            logs <- getLogs
            pure (Just (qcGen, qcSize), t, logs)
          let params' = params {paramsQuickCheckArgs = args {replay = r, chatty = False}}
          res <-
            evaluateExample
              (counterexample (ansiDocToString logs) testable)
              params'
              (\f -> hook (\_st -> f ()))
              progressCallback
          void $ throwIO $ resultStatus res
    evaluateExample runImpExample params hook progressCallback

applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b
applyQCGen f = do
  qcGenRef <- ImpM $ asks impEnvQCGenRef
  applyIOGen f qcGenRef

getLogs :: ImpM t (Doc AnsiStyle)
getLogs = do
  ref <- ImpM $ asks impEnvStateRef
  impStateLog <$> readIORef ref

modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
modifyLogs f = do
  ref <- ImpM $ asks impEnvStateRef
  modifyIORef ref $ \s -> s {impStateLog = f (impStateLog s)}

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

evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b)
evalImpGenM impInit = fmap (fmap fst) . runImpGenM impInit

evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
evalImpM mQCGen mQCSize impInit = fmap fst . runImpM mQCGen mQCSize impInit

execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t))
execImpGenM impInit = fmap (fmap snd) . runImpGenM impInit

execImpM ::
  ImpSpec t =>
  Maybe QCGen ->
  Maybe Int ->
  ImpInit t ->
  ImpM t b ->
  IO (ImpState t)
execImpM mQCGen mQCSize impInit = fmap snd . runImpM mQCGen mQCSize impInit

runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ())
runImpGenM_ impInit = fmap void . runImpGenM impInit

runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO ()
runImpM_ mQCGen mQCSize impInit = void . runImpM mQCGen mQCSize impInit

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

runImpM ::
  ImpSpec t =>
  Maybe QCGen ->
  Maybe Int ->
  ImpInit t ->
  ImpM t b ->
  IO (b, ImpState t)
runImpM mQCGen mQCSize ImpInit {impInitEnv, impInitState} action = do
  let qcSize = fromMaybe 30 mQCSize
      qcGen = fromMaybe (mkQCGen 2024) mQCGen
  ioRef <-
    newIORef $
      ImpState
        { impStateSpecState = impInitState
        , impStateLog = mempty
        }
  qcGenRef <- newIOGenM qcGen
  let
    env =
      ImpEnv
        { impEnvSpecEnv = impInitEnv
        , impEnvStateRef = ioRef
        , impEnvQCGenRef = qcGenRef
        , impEnvQCSize = qcSize
        }
  res <-
    runReaderT (unImpM (impPrepAction >> action)) env `catchAny` \exc -> do
      logs <- impStateLog <$> readIORef ioRef
      let x <?> my = case my of
            Nothing -> x
            Just y -> x ++ [pretty y]
          uncaughtException header excThrown =
            H.ColorizedReason $
              ansiDocToString $
                vsep $
                  header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown]
          fromHUnitFailure header (HUnitFailure mSrcLoc failReason) =
            case failReason of
              Reason msg ->
                H.Failure (srcLocToLocation <$> mSrcLoc) $
                  H.ColorizedReason $
                    ansiDocToString $
                      vsep $
                        header ++ [annotate (color Red) (pretty msg)]
              ExpectedButGot mMsg expected got ->
                H.Failure (srcLocToLocation <$> mSrcLoc) $
                  H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mMsg))) expected got
          adjustFailureReason header = \case
            H.Failure mLoc failureReason ->
              H.Failure mLoc $
                case failureReason of
                  H.NoReason ->
                    H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"]
                  H.Reason msg ->
                    H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)]
                  H.ColorizedReason msg ->
                    H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg]
                  H.ExpectedButGot mPreface expected actual ->
                    H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mPreface))) expected actual
                  H.Error mInfo excThrown -> uncaughtException (header <?> mInfo) excThrown
            result -> result
          newExc
            | Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc
            | Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure
            | Just (ImpException ann excThrown) <- fromException exc =
                let annLen = length ann
                    header =
                      logs
                        : [ let prefix
                                  | annLen <= 1 = "╺╸"
                                  | n <= 0 = "┏╸"
                                  | n + 1 == annLen = indent (n - 1) "┗━╸"
                                  | otherwise = indent (n - 1) "┗┳╸"
                             in annotate (color Red) prefix <> annotate (color Yellow) a
                          | (n, a) <- zip [0 ..] ann
                          ]
                        ++ [""]
                 in case fromException excThrown of
                      Just hUnitExc -> fromHUnitFailure header hUnitExc
                      Nothing ->
                        case fromException excThrown of
                          Just hspecFailure -> adjustFailureReason header hspecFailure
                          Nothing -> H.Failure Nothing $ uncaughtException header excThrown
            | otherwise = H.Failure Nothing $ uncaughtException [logs] exc
      throwIO newExc
  endState <- readIORef ioRef
  pure (res, endState)

ansiDocToString :: Doc AnsiStyle -> String
ansiDocToString = TL.unpack . renderLazy . layoutPretty defaultLayoutOptions

withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec
withImpInit = beforeAll (impInitIO (mkQCGen 2024))

modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
modifyImpInit f = beforeAllWith (pure . 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 msg = impAnnDoc (pretty msg)

impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a
impAnnDoc msg m = do
  logs <- getLogs
  res <- catchAnyDeep m $ \exc ->
    throwIO $
      case fromException exc of
        Just (ImpException ann origExc) -> ImpException (msg : ann) origExc
        Nothing -> ImpException [msg] exc
  modifyLogs (const logs)
  pure 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 callStack entry =
  modifyLogs (<> stack <> line <> indent 2 entry <> line)
  where
    prettySrcLoc' SrcLoc {srcLocModule, srcLocStartLine} =
      hcat
        [ annotate (color c) d
        | (c, d) <-
            [ (Yellow, "[")
            , (Blue, pretty srcLocModule)
            , (Yellow, ":")
            , (Magenta, pretty srcLocStartLine)
            , (Yellow, "]")
            ]
        ]
    prefix n = if n <= 0 then "" else indent (n - 1) "└"
    stack =
      vsep
        [prefix n <> prettySrcLoc' loc | (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack]

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

-- | Adds a Text to the log, which is only shown if the test fails
logText :: HasCallStack => Text -> ImpM t ()
logText = logWithCallStack ?callStack . pretty

-- | Adds a String to the log, which is only shown if the test fails
logString :: HasCallStack => String -> ImpM t ()
logString = logWithCallStack ?callStack . pretty

1	{-# LANGUAGE BangPatterns #-}
2	{-# LANGUAGE CPP #-}
3	{-# LANGUAGE DefaultSignatures #-}
4	{-# LANGUAGE FlexibleContexts #-}
5	{-# LANGUAGE FlexibleInstances #-}
6	{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7	{-# LANGUAGE ImplicitParams #-}
8	{-# LANGUAGE LambdaCase #-}
9	{-# LANGUAGE MultiParamTypeClasses #-}
10	{-# LANGUAGE NamedFieldPuns #-}
11	{-# LANGUAGE OverloadedStrings #-}
12	{-# LANGUAGE StandaloneDeriving #-}
13	{-# LANGUAGE TypeFamilyDependencies #-}
14	{-# LANGUAGE TypeOperators #-}
15	{-# LANGUAGE UndecidableInstances #-}
16
17	module Test.ImpSpec.Internal where
18
19	import Control.DeepSeq (NFData)
20	import Control.Monad (void)
21	import qualified Control.Monad.Fail as Fail
22	import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)
23	import Control.Monad.State.Strict (MonadState (..))
24	import Data.Kind (Type)
25	import Data.Maybe (fromMaybe)
26	import Data.Proxy (Proxy (..))
27	import Data.Text (Text)
28	import qualified Data.Text.Lazy as TL
29	import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), getCallStack)
30	import Prettyprinter (
31	Doc,
32	Pretty (..),
33	annotate,
34	defaultLayoutOptions,
35	hcat,
36	indent,
37	layoutPretty,
38	line,
39	vsep,
40	)
41	import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, renderLazy)
42	import System.Random (randomR, split)
43	import System.Random.Stateful (IOGenM, applyIOGen, newIOGenM)
44	import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
45	import Test.Hspec (Spec, SpecWith, beforeAll, beforeAllWith)
46	import Test.Hspec.Core.Spec (
47	Example (..),
48	Result (..),
49	paramsQuickCheckArgs,
50	)
51	import qualified Test.Hspec.Core.Spec as H
52	import Test.ImpSpec.Expectations
53	import Test.ImpSpec.Random
54	import Test.QuickCheck (Arbitrary, Args (chatty, replay), Testable (..), counterexample, ioProperty)
55	import Test.QuickCheck.Gen (Gen (..))
56	import Test.QuickCheck.GenT (MonadGen (..))
57	import Test.QuickCheck.Random (QCGen (..), integerVariant, mkQCGen)
58	import UnliftIO (MonadIO (liftIO), MonadUnliftIO (..))
59	import UnliftIO.Exception (
60	Exception (..),
61	SomeException (..),
62	catchAny,
63	catchAnyDeep,
64	throwIO,
65	)
66	import UnliftIO.IORef
67	#if !MIN_VERSION_base(4,11,0)
68	import Data.Monoid ((<>))
69	#endif
70
71	data ImpState t = ImpState
72	{ impStateSpecState :: !(ImpSpecState t)	×
73	, impStateLog :: !(Doc AnsiStyle)	×
74	}
75
76	data ImpEnv t = ImpEnv
77	{ impEnvSpecEnv :: !(ImpSpecEnv t)	×
78	, impEnvStateRef :: !(IORef (ImpState t))	2✔
79	, impEnvQCGenRef :: !(IOGenM QCGen)	2✔
80	, impEnvQCSize :: !Int	×
81	}
82
83	class ImpSpec t where
84	type ImpSpecEnv t = (r :: Type) \| r -> t
85	type ImpSpecEnv t = Proxy t
86	type ImpSpecState t = (r :: Type) \| r -> t
87	type ImpSpecState t = Proxy t
88
89	impInitIO :: QCGen -> IO (ImpInit t)
90	default impInitIO :: (ImpSpecEnv t ~ Proxy t, ImpSpecState t ~ Proxy t) => QCGen -> IO (ImpInit t)
91	impInitIO _ = pure $ ImpInit Proxy Proxy	1✔
92
93	-- \| This will be the very first action that will run in all `ImpM` specs.
94	impPrepAction :: ImpM t ()
95	impPrepAction = pure ()	1✔
96
97	data ImpInit t = ImpInit
98	{ impInitEnv :: ImpSpecEnv t	×
99	, impInitState :: ImpSpecState t	×
100	}
101
102	deriving instance (Eq (ImpSpecEnv t), Eq (ImpSpecState t)) => Eq (ImpInit t)	×
103
104	deriving instance (Ord (ImpSpecEnv t), Ord (ImpSpecState t)) => Ord (ImpInit t)	×
105
UNCOV 106	deriving instance (Show (ImpSpecEnv t), Show (ImpSpecState t)) => Show (ImpInit t)	×
107
108	-- \| Stores extra information about the failure of the unit test
109	data ImpException = ImpException
110	{ ieAnnotation :: [Doc AnsiStyle]	×
111	-- ^ Description of the IO action that caused the failure
112	, ieThrownException :: SomeException	×
113	-- ^ Exception that caused the test to fail
114	}
115	deriving (Show)	×
116
117	instance Exception ImpException where	×
118	displayException = ansiDocToString . prettyImpException	×
119
120	prettyImpException :: ImpException -> Doc AnsiStyle
121	prettyImpException (ImpException ann e) =	×
122	vsep $	×
123	mconcat	×
124	[ ["Annotations:"]	×
125	, zipWith indent [0, 2 ..] ann	×
126	, ["Failed with Exception:", indent 4 $ pretty (displayException e)]	×
127	]
128
129	newtype ImpM t a = ImpM {unImpM :: ReaderT (ImpEnv t) IO a}	2✔
130	deriving
131	( Functor	×
132	, Applicative	×
133	, Monad	×
134	, MonadIO	2✔
135	, MonadUnliftIO	×
136	)
137
138	instance env ~ ImpSpecEnv t => MonadReader env (ImpM t) where	×
139	ask = impEnvSpecEnv <$> ImpM ask	×
NEW 140	local f = ImpM . local (\e -> e {impEnvSpecEnv = f (impEnvSpecEnv e)}) . unImpM	×
141
142	instance Fail.MonadFail (ImpM t) where
143	fail = liftIO . assertFailure	×
144
145	instance s ~ ImpSpecState t => MonadState s (ImpM t) where	×
146	state f = do	×
NEW 147	ImpEnv {impEnvStateRef} <- ImpM ask	×
148	curState <- readIORef impEnvStateRef	×
149	let !(result, !newSpecState) = f $ impStateSpecState curState	×
NEW 150	writeIORef impEnvStateRef (curState {impStateSpecState = newSpecState})	×
151	pure result	×
152	get = fmap impStateSpecState . readIORef . impEnvStateRef =<< ImpM ask	×
153
154	instance MonadGen (ImpM t) where
155	liftGen (MkGen f) = do	2✔
156	qcSize <- ImpM $ asks impEnvQCSize	1✔
157	qcGen <- applyQCGen split	2✔
158	pure $ f qcGen qcSize	1✔
159	variant n action = do	×
160	applyQCGen $ \qcGen -> ((), integerVariant (toInteger n) qcGen)	×
161	action	×
162	sized f = ImpM (asks impEnvQCSize) >>= f	×
NEW 163	resize n (ImpM f) = ImpM $ local (\env -> env {impEnvQCSize = n}) f	×
164	choose r = applyQCGen (randomR r)	×
165
166	instance HasStatefulGen (IOGenM QCGen) (ImpM t) where
167	askStatefulGen = ImpM $ asks impEnvQCGenRef	×
168
169	instance (ImpSpec t, Testable a) => Testable (ImpM t a) where	×
170	property m = property $ MkGen $ \qcGen qcSize ->	×
171	ioProperty $ do	×
172	let (qcGen1, qcGen2) = split qcGen	×
173	impInit <- impInitIO qcGen1	×
174	evalImpM (Just qcGen2) (Just qcSize) impInit m	×
175
176	instance (ImpSpec t, Testable p) => Example (ImpM t p) where
177	type Arg (ImpM t p) = ImpInit t
178
179	evaluateExample impTest = evaluateExample (\() -> impTest)	2✔
180
181	instance (Arbitrary a, Show a, ImpSpec t, Testable p) => Example (a -> ImpM t p) where
182	type Arg (a -> ImpM t p) = ImpInit t
183
184	evaluateExample impTest params hook progressCallback = do	2✔
185	let runImpExample impInit = property $ \x -> do	2✔
186	let args = paramsQuickCheckArgs params	2✔
187	mQC = replay (paramsQuickCheckArgs params)	2✔
188
189	(r, testable, logs) <- evalImpM (fst <$> mQC) (snd <$> mQC) impInit $ do	1✔
190	t <- impTest x	2✔
191	qcSize <- ImpM $ asks impEnvQCSize	1✔
192	qcGen <- applyQCGen split	2✔
193	logs <- getLogs	2✔
194	pure (Just (qcGen, qcSize), t, logs)	1✔
195	let params' = params {paramsQuickCheckArgs = args {replay = r, chatty = False}}	1✔
196	res <-
197	evaluateExample	2✔
198	(counterexample (ansiDocToString logs) testable)	1✔
199	params'	2✔
200	(\f -> hook (\_st -> f ()))	2✔
201	progressCallback	2✔
202	void $ throwIO $ resultStatus res	2✔
203	evaluateExample runImpExample params hook progressCallback	2✔
204
205	applyQCGen :: (QCGen -> (b, QCGen)) -> ImpM t b
206	applyQCGen f = do	2✔
207	qcGenRef <- ImpM $ asks impEnvQCGenRef	2✔
208	applyIOGen f qcGenRef	2✔
209
210	getLogs :: ImpM t (Doc AnsiStyle)
211	getLogs = do	2✔
212	ref <- ImpM $ asks impEnvStateRef	2✔
213	impStateLog <$> readIORef ref	1✔
214
215	modifyLogs :: (Doc AnsiStyle -> Doc AnsiStyle) -> ImpM t ()
216	modifyLogs f = do	×
217	ref <- ImpM $ asks impEnvStateRef	×
NEW 218	modifyIORef ref $ \s -> s {impStateLog = f (impStateLog s)}	×
219
220	-- \| Override the QuickCheck generator using a fixed seed.
221	impSetSeed :: Int -> ImpM t ()
222	impSetSeed seed = applyQCGen $ const ((), mkQCGen seed)	2✔
223
224	evalImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO b)
225	evalImpGenM impInit = fmap (fmap fst) . runImpGenM impInit	×
226
227	evalImpM :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO b
228	evalImpM mQCGen mQCSize impInit = fmap fst . runImpM mQCGen mQCSize impInit	1✔
229
230	execImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (ImpState t))
231	execImpGenM impInit = fmap (fmap snd) . runImpGenM impInit	×
232
233	execImpM ::
234	ImpSpec t =>
235	Maybe QCGen ->
236	Maybe Int ->
237	ImpInit t ->
238	ImpM t b ->
239	IO (ImpState t)
240	execImpM mQCGen mQCSize impInit = fmap snd . runImpM mQCGen mQCSize impInit	×
241
242	runImpGenM_ :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO ())
243	runImpGenM_ impInit = fmap void . runImpGenM impInit	×
244
245	runImpM_ :: ImpSpec t => Maybe QCGen -> Maybe Int -> ImpInit t -> ImpM t b -> IO ()
246	runImpM_ mQCGen mQCSize impInit = void . runImpM mQCGen mQCSize impInit	×
247
248	runImpGenM :: ImpSpec t => ImpInit t -> ImpM t b -> Gen (IO (b, ImpState t))
249	runImpGenM impInit m =	×
250	MkGen $ \qcGen qcSize -> runImpM (Just qcGen) (Just qcSize) impInit m	×
251
252	runImpM ::
253	ImpSpec t =>
254	Maybe QCGen ->
255	Maybe Int ->
256	ImpInit t ->
257	ImpM t b ->
258	IO (b, ImpState t)
259	runImpM mQCGen mQCSize ImpInit {impInitEnv, impInitState} action = do	2✔
260	let qcSize = fromMaybe 30 mQCSize	1✔
261	qcGen = fromMaybe (mkQCGen 2024) mQCGen	×
262	ioRef <-
263	newIORef $	2✔
264	ImpState	×
265	{ impStateSpecState = impInitState	×
266	, impStateLog = mempty	×
267	}
268	qcGenRef <- newIOGenM qcGen	1✔
269	let
270	env =	2✔
271	ImpEnv	2✔
272	{ impEnvSpecEnv = impInitEnv	2✔
273	, impEnvStateRef = ioRef	2✔
274	, impEnvQCGenRef = qcGenRef	2✔
275	, impEnvQCSize = qcSize	2✔
276	}
277	res <-
278	runReaderT (unImpM (impPrepAction >> action)) env `catchAny` \exc -> do	1✔
279	logs <- impStateLog <$> readIORef ioRef	×
280	let x <?> my = case my of	×
281	Nothing -> x	×
282	Just y -> x ++ [pretty y]	×
283	uncaughtException header excThrown =	×
284	H.ColorizedReason $	×
285	ansiDocToString $	×
286	vsep $	×
287	header ++ [pretty $ "Uncaught Exception: " <> displayException excThrown]	×
288	fromHUnitFailure header (HUnitFailure mSrcLoc failReason) =	×
289	case failReason of	×
290	Reason msg ->
291	H.Failure (srcLocToLocation <$> mSrcLoc) $	×
292	H.ColorizedReason $	×
293	ansiDocToString $	×
294	vsep $	×
295	header ++ [annotate (color Red) (pretty msg)]	×
296	ExpectedButGot mMsg expected got ->
297	H.Failure (srcLocToLocation <$> mSrcLoc) $	×
298	H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mMsg))) expected got	×
299	adjustFailureReason header = \case	×
300	H.Failure mLoc failureReason ->
301	H.Failure mLoc $	×
302	case failureReason of	×
303	H.NoReason ->
304	H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) "NoReason"]	×
305	H.Reason msg ->
306	H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [annotate (color Red) (pretty msg)]	×
307	H.ColorizedReason msg ->
308	H.ColorizedReason $ ansiDocToString $ vsep $ header ++ [pretty msg]	×
309	H.ExpectedButGot mPreface expected actual ->
310	H.ExpectedButGot (Just (ansiDocToString $ vsep (header <?> mPreface))) expected actual	×
311	H.Error mInfo excThrown -> uncaughtException (header <?> mInfo) excThrown	×
312	result -> result	×
313	newExc	×
314	\| Just hUnitExc <- fromException exc = fromHUnitFailure [logs] hUnitExc	×
315	\| Just hspecFailure <- fromException exc = adjustFailureReason [logs] hspecFailure	×
316	\| Just (ImpException ann excThrown) <- fromException exc =	×
317	let annLen = length ann	×
318	header =	×
319	logs	×
320	: [ let prefix	×
321	\| annLen <= 1 = "╺╸"	×
322	\| n <= 0 = "┏╸"	×
323	\| n + 1 == annLen = indent (n - 1) "┗━╸"	×
324	\| otherwise = indent (n - 1) "┗┳╸"	×
325	in annotate (color Red) prefix <> annotate (color Yellow) a	×
326	\| (n, a) <- zip [0 ..] ann	×
327	]
328	++ [""]	×
329	in case fromException excThrown of	×
330	Just hUnitExc -> fromHUnitFailure header hUnitExc	×
331	Nothing ->
332	case fromException excThrown of	×
333	Just hspecFailure -> adjustFailureReason header hspecFailure	×
334	Nothing -> H.Failure Nothing $ uncaughtException header excThrown	×
335	\| otherwise = H.Failure Nothing $ uncaughtException [logs] exc	×
336	throwIO newExc	×
337	endState <- readIORef ioRef	2✔
338	pure (res, endState)	1✔
339
340	ansiDocToString :: Doc AnsiStyle -> String
341	ansiDocToString = TL.unpack . renderLazy . layoutPretty defaultLayoutOptions	×
342
343	withImpInit :: ImpSpec t => SpecWith (ImpInit t) -> Spec
344	withImpInit = beforeAll (impInitIO (mkQCGen 2024))	1✔
345
346	modifyImpInit :: (ImpInit t -> ImpInit t) -> SpecWith (ImpInit t) -> SpecWith (ImpInit t)
347	modifyImpInit f = beforeAllWith (pure . f)	×
348
349	-- \| Annotation for when failure happens. All the logging done within annotation will be
350	-- discarded if there no failures within the annotation.
351	impAnn :: NFData a => String -> ImpM t a -> ImpM t a
352	impAnn msg = impAnnDoc (pretty msg)	×
353
354	impAnnDoc :: NFData a => Doc AnsiStyle -> ImpM t a -> ImpM t a
355	impAnnDoc msg m = do	×
356	logs <- getLogs	×
357	res <- catchAnyDeep m $ \exc ->	×
358	throwIO $	×
359	case fromException exc of	×
360	Just (ImpException ann origExc) -> ImpException (msg : ann) origExc	×
361	Nothing -> ImpException [msg] exc	×
362	modifyLogs (const logs)	×
363	pure res	×
364
365	-- \| Adds a source location and Doc to the log, which are only shown if the test fails
366	logWithCallStack :: CallStack -> Doc AnsiStyle -> ImpM t ()
367	logWithCallStack callStack entry =	×
368	modifyLogs (<> stack <> line <> indent 2 entry <> line)	×
369	where
NEW 370	prettySrcLoc' SrcLoc {srcLocModule, srcLocStartLine} =	×
371	hcat	×
372	[ annotate (color c) d	×
373	\| (c, d) <-
374	[ (Yellow, "[")	×
375	, (Blue, pretty srcLocModule)	×
376	, (Yellow, ":")	×
377	, (Magenta, pretty srcLocStartLine)	×
378	, (Yellow, "]")	×
379	]
380	]
381	prefix n = if n <= 0 then "" else indent (n - 1) "└"	×
382	stack =	×
383	vsep	×
384	[prefix n <> prettySrcLoc' loc \| (n, (_, loc)) <- zip [0, 2 ..] . reverse $ getCallStack callStack]	×
385
386	-- \| Adds a Doc to the log, which is only shown if the test fails
387	logDoc :: HasCallStack => Doc AnsiStyle -> ImpM t ()
388	logDoc = logWithCallStack ?callStack	×
389
390	-- \| Adds a Text to the log, which is only shown if the test fails
391	logText :: HasCallStack => Text -> ImpM t ()
392	logText = logWithCallStack ?callStack . pretty	×
393
394	-- \| Adds a String to the log, which is only shown if the test fails
395	logString :: HasCallStack => String -> ImpM t ()
396	logString = logWithCallStack ?callStack . pretty	×

input-output-hk / ImpSpec / 28

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous