{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
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
, failWithCustom
, failMessage
, assertByDeadlineM
, assertByDeadlineIO
, assertByDeadlineMFinally
, assertByDeadlineIOFinally
, assertM
, assertIO
, onFailure
, Integration
, release
, runFinallies
) where
import Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Morph (hoist)
import Control.Monad.Reader
import Control.Monad.Trans.Resource (ReleaseKey, runResourceT)
import Data.Bool
import Data.Either (Either (..))
import Data.Eq
import Data.Foldable
import Data.Function (($), (.))
import Data.Maybe (Maybe (..), listToMaybe, maybe)
import Data.Monoid (Monoid (..))
import Data.Ord
import Data.Semigroup (Semigroup (..))
import Data.String (String)
import Data.Time.Clock (UTCTime)
import Data.Traversable
import Data.Tuple
import GHC.Stack (CallStack, HasCallStack)
import Hedgehog (MonadTest)
import Hedgehog.Extras.Internal.Test.Integration
import Hedgehog.Extras.Stock.CallStack
import Hedgehog.Extras.Stock.Monad
import Hedgehog.Internal.Property (Diff, liftTest, mkTest)
import Hedgehog.Internal.Source (getCaller)
import System.IO (FilePath, IO)
import Text.Show
import qualified Control.Concurrent as IO
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.Test.MonadAssertion as H
import qualified Hedgehog.Internal.Property as H
import qualified System.Directory as IO
import qualified System.Info as IO
import qualified System.IO as IO
import qualified System.IO.Temp as IO
propertyOnce :: HasCallStack => Integration () -> H.Property
propertyOnce :: 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
hoist 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
hoist forall a.
ReaderT IntegrationState (ResourceT IO) a -> ResourceT IO a
forall (m :: * -> *) a.
MonadIO m =>
ReaderT IntegrationState m a -> m a
runIntegrationReaderT
failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a
failWithCustom :: CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cs Maybe Diff
mdiff String
msg = 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)
failMessage :: MonadTest m => CallStack -> String -> m a
failMessage :: 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
workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()
workspace :: 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
let systemPrefixPath :: String
systemPrefixPath = String
systemTemp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
prefixPath
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
$ Bool -> String -> IO ()
IO.createDirectoryIfMissing Bool
True String
systemPrefixPath
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
systemPrefixPath 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 (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
forall a. Semigroup a => a -> a -> a
<> 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") (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
$ String -> IO ()
IO.removeDirectoryRecursive String
ws
moduleWorkspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()
moduleWorkspace :: String -> (String -> m ()) -> m ()
moduleWorkspace 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
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
prefixPath 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
noteWithCallstack :: MonadTest m => CallStack -> String -> m ()
noteWithCallstack :: 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
note :: (MonadTest m, HasCallStack) => String -> m String
note :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
b
note_ :: (MonadTest m, HasCallStack) => String -> m ()
note_ :: 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
noteM :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m String
noteM :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
b
noteM_ :: (MonadTest m, MonadCatch m, HasCallStack) => m String -> m ()
noteM_ :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
noteIO :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m String
noteIO :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
a
noteIO_ :: (MonadTest m, MonadIO m, HasCallStack) => IO String -> m ()
noteIO_ :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
noteShow :: (MonadTest m, HasCallStack, Show a) => a -> m a
noteShow :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
b
noteShow_ :: (MonadTest m, HasCallStack, Show a) => a -> m ()
noteShow_ :: 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)
noteShowM :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m a
noteShowM :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
b
noteShowM_ :: (MonadTest m, MonadCatch m, HasCallStack, Show a) => m a -> m ()
noteShowM_ :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
noteShowIO :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m a
noteShowIO :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
a
noteShowIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a) => IO a -> m ()
noteShowIO_ :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
noteEach :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m (f a)
noteEach :: 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 (m :: * -> *) a. Monad m => a -> m a
return f a
as
noteEach_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => f a -> m ()
noteEach_ :: 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
noteEachM :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m (f a)
noteEachM :: 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 (m :: * -> *) a. Monad m => a -> m a
return f a
as
noteEachM_ :: (MonadTest m, HasCallStack, Show a, Traversable f) => m (f a) -> m ()
noteEachM_ :: 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
noteEachIO :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m (f a)
noteEachIO :: 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 (m :: * -> *) a. Monad m => a -> m a
return f a
as
noteEachIO_ :: (MonadTest m, MonadIO m, HasCallStack, Show a, Traversable f) => IO (f a) -> m ()
noteEachIO_ :: 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
noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath
noteTempFile :: 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
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate String
relPath
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
relPath
assertByDeadlineIO :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m ()
assertByDeadlineIO :: 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 (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 (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 (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"
assertByDeadlineM :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m ()
assertByDeadlineM :: 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 (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 (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"
assertByDeadlineIOFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> IO Bool -> m () -> m ()
assertByDeadlineIOFinally :: 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 (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 (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 (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"
assertByDeadlineMFinally :: (MonadTest m, MonadIO m, HasCallStack) => UTCTime -> m Bool -> m () -> m ()
assertByDeadlineMFinally :: 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 (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 (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"
assertM :: (MonadTest m, HasCallStack) => m Bool -> m ()
assertM :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert
assertIO :: (MonadTest m, MonadIO m, HasCallStack) => IO Bool -> m ()
assertIO :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
H.assert
release :: (MonadTest m, MonadIO m) => ReleaseKey -> m ()
release :: ReleaseKey -> m ()
release ReleaseKey
k = 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 (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 (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
H.catchAssertion ((() -> Either Failure ())
-> Integration ()
-> PropertyT
(ReaderT IntegrationState (ResourceT IO)) (Either Failure ())
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 (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 (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 :: 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 (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 (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 (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 (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 (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 (m :: * -> *) a. MonadAssertion m => Failure -> m a
H.throwAssertion Failure
assertion