{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hedgehog.Extras.Test.Base
  ( propertyOnce

  , workspace
  , moduleWorkspace

  , note
  , note_
  , noteM
  , noteM_
  , noteIO
  , noteIO_

  , noteShow
  , noteShow_
  , noteShowM
  , noteShowM_
  , noteShowIO
  , noteShowIO_

  , noteEach
  , noteEach_
  , noteEachM
  , noteEachM_
  , noteEachIO
  , noteEachIO_

  , noteTempFile

  , headM
  , fromJustM

  , nothingFail
  , nothingFailM
  , leftFail
  , leftFailM

  , onLeft
  , onNothing

  , jsonErrorFail
  , jsonErrorFailM

  , failWithCustom
  , failMessage

  , assertByDeadlineM
  , assertByDeadlineIO
  , assertByDeadlineMFinally
  , assertByDeadlineIOFinally
  , assertM
  , assertIO

  , byDeadlineM
  , byDeadlineIO
  , byDurationM
  , byDurationIO

  , onFailure

  , Integration
  , release

  , runFinallies

  , retry
  , retry'
  ) where

import           Control.Applicative (Applicative (..))
import           Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when)
import           Control.Monad.Catch (MonadCatch)
import           Control.Monad.Morph (hoist)
import           Control.Monad.Reader (MonadIO (..), MonadReader (..))
import           Control.Monad.Trans.Resource (ReleaseKey, runResourceT)
import           Data.Aeson (Result (..))
import           Data.Bool (Bool, (&&))
import           Data.Either (Either (..), either)
import           Data.Eq (Eq ((/=)))
import           Data.Foldable (for_)
import           Data.Function (const, ($), (.))
import           Data.Functor ((<$>))
import           Data.Int (Int)
import           Data.Maybe (Maybe (..), listToMaybe, maybe)
import           Data.Monoid (Monoid (..))
import           Data.Ord (Ord (..))
import           Data.Semigroup (Semigroup (..))
import           Data.String (String)
import           Data.Time.Clock (NominalDiffTime, UTCTime)
import           Data.Traversable (Traversable)
import           Data.Tuple (snd)
import           GHC.Num (Num ((*), (+)))
import           GHC.Stack (CallStack, HasCallStack)
import           Hedgehog (MonadTest)
import           Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..))
import           Hedgehog.Extras.Stock.CallStack (callerModuleName)
import           Hedgehog.Extras.Stock.Monad (forceM)
import           Hedgehog.Extras.Test.MonadAssertion (MonadAssertion)
import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)
import           Hedgehog.Internal.Source (getCaller)
import           Prelude (floor)
import           System.IO (FilePath, IO)
import           Text.Show (Show (show))

import qualified Control.Concurrent as IO
import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.Trans.Resource as IO
import qualified Data.Time.Clock as DTC
import qualified GHC.Stack as GHC
import qualified Hedgehog as H
import qualified Hedgehog.Extras.Internal.Test.Integration as H
import qualified Hedgehog.Extras.Test.MonadAssertion as H
import qualified Hedgehog.Internal.Property as H
import qualified System.Directory as IO
import qualified System.Environment as IO
import qualified System.Info as IO
import qualified System.IO as IO
import qualified System.IO.Temp as IO

{- HLINT ignore "Reduce duplication" -}

-- | Run a property with only one test.  This is intended for allowing hedgehog
-- to run unit tests.
propertyOnce :: HasCallStack => Integration () -> H.Property
propertyOnce :: HasCallStack => Integration () -> Property
propertyOnce = TestLimit -> Property -> Property
H.withTests TestLimit
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
H.property forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall (m :: * -> *) a.
MonadIO m =>
ReaderT IntegrationState m a -> m a
H.runIntegrationReaderT

-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.
failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a
failWithCustom :: forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cs Maybe Diff
mdiff String
msg = forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest forall a b. (a -> b) -> a -> b
$ forall a. (Either Failure a, Journal) -> Test a
mkTest (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe Span -> String -> Maybe Diff -> Failure
H.Failure (CallStack -> Maybe Span
getCaller CallStack
cs) String
msg Maybe Diff
mdiff, forall a. Monoid a => a
mempty)

-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.
failMessage :: MonadTest m => CallStack -> String -> m a
failMessage :: forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
cs = forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cs forall a. Maybe a
Nothing

-- | Create a workspace directory which will exist for at least the duration of
-- the supplied block.
--
-- The directory will have the supplied prefix but contain a generated random
-- suffix to prevent interference between tests
--
-- The directory will be deleted if the block succeeds, but left behind if
-- the block fails.
workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()
workspace :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> (String -> m ()) -> m ()
workspace String
prefixPath String -> m ()
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  String
systemTemp <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
IO.getCanonicalTemporaryDirectory
  Maybe String
maybeKeepWorkspace <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
IO.lookupEnv String
"KEEP_WORKSPACE"
  String
ws <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
IO.createTempDirectory String
systemTemp forall a b. (a -> b) -> a -> b
$ String
prefixPath forall a. Semigroup a => a -> a -> a
<> String
"-test"
  forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate forall a b. (a -> b) -> a -> b
$ String
"Workspace: " forall a. Semigroup a => a -> a -> a
<> String
ws
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
IO.writeFile (String
ws forall a. Semigroup a => a -> a -> a
<> String
"/module") HasCallStack => String
callerModuleName
  String -> m ()
f String
ws
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
IO.os forall a. Eq a => a -> a -> Bool
/= String
"mingw32" Bool -> Bool -> Bool
&& Maybe String
maybeKeepWorkspace forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just String
"1") forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
IO.removeDirectoryRecursive String
ws

-- | Create a workspace directory which will exist for at least the duration of
-- the supplied block.
--
-- The directory will have the prefix as "$prefixPath/$moduleName" but contain a generated random
-- suffix to prevent interference between tests
--
-- The directory will be deleted if the block succeeds, but left behind if
-- the block fails.
--
-- The 'prefix' argument should not contain directory delimeters.
moduleWorkspace :: (MonadTest m, MonadIO m, HasCallStack) => String -> (FilePath -> m ()) -> m ()
moduleWorkspace :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> (String -> m ()) -> m ()
moduleWorkspace String
prefix String -> m ()
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  let srcModule :: String
srcModule = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"UnknownModule" (SrcLoc -> String
GHC.srcLocModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
GHC.getCallStack HasCallStack => CallStack
GHC.callStack))
  forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> (String -> m ()) -> m ()
workspace (String
prefix forall a. Semigroup a => a -> a -> a
<> String
"-" forall a. Semigroup a => a -> a -> a
<> String
srcModule) String -> m ()
f

-- | Annotate the given string at the context supplied by the callstack.
noteWithCallstack :: MonadTest m => CallStack -> String -> m ()
noteWithCallstack :: forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
cs String
a = forall (m :: * -> *). MonadTest m => Log -> m ()
H.writeLog forall a b. (a -> b) -> a -> b
$ Maybe Span -> String -> Log
H.Annotation (CallStack -> Maybe Span
getCaller CallStack
cs) String
a

-- | Annotate with the given string.
note :: (MonadTest m, HasCallStack) => String -> m String
note :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
String -> m String
note String
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !String
b <- forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval String
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
b
  forall (m :: * -> *) a. Monad m => a -> m a
return String
b

-- | Annotate the given string returning unit.
note_ :: (MonadTest m, HasCallStack) => String -> m ()
note_ :: forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ String
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
a

-- | Annotate the given string in a monadic context.
noteM :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m String
noteM :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, HasCallStack) =>
m String -> m String
noteM m String
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !String
b <- forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m String
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
b
  forall (m :: * -> *) a. Monad m => a -> m a
return String
b

-- | Annotate the given string in a monadic context returning unit.
noteM_ :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m ()
noteM_ :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, HasCallStack) =>
m String -> m ()
noteM_ m String
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !String
b <- forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m String
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
b
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Annotate the given string in IO.
noteIO :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m String
noteIO :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
IO String -> m String
noteIO IO String
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !String
a <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
f
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
a
  forall (m :: * -> *) a. Monad m => a -> m a
return String
a

-- | Annotate the given string in IO returning unit.
noteIO_ :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m ()
noteIO_ :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
IO String -> m ()
noteIO_ IO String
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !String
a <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
f
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack String
a
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Annotate the given value.
noteShow :: (MonadTest m, HasCallStack, Show a) => a -> m a
noteShow :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Show a) =>
a -> m a
noteShow a
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !a
b <- forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval a
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
b)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
b

-- | Annotate the given value returning unit.
noteShow_ :: (MonadTest m, HasCallStack, Show a) => a -> m ()
noteShow_ :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Show a) =>
a -> m ()
noteShow_ a
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
a)

-- | Annotate the given value in a monadic context.
noteShowM :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m a
noteShowM :: forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack, Show a) =>
m a -> m a
noteShowM m a
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !a
b <- forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m a
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
b)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
b

-- | Annotate the given value in a monadic context returning unit.
noteShowM_ :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m ()
noteShowM_ :: forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack, Show a) =>
m a -> m ()
noteShowM_ m a
a = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !a
b <- forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m a
a
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
b)
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Annotate the given value in IO.
noteShowIO :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m a
noteShowIO :: forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack, Show a) =>
IO a -> m a
noteShowIO IO a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !a
a <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO a
f
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
a)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Annotate the given value in IO returning unit.
noteShowIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m ()
noteShowIO_ :: forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack, Show a) =>
IO a -> m ()
noteShowIO_ IO a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !a
a <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO a
f
  forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack (forall a. Show a => a -> String
show a
a)
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Annotate the each value in the given traversable.
noteEach :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m (f a)
noteEach :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Show a, Traversable f) =>
f a -> m (f a)
noteEach f a
as = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  forall (m :: * -> *) a. Monad m => a -> m a
return f a
as

-- | Annotate the each value in the given traversable returning unit.
noteEach_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m ()
noteEach_ :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Show a, Traversable f) =>
f a -> m ()
noteEach_ f a
as = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Annotate the each value in the given traversable in a monadic context.
noteEachM :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m (f a)
noteEachM :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Show a, Traversable f) =>
m (f a) -> m (f a)
noteEachM m (f a)
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- m (f a)
f
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  forall (m :: * -> *) a. Monad m => a -> m a
return f a
as

-- | Annotate the each value in the given traversable in a monadic context returning unit.
noteEachM_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m ()
noteEachM_ :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Show a, Traversable f) =>
m (f a) -> m ()
noteEachM_ m (f a)
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- m (f a)
f
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Annotate the each value in the given traversable in IO.
noteEachIO :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m (f a)
noteEachIO :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) =>
IO (f a) -> m (f a)
noteEachIO IO (f a)
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO (f a)
f
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  forall (m :: * -> *) a. Monad m => a -> m a
return f a
as

-- | Annotate the each value in the given traversable in IO returning unit.
noteEachIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m ()
noteEachIO_ :: forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) =>
IO (f a) -> m ()
noteEachIO_ IO (f a)
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO (f a)
f
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack HasCallStack => CallStack
GHC.callStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Return the test file path after annotating it relative to the project root directory
noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath
noteTempFile :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
String -> String -> m String
noteTempFile String
tempDir String
filePath = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  let relPath :: String
relPath = String
tempDir forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> String
filePath
  forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate String
relPath
  forall (m :: * -> *) a. Monad m => a -> m a
return String
relPath

-- | Fail when the result is Nothing.
nothingFail :: (MonadTest m, HasCallStack) => Maybe a -> m a
nothingFail :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe a -> m a
nothingFail Maybe a
r = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ case Maybe a
r of
  Just a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Maybe a
Nothing -> forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Expected Just"

-- | Fail when the computed result is Nothing.
nothingFailM :: (MonadTest m, HasCallStack) => m (Maybe a) -> m a
nothingFailM :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
m (Maybe a) -> m a
nothingFailM m (Maybe a)
f = m (Maybe a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe a -> m a
nothingFail

-- | Fail when the result is Left.
leftFail :: (MonadTest m, Show e, HasCallStack) => Either e a -> m a
leftFail :: forall (m :: * -> *) e a.
(MonadTest m, Show e, HasCallStack) =>
Either e a -> m a
leftFail Either e a
r = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ case Either e a
r of
  Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Left e
e -> forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show e
e)

-- | Fail when the computed result is Left.
leftFailM :: (MonadTest m, Show e, HasCallStack) => m (Either e a) -> m a
leftFailM :: forall (m :: * -> *) e a.
(MonadTest m, Show e, HasCallStack) =>
m (Either e a) -> m a
leftFailM m (Either e a)
f = m (Either e a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) e a.
(MonadTest m, Show e, HasCallStack) =>
Either e a -> m a
leftFail

headM :: (MonadTest m, HasCallStack) => [a] -> m a
headM :: forall (m :: * -> *) a. (MonadTest m, HasCallStack) => [a] -> m a
headM (a
a:[a]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
headM [] = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Cannot take head of empty list"

onLeft :: Monad m => (e -> m a) -> m (Either e a) -> m a
onLeft :: forall (m :: * -> *) e a.
Monad m =>
(e -> m a) -> m (Either e a) -> m a
onLeft e -> m a
h m (Either e a)
f = m (Either e a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
h forall (f :: * -> *) a. Applicative f => a -> f a
pure

onNothing :: Monad m => m a -> m (Maybe a) -> m a
onNothing :: forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothing m a
h m (Maybe a)
f = m (Maybe a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
h forall (f :: * -> *) a. Applicative f => a -> f a
pure

fromJustM :: (MonadTest m, HasCallStack) => Maybe a -> m a
fromJustM :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe a -> m a
fromJustM (Just a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
fromJustM Maybe a
Nothing = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Cannot take head of empty list"

-- | Fail when the result is Error.
jsonErrorFail :: (MonadTest m, HasCallStack) => Result a -> m a
jsonErrorFail :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Result a -> m a
jsonErrorFail Result a
r = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ case Result a
r of
  Success a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Error String
msg -> forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " forall a. Semigroup a => a -> a -> a
<> String
msg)

-- | Fail when the computed result is Error.
jsonErrorFailM :: (MonadTest m, HasCallStack) => m (Result a) -> m a
jsonErrorFailM :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
m (Result a) -> m a
jsonErrorFailM m (Result a)
f = m (Result a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Result a -> m a
jsonErrorFail

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- Expiration of the deadline results in an assertion failure
byDeadlineIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> IO a -> m a
byDeadlineIO :: forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> UTCTime -> String -> IO a -> m a
byDeadlineIO NominalDiffTime
period UTCTime
deadline String
errorMessage IO a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> UTCTime -> String -> m a -> m a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
f

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- Expiration of the deadline results in an assertion failure
byDeadlineM :: forall m a. (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> UTCTime -> String -> m a -> m a
byDeadlineM :: forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> UTCTime -> String -> m a -> m a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage m a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  UTCTime
start <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  a
a <- m a
goM
  UTCTime
end <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ forall a b. (a -> b) -> a -> b
$ String
"Operation completed in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
DTC.diffUTCTime UTCTime
end UTCTime
start)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where goM :: m a
        goM :: m a
goM = forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion m a
f forall a b. (a -> b) -> a -> b
$ \Failure
e -> do
          UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
          if UTCTime
currentTime forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
            then do
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay (forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Pico
DTC.nominalDiffTimeToSeconds NominalDiffTime
period forall a. Num a => a -> a -> a
* Pico
1000000))
              m a
goM
            else do
              forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
              forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack forall a b. (a -> b) -> a -> b
$ String
"Condition not met by deadline: " forall a. Semigroup a => a -> a -> a
<> String
errorMessage
              forall (m :: * -> *) a. MonadAssertion m => Failure -> m a
H.throwAssertion Failure
e

-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.
--
-- Expiration of the duration results in an assertion failure
byDurationIO :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> IO a -> m a
byDurationIO :: forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> NominalDiffTime -> String -> IO a -> m a
byDurationIO NominalDiffTime
period NominalDiffTime
duration String
errorMessage IO a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> NominalDiffTime -> String -> m a -> m a
byDurationM NominalDiffTime
period NominalDiffTime
duration String
errorMessage forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
f

-- | Run the operation 'f' once a second until it returns 'True' or the duration expires.
--
-- Expiration of the duration results in an assertion failure
byDurationM :: (MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) => NominalDiffTime -> NominalDiffTime -> String -> m a -> m a
byDurationM :: forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> NominalDiffTime -> String -> m a -> m a
byDurationM NominalDiffTime
period NominalDiffTime
duration String
errorMessage m a
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  UTCTime
deadline <- NominalDiffTime -> UTCTime -> UTCTime
DTC.addUTCTime NominalDiffTime
duration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  forall (m :: * -> *) a.
(MonadAssertion m, MonadTest m, MonadIO m, HasCallStack) =>
NominalDiffTime -> UTCTime -> String -> m a -> m a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage m a
f

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- Expiration of the deadline results in an assertion failure
assertByDeadlineIO :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m ()
assertByDeadlineIO :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m ()
assertByDeadlineIO UTCTime
deadline IO Bool
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m ()
assertByDeadlineIO UTCTime
deadline IO Bool
f
      else do
        forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Condition not met by deadline"

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- Expiration of the deadline results in an assertion failure
assertByDeadlineM :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m ()
assertByDeadlineM :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m ()
assertByDeadlineM UTCTime
deadline m Bool
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- m Bool
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m ()
assertByDeadlineM UTCTime
deadline m Bool
f
      else do
        forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Condition not met by deadline"

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- The action 'g' is run after expiration of the deadline, but before failure allowing for
-- additional annotations to be presented.
--
-- Expiration of the deadline results in an assertion failure
assertByDeadlineIOFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m () -> m ()
assertByDeadlineIOFinally :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m () -> m ()
assertByDeadlineIOFinally UTCTime
deadline IO Bool
f m ()
g = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m () -> m ()
assertByDeadlineIOFinally UTCTime
deadline IO Bool
f m ()
g
      else do
        forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        m ()
g
        forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Condition not met by deadline"

-- | Run the operation 'f' once a second until it returns 'True' or the deadline expires.
--
-- The action 'g' is run after expiration of the deadline, but before failure allowing for
-- additional annotations to be presented.
--
-- Expiration of the deadline results in an assertion failure
assertByDeadlineMFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m () -> m ()
assertByDeadlineMFinally :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m () -> m ()
assertByDeadlineMFinally UTCTime
deadline m Bool
f m ()
g = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- m Bool
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m () -> m ()
assertByDeadlineMFinally UTCTime
deadline m Bool
f m ()
g
      else do
        forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        m ()
g
        forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage HasCallStack => CallStack
GHC.callStack String
"Condition not met by deadline"

-- | Run the monadic action 'f' and assert the return value is 'True'.
assertM :: (MonadTest m, HasCallStack) => m Bool -> m ()
assertM :: forall (m :: * -> *). (MonadTest m, HasCallStack) => m Bool -> m ()
assertM m Bool
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ m Bool
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert

-- | Run the IO action 'f' and assert the return value is 'True'.
assertIO :: (MonadTest m, MonadIO m, HasCallStack) => IO Bool -> m ()
assertIO :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
IO Bool -> m ()
assertIO IO Bool
f = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (forall (m :: * -> *) a. (Monad m, NFData a) => m a -> m a
forceM IO Bool
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert

-- | Release the given release key.
release :: (MonadTest m, MonadIO m) => ReleaseKey -> m ()
release :: forall (m :: * -> *).
(MonadTest m, MonadIO m) =>
ReleaseKey -> m ()
release ReleaseKey
k = forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
IO.release ReleaseKey
k

onFailure :: Integration () -> Integration ()
onFailure :: Integration () -> Integration ()
onFailure Integration ()
f = do
  IntegrationState
s <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar (IntegrationState -> TVar [Integration ()]
integrationStateFinals IntegrationState
s) (Integration ()
fforall a. a -> [a] -> [a]
:)

reportFinally :: Integration () -> Integration ()
reportFinally :: Integration () -> Integration ()
reportFinally Integration ()
f = do
  Either Failure ()
result <- forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right Integration ()
f) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

  case Either Failure ()
result of
    Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left Failure
a -> forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ forall a b. (a -> b) -> a -> b
$ String
"Unable to run finally: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Failure
a

runFinallies :: Integration a -> Integration a
runFinallies :: forall a. Integration a -> Integration a
runFinallies Integration a
f = do
  Either Failure a
result <- forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right Integration a
f) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

  case Either Failure a
result of
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Failure
assertion -> do
      IntegrationState
s <- forall r (m :: * -> *). MonadReader r m => m r
ask
      [Integration ()]
finals <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM a
STM.swapTVar (IntegrationState -> TVar [Integration ()]
integrationStateFinals IntegrationState
s) []
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Integration () -> Integration ()
reportFinally [Integration ()]
finals
      forall (m :: * -> *) a. MonadAssertion m => Failure -> m a
H.throwAssertion Failure
assertion

retry :: forall a. Int -> (Int -> Integration a) -> Integration a
retry :: forall a. Int -> (Int -> Integration a) -> Integration a
retry Int
n Int -> Integration a
f = Int -> Integration a
go Int
0
  where go :: Int -> Integration a
        go :: Int -> Integration a
go Int
i = do
          forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ forall a b. (a -> b) -> a -> b
$ String
"Retry attempt " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i forall a. Semigroup a => a -> a -> a
<> String
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n
          Either Failure a
result <- forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (Int -> Integration a
f Int
i)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

          case Either Failure a
result of
            Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
            Left Failure
assertion -> do
              if Int
i forall a. Ord a => a -> a -> Bool
< Int
n
                then Int -> Integration a
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
                else do
                  forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ forall a b. (a -> b) -> a -> b
$ String
"All " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n forall a. Semigroup a => a -> a -> a
<> String
" attempts failed"
                  forall (m :: * -> *) a. MonadAssertion m => Failure -> m a
H.throwAssertion Failure
assertion

retry' :: forall a. Int -> Integration a -> Integration a
retry' :: forall a. Int -> Integration a -> Integration a
retry' Int
n Integration a
f = forall a. Int -> (Int -> Integration a) -> Integration a
retry Int
n (forall a b. a -> b -> a
const Integration a
f)