{-# 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
  , indexM
  , fromJustM

  , nothingFail
  , nothingFailM
  , leftFail
  , leftFailM

  , onLeft
  , onNothing

  , jsonErrorFail
  , jsonErrorFailM

  , failWithCustom
  , failMessage

  , assertByDeadlineM
  , assertByDeadlineIO
  , assertByDeadlineMFinally
  , assertByDeadlineIOFinally
  , assertWith
  , assertWithM
  , assertM
  , assertIO
  , assertWithinTolerance

  , 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 (ask))
import           Control.Monad.Trans.Resource (ReleaseKey, runResourceT)
import           Data.Aeson (Result (..))
import           Data.Bool (Bool, (&&), otherwise)
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.Semigroup (Semigroup (..))
import           Data.String (String)
import           Data.Time.Clock (NominalDiffTime, UTCTime)
import           Data.Traversable (Traversable)
import           Data.Tuple (snd)
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 (Num (..), Ord (..), floor)
import           System.FilePath ((</>))
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.List as L
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 (Property -> Property)
-> (Integration () -> Property) -> Integration () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
H.property (PropertyT IO () -> Property)
-> (Integration () -> PropertyT IO ())
-> Integration ()
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ResourceT IO a -> IO a)
-> PropertyT (ResourceT IO) () -> PropertyT IO ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> PropertyT m b -> PropertyT n b
hoist ResourceT IO a -> IO a
forall a. ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (PropertyT (ResourceT IO) () -> PropertyT IO ())
-> (Integration () -> PropertyT (ResourceT IO) ())
-> Integration ()
-> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 ReaderT IntegrationState (ResourceT IO) a -> ResourceT IO a)
-> Integration () -> PropertyT (ResourceT IO) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> PropertyT m b -> PropertyT n b
hoist ReaderT IntegrationState (ResourceT IO) a -> ResourceT IO a
forall a.
ReaderT IntegrationState (ResourceT IO) a -> ResourceT IO a
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 = Test a -> m a
forall a. Test a -> m a
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest (Test a -> m a) -> Test a -> m a
forall a b. (a -> b) -> a -> b
$ (Either Failure a, Journal) -> Test a
forall a. (Either Failure a, Journal) -> Test a
mkTest (Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
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, Journal
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 = CallStack -> Maybe Diff -> String -> m a
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cs Maybe Diff
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  String
systemTemp <- IO String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
IO.getCanonicalTemporaryDirectory
  Maybe String
maybeKeepWorkspace <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
IO.lookupEnv String
"KEEP_WORKSPACE"
  String
ws <- IO String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
IO.createTempDirectory String
systemTemp (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
prefixPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-test"
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Workspace: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ws
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
IO.writeFile (String
ws String -> String -> String
</> String
"module") String
HasCallStack => String
callerModuleName
  String -> m ()
f String
ws
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
IO.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"mingw32" Bool -> Bool -> Bool
&& Maybe String
maybeKeepWorkspace Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just String
"1") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO () -> m ()) -> IO () -> m ()
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let srcModule :: String
srcModule = String
-> ((String, SrcLoc) -> String) -> Maybe (String, SrcLoc) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"UnknownModule" (SrcLoc -> String
GHC.srcLocModule (SrcLoc -> String)
-> ((String, SrcLoc) -> SrcLoc) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd) ([(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
GHC.getCallStack CallStack
HasCallStack => CallStack
GHC.callStack))
  String -> (String -> m ()) -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> (String -> m ()) -> m ()
workspace (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> 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 = Log -> m ()
forall (m :: * -> *). MonadTest m => Log -> m ()
H.writeLog (Log -> m ()) -> Log -> m ()
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 = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  !String
b <- String -> m String
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval String
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack String
b
  String -> m String
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
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 = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  !String
b <- m String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m String
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack String
b
  String -> m String
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !String
b <- m String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m String
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack String
b
  () -> m ()
forall a. a -> m a
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 = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  !String
a <- IO String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
f
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack String
a
  String -> m String
forall a. a -> m 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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !String
a <- IO String -> m String
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO String
f
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack String
a
  () -> m ()
forall a. a -> m 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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
  !a
b <- a -> m a
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval a
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
forall a. Show a => a -> String
show a
b)
  a -> m a
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
  !a
b <- m a -> m a
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m a
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
forall a. Show a => a -> String
show a
b)
  a -> m a
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !a
b <- m a -> m a
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM m a
a
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
forall a. Show a => a -> String
show a
b)
  () -> m ()
forall a. a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
  !a
a <- IO a -> m a
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO a
f
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
forall a. Show a => a -> String
show a
a)
  a -> m a
forall a. a -> m 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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !a
a <- IO a -> m a
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO a
f
  CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (a -> String
forall a. Show a => a -> String
show a
a)
  () -> m ()
forall a. a -> m 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 = (HasCallStack => m (f a)) -> m (f a)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (f a)) -> m (f a))
-> (HasCallStack => m (f a)) -> m (f a)
forall a b. (a -> b) -> a -> b
$ do
  f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
  f a -> m (f a)
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 = (HasCallStack => m (f a)) -> m (f a)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (f a)) -> m (f a))
-> (HasCallStack => m (f a)) -> m (f a)
forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- m (f a)
f
  f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
  f a -> m (f a)
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- m (f a)
f
  f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 = (HasCallStack => m (f a)) -> m (f a)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (f a)) -> m (f a))
-> (HasCallStack => m (f a)) -> m (f a)
forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- IO (f a) -> m (f a)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO (f a)
f
  f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
  f a -> m (f a)
forall a. a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  !f a
as <- IO (f a) -> m (f a)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO (f a)
f
  f a -> (a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
as ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m ()
forall (m :: * -> *). MonadTest m => CallStack -> String -> m ()
noteWithCallstack CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  let relPath :: String
relPath = String
tempDir String -> String -> String
</> String
filePath
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate String
relPath
  String -> m String
forall a. a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ case Maybe a
r of
  Just a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Maybe a
Nothing -> CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
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 m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
  Right a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Left e
e -> CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> e -> String
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 m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> m a
forall (m :: * -> *) e a.
(MonadTest m, Show e, HasCallStack) =>
Either e a -> m a
leftFail

maybeAt :: Int -> [a] -> Maybe a
maybeAt :: forall a. Int -> [a] -> Maybe a
maybeAt Int
n [a]
xs
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise = (a -> (Int -> Maybe a) -> Int -> Maybe a)
-> (Int -> Maybe a) -> [a] -> Int -> Maybe a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr a -> (Int -> Maybe a) -> Int -> Maybe a
forall a. a -> (Int -> Maybe a) -> Int -> Maybe a
go (Maybe a -> Int -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) [a]
xs Int
n
      where
        go :: a -> (Int -> Maybe a) -> Int -> Maybe a
        go :: forall a. a -> (Int -> Maybe a) -> Int -> Maybe a
go a
x Int -> Maybe a
r Int
k =
          case Int
k of
            Int
0 -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            Int
_ -> Int -> Maybe a
r (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

indexM :: (MonadTest m, HasCallStack) => Int -> [a] -> m a
indexM :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Int -> [a] -> m a
indexM Int
n [a]
xs =
  case Int -> [a] -> Maybe a
forall a. Int -> [a] -> Maybe a
maybeAt Int
n [a]
xs of
    Just a
x -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Maybe a
Nothing ->
      (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$
        CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Cannot get index " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of list of length " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [a]
xs)

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 m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
h a -> m a
forall a. a -> m a
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 m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
h a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Index into a list.  On failure, a friendly message is included in the test report.
fromJustM :: (MonadTest m, HasCallStack) => Maybe a -> m a
fromJustM :: forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe a -> m a
fromJustM (Just a
a) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
fromJustM Maybe a
Nothing = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ case Result a
r of
  Success a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  Error String
msg -> CallStack -> String -> m a
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
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 m (Result a) -> (Result a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> String -> m a -> m a
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 -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ IO a -> m a
forall a. IO a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
  UTCTime
start <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  a
a <- m a
goM
  UTCTime
end <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Operation completed in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
DTC.diffUTCTime UTCTime
end UTCTime
start)
  a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where goM :: m a
        goM :: m a
goM = m a -> (Failure -> m a) -> m a
forall a. m a -> (Failure -> m a) -> m a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion m a
f ((Failure -> m a) -> m a) -> (Failure -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Failure
e -> do
          UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
          if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
            then do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay (Pico -> Int
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Pico
DTC.nominalDiffTimeToSeconds NominalDiffTime
period Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
1000000))
              m a
goM
            else do
              UTCTime -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
              m Any -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Any -> m ()) -> m Any -> m ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> m Any
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> m Any) -> String -> m Any
forall a b. (a -> b) -> a -> b
$ String
"Condition not met by deadline: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
errorMessage
              Failure -> m a
forall a. Failure -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime -> String -> m a -> m a
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 -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ IO a -> m a
forall a. IO a -> m a
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 = (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$ do
  UTCTime
deadline <- NominalDiffTime -> UTCTime -> UTCTime
DTC.addUTCTime NominalDiffTime
duration (UTCTime -> UTCTime) -> m UTCTime -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
  NominalDiffTime -> UTCTime -> String -> m a -> m a
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
f
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        UTCTime -> IO Bool -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m ()
assertByDeadlineIO UTCTime
deadline IO Bool
f
      else do
        UTCTime -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        CallStack -> String -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- m Bool
f
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        UTCTime -> m Bool -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m ()
assertByDeadlineM UTCTime
deadline m Bool
f
      else do
        UTCTime -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        CallStack -> String -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
f
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        UTCTime -> IO Bool -> m () -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> IO Bool -> m () -> m ()
assertByDeadlineIOFinally UTCTime
deadline IO Bool
f m ()
g
      else do
        UTCTime -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        m ()
g
        CallStack -> String -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
success <- m Bool
f
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
DTC.getCurrentTime
    if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
      then do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
IO.threadDelay Int
1000000
        UTCTime -> m Bool -> m () -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
UTCTime -> m Bool -> m () -> m ()
assertByDeadlineMFinally UTCTime
deadline m Bool
f m ()
g
      else do
        UTCTime -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
H.annotateShow UTCTime
currentTime
        m ()
g
        CallStack -> String -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
"Condition not met by deadline"

-- | Run the test function against the value. Report the value on the failure.
assertWith :: (H.MonadTest m, Show p, HasCallStack) => p -> (p -> Bool) -> m ()
assertWith :: forall (m :: * -> *) p.
(MonadTest m, Show p, HasCallStack) =>
p -> (p -> Bool) -> m ()
assertWith p
v p -> Bool
f = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ p -> (p -> m Bool) -> m ()
forall (m :: * -> *) p.
(MonadTest m, Show p, HasCallStack) =>
p -> (p -> m Bool) -> m ()
assertWithM p
v (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> (p -> Bool) -> p -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Bool
f)

-- | Run the test function against the value. Report the value on the failure.
assertWithM :: (H.MonadTest m, Show p, HasCallStack) => p -> (p -> m Bool) -> m ()
assertWithM :: forall (m :: * -> *) p.
(MonadTest m, Show p, HasCallStack) =>
p -> (p -> m Bool) -> m ()
assertWithM p
v p -> m Bool
f = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
result <- p -> m Bool
f p
v
  if Bool
result
     then m ()
forall (m :: * -> *). MonadTest m => m ()
H.success
     else do
       p -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Show a) =>
a -> m ()
noteShow_ p
v
       Bool -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert Bool
result

-- | 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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ m Bool
f m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> m ()
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 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> m Bool
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO Bool -> IO Bool
forall (m :: * -> *) a. (Monad m, NFData a) => m a -> m a
forceM IO Bool
f) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert

-- | Tests if @|c - v| <= r@
assertWithinTolerance :: (Show a, Ord a, Num a, HasCallStack, H.MonadTest m)
                  => a -- ^ tested value @v@
                  -> a -- ^ expected value @c@
                  -> a -- ^ tolerance range @r@
                  -> m ()
assertWithinTolerance :: forall a (m :: * -> *).
(Show a, Ord a, Num a, HasCallStack, MonadTest m) =>
a -> a -> a -> m ()
assertWithinTolerance a
v a
c a
r = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  a -> (a -> a -> Bool) -> a -> m ()
forall (m :: * -> *) a b.
(MonadTest m, Show a, Show b, HasCallStack) =>
a -> (a -> b -> Bool) -> b -> m ()
H.diff a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) (a
c a -> a -> a
forall a. Num a => a -> a -> a
- a
r)
  a -> (a -> a -> Bool) -> a -> m ()
forall (m :: * -> *) a b.
(MonadTest m, Show a, Show b, HasCallStack) =>
a -> (a -> b -> Bool) -> b -> m ()
H.diff a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) (a
c a -> a -> a
forall a. Num a => a -> a -> a
+ a
r)

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

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

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

  case Either Failure ()
result of
    Right () -> () -> Integration ()
forall a.
a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left Failure
a -> String -> Integration ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ (String -> Integration ()) -> String -> Integration ()
forall a b. (a -> b) -> a -> b
$ String
"Unable to run finally: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Failure -> String
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 <- PropertyT
  (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
-> (Failure
    -> PropertyT
         (ReaderT IntegrationState (ResourceT IO)) (Either Failure a))
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a.
PropertyT (ReaderT IntegrationState (ResourceT IO)) a
-> (Failure
    -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a)
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion ((a -> Either Failure a)
-> Integration a
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a b.
(a -> b)
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either Failure a
forall a b. b -> Either a b
Right Integration a
f) (Either Failure a
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a.
a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a
 -> PropertyT
      (ReaderT IntegrationState (ResourceT IO)) (Either Failure a))
-> (Failure -> Either Failure a)
-> Failure
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Either Failure a
forall a b. a -> Either a b
Left)

  case Either Failure a
result of
    Right a
a -> a -> Integration a
forall a.
a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Left Failure
assertion -> do
      IntegrationState
s <- PropertyT
  (ReaderT IntegrationState (ResourceT IO)) IntegrationState
forall r (m :: * -> *). MonadReader r m => m r
ask
      [Integration ()]
finals <- IO [Integration ()]
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) [Integration ()]
forall a.
IO a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Integration ()]
 -> PropertyT
      (ReaderT IntegrationState (ResourceT IO)) [Integration ()])
-> (STM [Integration ()] -> IO [Integration ()])
-> STM [Integration ()]
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) [Integration ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [Integration ()] -> IO [Integration ()]
forall a. STM a -> IO a
STM.atomically (STM [Integration ()]
 -> PropertyT
      (ReaderT IntegrationState (ResourceT IO)) [Integration ()])
-> STM [Integration ()]
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) [Integration ()]
forall a b. (a -> b) -> a -> b
$ TVar [Integration ()] -> [Integration ()] -> STM [Integration ()]
forall a. TVar a -> a -> STM a
STM.swapTVar (IntegrationState -> TVar [Integration ()]
integrationStateFinals IntegrationState
s) []
      (Integration () -> Integration ())
-> [Integration ()] -> Integration ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Integration () -> Integration ()
reportFinally [Integration ()]
finals
      Failure -> Integration a
forall a.
Failure -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
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
          String -> Integration ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ (String -> Integration ()) -> String -> Integration ()
forall a b. (a -> b) -> a -> b
$ String
"Retry attempt " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
          Either Failure a
result <- PropertyT
  (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
-> (Failure
    -> PropertyT
         (ReaderT IntegrationState (ResourceT IO)) (Either Failure a))
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a.
PropertyT (ReaderT IntegrationState (ResourceT IO)) a
-> (Failure
    -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a)
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion ((a -> Either Failure a)
-> Integration a
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a b.
(a -> b)
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
-> PropertyT (ReaderT IntegrationState (ResourceT IO)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either Failure a
forall a b. b -> Either a b
Right (Int -> Integration a
f Int
i)) (Either Failure a
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall a.
a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a
 -> PropertyT
      (ReaderT IntegrationState (ResourceT IO)) (Either Failure a))
-> (Failure -> Either Failure a)
-> Failure
-> PropertyT
     (ReaderT IntegrationState (ResourceT IO)) (Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Either Failure a
forall a b. a -> Either a b
Left)

          case Either Failure a
result of
            Right a
a -> a -> Integration a
forall a.
a -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
            Left Failure
assertion -> do
              if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
                then Int -> Integration a
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                else do
                  String -> Integration ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
note_ (String -> Integration ()) -> String -> Integration ()
forall a b. (a -> b) -> a -> b
$ String
"All " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" attempts failed"
                  Failure -> Integration a
forall a.
Failure -> PropertyT (ReaderT IntegrationState (ResourceT IO)) a
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 = Int -> (Int -> Integration a) -> Integration a
forall a. Int -> (Int -> Integration a) -> Integration a
retry Int
n (Integration a -> Int -> Integration a
forall a b. a -> b -> a
const Integration a
f)