module HaskellWorks.Polysemy.Hedgehog.Assert
( Hedgehog,
leftFail,
leftFailM,
leftFailJson,
leftFailJsonM,
leftFailJsonPretty,
leftFailJsonPrettyM,
leftFailPretty,
leftFailPrettyM,
leftFailYaml,
leftFailYamlM,
nothingFail,
nothingFailM,
requireHead,
catchFail,
trapFail,
trapFailJson,
trapFailJsonPretty,
trapFailYaml,
evalIO,
failure,
failMessage,
failMessageText,
byDeadlineIO,
byDeadlineM,
byDurationIO,
byDurationM,
(===),
assertPidOk,
assertIsJsonFile_,
assertIsYamlFile,
assertFileExists,
assertFilesExist,
assertFileMissing,
assertFilesMissing,
assertFileOccurences,
assertFileLines,
assertEndsWithSingleNewline,
assertDirectoryExists,
assertDirectoryMissing,
) where
import qualified Control.Concurrent as IO
import Data.Aeson (ToJSON, Value)
import qualified Data.Aeson as J
import qualified Data.Aeson.Encode.Pretty as J
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Time.Clock (NominalDiffTime,
UTCTime)
import qualified Data.Time.Clock as DTC
import qualified Data.Yaml as Y
import qualified GHC.Stack as GHC
import HaskellWorks.Polysemy.Error
import HaskellWorks.Polysemy.File
import HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog
import HaskellWorks.Polysemy.Hedgehog.Jot
import HaskellWorks.Polysemy.Prelude
import HaskellWorks.Polysemy.System.Directory
import Prettyprinter (Pretty)
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.String as PP
import Control.Monad.IO.Class (MonadIO (..))
import HaskellWorks.Polysemy.System.IO as IO
import HaskellWorks.Polysemy.System.Process
import Polysemy
import Polysemy.Error
import Polysemy.Log
import qualified System.IO as IOIO
(===) :: forall a r. ()
=> Member Hedgehog r
=> Eq a
=> Show a
=> HasCallStack
=> a
-> a
-> Sem r ()
=== :: forall a (r :: EffectRow).
(Member Hedgehog r, Eq a, Show a, HasCallStack) =>
a -> a -> Sem r ()
(===) a
a a
b = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ a -> a -> Sem r ()
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack, Eq a, Show a) =>
a -> a -> Sem r ()
assertEquals a
a a
b
leftFail :: forall e a r. ()
=> Member Hedgehog r
=> Show e
=> HasCallStack
=> Either e a
-> Sem r a
leftFail :: forall e a (r :: EffectRow).
(Member Hedgehog r, Show e, HasCallStack) =>
Either e a -> Sem r a
leftFail Either e a
r = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r 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)
nothingFail :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> Maybe a
-> Sem r a
nothingFail :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
Maybe a -> Sem r a
nothingFail Maybe a
r = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Maybe a
r of
Just a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing -> CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
"Expected Just"
failure :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> Sem r a
failure :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
Sem r a
failure =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Maybe Diff -> String -> Sem r a
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
Maybe Diff -> String -> Sem r a
failWith Maybe Diff
forall a. Maybe a
Nothing String
""
failMessage :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> GHC.CallStack
-> String
-> Sem r a
failMessage :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
cs =
(HasCallStack => String -> Sem r a) -> String -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> Sem r a) -> String -> Sem r a)
-> (HasCallStack => String -> Sem r a) -> String -> Sem r a
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> Sem r a
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
cs Maybe Diff
forall a. Maybe a
Nothing
failMessageText :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> GHC.CallStack
-> Text
-> Sem r a
failMessageText :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> Text -> Sem r a
failMessageText CallStack
cs =
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
cs (String -> Sem r a) -> (Text -> String) -> Text -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
leftFailM :: forall e a r. ()
=> Member Hedgehog r
=> Show e
=> HasCallStack
=> Sem r (Either e a)
-> Sem r a
leftFailM :: forall e a (r :: EffectRow).
(Member Hedgehog r, Show e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailM Sem r (Either e a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Either e a)
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, Show e, HasCallStack) =>
Either e a -> Sem r a
leftFail
leftFailJson :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Either e a
-> Sem r a
leftFailJson :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailJson Either e a
r = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
LT.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
leftFailJsonM :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Sem r (Either e a)
-> Sem r a
leftFailJsonM :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailJsonM Sem r (Either e a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Either e a)
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailJson
leftFailPretty :: forall e a r. ()
=> Member Hedgehog r
=> Pretty e
=> HasCallStack
=> Either e a
-> Sem r a
leftFailPretty :: forall e a (r :: EffectRow).
(Member Hedgehog r, Pretty e, HasCallStack) =>
Either e a -> Sem r a
leftFailPretty Either e a
r =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (SimpleDocStream Any -> String) -> SimpleDocStream Any -> String
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
PP.defaultLayoutOptions (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ e -> Doc Any
forall ann. e -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
leftFailPrettyM :: forall e a r. ()
=> Member Hedgehog r
=> Pretty e
=> HasCallStack
=> Sem r (Either e a)
-> Sem r a
leftFailPrettyM :: forall e a (r :: EffectRow).
(Member Hedgehog r, Pretty e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailPrettyM Sem r (Either e a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Either e a)
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, Pretty e, HasCallStack) =>
Either e a -> Sem r a
leftFailPretty
leftFailJsonPretty :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Either e a
-> Sem r a
leftFailJsonPretty :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailJsonPretty Either e a
r = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
LT.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
J.encodePretty e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
leftFailJsonPrettyM :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Sem r (Either e a)
-> Sem r a
leftFailJsonPrettyM :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailJsonPrettyM Sem r (Either e a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Either e a)
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailJsonPretty
leftFailYaml :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Either e a
-> Sem r a
leftFailYaml :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailYaml Either e a
r = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
Y.encode e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
"Expected Right: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
leftFailYamlM :: forall e a r. ()
=> Member Hedgehog r
=> ToJSON e
=> HasCallStack
=> Sem r (Either e a)
-> Sem r a
leftFailYamlM :: forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailYamlM Sem r (Either e a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Either e a)
f Sem r (Either e a) -> (Either e a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, ToJSON e, HasCallStack) =>
Either e a -> Sem r a
leftFailYaml
nothingFailM :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> Sem r (Maybe a)
-> Sem r a
nothingFailM :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
Sem r (Maybe a) -> Sem r a
nothingFailM Sem r (Maybe a)
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r (Maybe a)
f Sem r (Maybe a) -> (Maybe a -> Sem r a) -> Sem r a
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
Maybe a -> Sem r a
nothingFail
catchFail :: forall e a r. ()
=> Member Hedgehog r
=> HasCallStack
=> Show e
=> Sem (Error e ': r) a
-> Sem r a
catchFail :: forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, Show e) =>
Sem (Error e : r) a -> Sem r a
catchFail Sem (Error e : r) a
f =
(HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem (Error e : r) a
f Sem (Error e : r) a
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem r (Either e a)
forall a b. a -> (a -> b) -> b
& Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem r (Either e a) -> (Sem r (Either e a) -> Sem r a) -> Sem r a
forall a b. a -> (a -> b) -> b
& Sem r (Either e a) -> Sem r a
forall e a (r :: EffectRow).
(Member Hedgehog r, Show e, HasCallStack) =>
Sem r (Either e a) -> Sem r a
leftFailM
{-# DEPRECATED catchFail "Use trapFail instead" #-}
trapFail :: forall e a r. ()
=> Member Hedgehog r
=> HasCallStack
=> Show e
=> Sem (Error e ': r) a
-> Sem r a
trapFail :: forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, Show e) =>
Sem (Error e : r) a -> Sem r a
trapFail Sem (Error e : r) a
f = do
Either e a
r <- (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (Either e a)) -> Sem r (Either e a))
-> (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a b. (a -> b) -> a -> b
$ Sem (Error e : r) a
f Sem (Error e : r) a
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem r (Either e a)
forall a b. a -> (a -> b) -> b
& Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem r a) -> String -> Sem r a
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e
trapFailJson :: forall e a r. ()
=> Member Hedgehog r
=> HasCallStack
=> ToJSON e
=> Sem (Error e ': r) a
-> Sem r a
trapFailJson :: forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, ToJSON e) =>
Sem (Error e : r) a -> Sem r a
trapFailJson Sem (Error e : r) a
f = do
Either e a
r <- (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (Either e a)) -> Sem r (Either e a))
-> (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a b. (a -> b) -> a -> b
$ Sem (Error e : r) a
f Sem (Error e : r) a
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem r (Either e a)
forall a b. a -> (a -> b) -> b
& Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
LT.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
msg
trapFailJsonPretty :: forall e a r. ()
=> Member Hedgehog r
=> HasCallStack
=> ToJSON e
=> Sem (Error e ': r) a
-> Sem r a
trapFailJsonPretty :: forall e a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, ToJSON e) =>
Sem (Error e : r) a -> Sem r a
trapFailJsonPretty Sem (Error e : r) a
f = do
Either e a
r <- (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (Either e a)) -> Sem r (Either e a))
-> (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a b. (a -> b) -> a -> b
$ Sem (Error e : r) a
f Sem (Error e : r) a
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem r (Either e a)
forall a b. a -> (a -> b) -> b
& Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
LT.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
J.encodePretty e
e
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
msg
trapFailYaml :: forall e a r m. ()
=> MonadIO m
=> Member (Embed m) r
=> Member Hedgehog r
=> HasCallStack
=> ToJSON e
=> Sem (Error e ': r) a
-> Sem r a
trapFailYaml :: forall e a (r :: EffectRow) (m :: * -> *).
(MonadIO m, Member (Embed m) r, Member Hedgehog r, HasCallStack,
ToJSON e) =>
Sem (Error e : r) a -> Sem r a
trapFailYaml Sem (Error e : r) a
f = do
Either e a
r <- (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r (Either e a)) -> Sem r (Either e a))
-> (HasCallStack => Sem r (Either e a)) -> Sem r (Either e a)
forall a b. (a -> b) -> a -> b
$ Sem (Error e : r) a
f Sem (Error e : r) a
-> (Sem (Error e : r) a -> Sem r (Either e a))
-> Sem r (Either e a)
forall a b. a -> (a -> b) -> b
& Sem (Error e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
case Either e a
r of
Right a
a -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left e
e -> do
let msg :: String
msg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ e -> ByteString
forall a. ToJSON a => a -> ByteString
Y.encode e
e
m () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (m () -> Sem r ()) -> m () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ 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 -> IO ()
IOIO.putStrLn String
msg
CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
msg
requireHead :: forall a r. ()
=> Member Hedgehog r
=> HasCallStack
=> [a]
-> Sem r a
requireHead :: forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
[a] -> Sem r a
requireHead = (HasCallStack => [a] -> Sem r a) -> [a] -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => [a] -> Sem r a) -> [a] -> Sem r a)
-> (HasCallStack => [a] -> Sem r a) -> [a] -> Sem r a
forall a b. (a -> b) -> a -> b
$
\case
[] -> CallStack -> String -> Sem r a
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack String
"Cannot take head of empty list"
(a
x:[a]
_) -> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
assertPidOk :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member (Error IOException) r
=> ProcessHandle
-> Sem r Pid
assertPidOk :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member (Error IOException) r) =>
ProcessHandle -> Sem r Pid
assertPidOk ProcessHandle
hProcess = (HasCallStack => Sem r Pid) -> Sem r Pid
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r Pid) -> Sem r Pid)
-> (HasCallStack => Sem r Pid) -> Sem r Pid
forall a b. (a -> b) -> a -> b
$
Sem r (Maybe Pid) -> Sem r Pid
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
Sem r (Maybe a) -> Sem r a
nothingFailM (Sem r (Maybe Pid) -> Sem r Pid) -> Sem r (Maybe Pid) -> Sem r Pid
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> Sem r (Maybe Pid)
forall (r :: EffectRow).
(Member (Embed IO) r, Member (Error IOException) r) =>
ProcessHandle -> Sem r (Maybe Pid)
getPid ProcessHandle
hProcess
assertIsJsonFile_ :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertIsJsonFile_ :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertIsJsonFile_ String
fp = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Sem (Error IOException : Error JsonDecodeError : r) Value
-> Sem (Error IOException : Error JsonDecodeError : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a (r :: EffectRow).
(FromJSON a, HasCallStack, Member (Error IOException) r,
Member (Error JsonDecodeError) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r a
readJsonFile @Value String
fp)
Sem (Error IOException : Error JsonDecodeError : r) ()
-> (Sem (Error IOException : Error JsonDecodeError : r) ()
-> Sem (Error JsonDecodeError : r) ())
-> Sem (Error JsonDecodeError : r) ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (CallStack -> String -> Sem (Error JsonDecodeError : r) ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem (Error JsonDecodeError : r) ())
-> (IOException -> String)
-> IOException
-> Sem (Error JsonDecodeError : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show)
Sem (Error JsonDecodeError : r) ()
-> (Sem (Error JsonDecodeError : r) () -> Sem r ()) -> Sem r ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @JsonDecodeError (\JsonDecodeError
e -> CallStack -> Text -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> Text -> Sem r a
failMessageText CallStack
HasCallStack => CallStack
GHC.callStack JsonDecodeError
e.message)
assertIsYamlFile :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertIsYamlFile :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertIsYamlFile String
fp = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Sem
(Error IOException
: Error JsonDecodeError : Error YamlDecodeError : r)
Value
-> Sem
(Error IOException
: Error JsonDecodeError : Error YamlDecodeError : r)
()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a (r :: EffectRow).
(FromJSON a, HasCallStack, Member (Error IOException) r,
Member (Error JsonDecodeError) r, Member (Error YamlDecodeError) r,
Member (Embed IO) r, Member Log r) =>
String -> Sem r a
readYamlFile @Value String
fp)
Sem
(Error IOException
: Error JsonDecodeError : Error YamlDecodeError : r)
()
-> (Sem
(Error IOException
: Error JsonDecodeError : Error YamlDecodeError : r)
()
-> Sem (Error JsonDecodeError : Error YamlDecodeError : r) ())
-> Sem (Error JsonDecodeError : Error YamlDecodeError : r) ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (CallStack
-> String
-> Sem (Error JsonDecodeError : Error YamlDecodeError : r) ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String
-> Sem (Error JsonDecodeError : Error YamlDecodeError : r) ())
-> (IOException -> String)
-> IOException
-> Sem (Error JsonDecodeError : Error YamlDecodeError : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show)
Sem (Error JsonDecodeError : Error YamlDecodeError : r) ()
-> (Sem (Error JsonDecodeError : Error YamlDecodeError : r) ()
-> Sem (Error YamlDecodeError : r) ())
-> Sem (Error YamlDecodeError : r) ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @JsonDecodeError (\JsonDecodeError
e -> CallStack -> Text -> Sem (Error YamlDecodeError : r) ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> Text -> Sem r a
failMessageText CallStack
HasCallStack => CallStack
GHC.callStack JsonDecodeError
e.message)
Sem (Error YamlDecodeError : r) ()
-> (Sem (Error YamlDecodeError : r) () -> Sem r ()) -> Sem r ()
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @YamlDecodeError (\YamlDecodeError
e -> CallStack -> Text -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> Text -> Sem r a
failMessageText CallStack
HasCallStack => CallStack
GHC.callStack YamlDecodeError
e.message)
assertFileExists :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertFileExists :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertFileExists String
file = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- String -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r Bool
doesFileExist String
file
Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (Sem r Bool -> IOException -> Sem r Bool
forall a b. a -> b -> a
const (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False))
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has not been successfully created.")
assertFilesExist :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> [FilePath]
-> Sem r ()
assertFilesExist :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
[String] -> Sem r ()
assertFilesExist [String]
files =
(HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
files String -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertFileExists
assertFileMissing :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertFileMissing :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertFileMissing String
file = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- String -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r Bool
doesFileExist String
file
Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (Sem r Bool -> IOException -> Sem r Bool
forall a b. a -> b -> a
const (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False))
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" should not have been created.")
assertFilesMissing :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> [FilePath]
-> Sem r ()
assertFilesMissing :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
[String] -> Sem r ()
assertFilesMissing [String]
files =
(HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [String]
files String -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertFileMissing
assertFileOccurences :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> Int
-> String
-> FilePath
-> Sem r ()
assertFileOccurences :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
Int -> String -> String -> Sem r ()
assertFileOccurences Int
n String
s String
fp = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
String
contents <- String -> Sem (Error IOException : r) String
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r String
readFile String
fp
Sem (Error IOException : r) String
-> (Sem (Error IOException : r) String -> Sem r String)
-> Sem r String
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (CallStack -> String -> Sem r String
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem r String)
-> (IOException -> String) -> IOException -> Sem r String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show)
[String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (String
s String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf`) (String -> [String]
L.lines String
contents)) Int -> Int -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, Eq a, Show a, HasCallStack) =>
a -> a -> Sem r ()
=== Int
n
assertFileLines :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> (Int -> Bool)
-> FilePath
-> Sem r ()
assertFileLines :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
(Int -> Bool) -> String -> Sem r ()
assertFileLines Int -> Bool
p String
fp = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
String
contents <- String -> Sem (Error IOException : r) String
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r String
readFile String
fp
Sem (Error IOException : r) String
-> (Sem (Error IOException : r) String -> Sem r String)
-> Sem r String
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (CallStack -> String -> Sem r String
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem r String)
-> (IOException -> String) -> IOException -> Sem r String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show)
let lines :: [String]
lines = String -> [String]
L.lines String
contents
let len :: Int
len = case [String] -> [String]
forall a. [a] -> [a]
L.reverse [String]
lines of
String
"":[String]
xs -> [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [String]
xs
[String]
xs -> [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [String]
xs
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Bool
p Int
len) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has an unexpected number of lines")
assertEndsWithSingleNewline :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertEndsWithSingleNewline :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertEndsWithSingleNewline String
fp = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
String
contents <- String -> Sem (Error IOException : r) String
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r String
readFile String
fp
Sem (Error IOException : r) String
-> (Sem (Error IOException : r) String -> Sem r String)
-> Sem r String
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (CallStack -> String -> Sem r String
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem r String)
-> (IOException -> String) -> IOException -> Sem r String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show)
case String -> String
forall a. [a] -> [a]
L.reverse String
contents of
Char
'\n':Char
'\n':String
_ -> CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ends with too many newlines.")
Char
'\n':String
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
String
_ -> CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must end with newline.")
assertDirectoryExists :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member (Embed IO) r
=> Member Log r
=> FilePath
-> Sem r ()
assertDirectoryExists :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r ()
assertDirectoryExists String
dir = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- String -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r Bool
doesDirectoryExist String
dir
Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (Sem r Bool -> IOException -> Sem r Bool
forall a b. a -> b -> a
const (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False))
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
"Directory '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' does not exist on the file system.")
assertDirectoryMissing :: forall r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member Log r
=> Member (Embed IO) r
=> FilePath
-> Sem r ()
assertDirectoryMissing :: forall (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
Member (Embed IO) r) =>
String -> Sem r ()
assertDirectoryMissing String
dir = (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- String -> Sem (Error IOException : r) Bool
forall (r :: EffectRow).
(HasCallStack, Member (Error IOException) r, Member (Embed IO) r,
Member Log r) =>
String -> Sem r Bool
doesDirectoryExist String
dir
Sem (Error IOException : r) Bool
-> (Sem (Error IOException : r) Bool -> Sem r Bool) -> Sem r Bool
forall a b. a -> (a -> b) -> b
& forall e a (r :: EffectRow).
(e -> Sem r a) -> Sem (Error e : r) a -> Sem r a
trap @IOException (Sem r Bool -> IOException -> Sem r Bool
forall a b. a -> b -> a
const (Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False))
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Maybe Diff -> String -> Sem r ()
forall (r :: EffectRow) a.
Member Hedgehog r =>
CallStack -> Maybe Diff -> String -> Sem r a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
"Directory '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' does exist on the file system.")
byDeadlineIO :: forall a r m. ()
=> HasCallStack
=> Member (Embed m) r
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member Log r
=> NominalDiffTime
-> UTCTime
-> String
-> m a
-> Sem r a
byDeadlineIO :: forall a (r :: EffectRow) (m :: * -> *).
(HasCallStack, Member (Embed m) r, Member (Embed IO) r,
Member Hedgehog r, Member Log r) =>
NominalDiffTime -> UTCTime -> String -> m a -> Sem r a
byDeadlineIO NominalDiffTime
period UTCTime
deadline String
errorMessage m a
f = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> String -> Sem r a -> Sem r a
forall a (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
Member (Embed IO) r) =>
NominalDiffTime -> UTCTime -> String -> Sem r a -> Sem r a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage (Sem r a -> Sem r a) -> Sem r a -> Sem r a
forall a b. (a -> b) -> a -> b
$ m a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed m a
f
byDeadlineM :: forall a r. ()
=> HasCallStack
=> Member Hedgehog r
=> Member Log r
=> Member (Embed IO) r
=> NominalDiffTime
-> UTCTime
-> String
-> Sem r a
-> Sem r a
byDeadlineM :: forall a (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
Member (Embed IO) r) =>
NominalDiffTime -> UTCTime -> String -> Sem r a -> Sem r a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage Sem r a
f = (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => Sem r a) -> Sem r a)
-> (HasCallStack => Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ do
UTCTime
start <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
DTC.getCurrentTime
a
a <- Sem r a
goM
UTCTime
end <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
DTC.getCurrentTime
String -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, ToString a) =>
a -> Sem r ()
jot_ (String -> Sem r ()) -> String -> Sem r ()
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 -> Sem r a
forall a. a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
where goM :: Sem r a
goM = Sem r a -> (Failure -> Sem r a) -> Sem r a
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
Sem r a -> (Failure -> Sem r a) -> Sem r a
catchAssertion Sem r a
f ((Failure -> Sem r a) -> Sem r a)
-> (Failure -> Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ \Failure
e -> do
UTCTime
currentTime <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
DTC.getCurrentTime
if UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
deadline
then do
IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
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))
Sem r a
goM
else do
UTCTime -> Sem r ()
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack, Show a) =>
a -> Sem r ()
jotShow_ UTCTime
currentTime
Sem r Any -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Any -> Sem r ()) -> Sem r Any -> Sem r ()
forall a b. (a -> b) -> a -> b
$ CallStack -> String -> Sem r Any
forall a (r :: EffectRow).
(Member Hedgehog r, HasCallStack) =>
CallStack -> String -> Sem r a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> Sem r Any) -> String -> Sem r 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 -> Sem r a
forall (r :: EffectRow) a.
(Member Hedgehog r, HasCallStack) =>
Failure -> Sem r a
throwAssertion Failure
e
byDurationIO :: forall b r m . ()
=> HasCallStack
=> Member (Embed m) r
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member Log r
=> NominalDiffTime
-> NominalDiffTime
-> String
-> m b
-> Sem r b
byDurationIO :: forall b (r :: EffectRow) (m :: * -> *).
(HasCallStack, Member (Embed m) r, Member (Embed IO) r,
Member Hedgehog r, Member Log r) =>
NominalDiffTime -> NominalDiffTime -> String -> m b -> Sem r b
byDurationIO NominalDiffTime
period NominalDiffTime
duration String
errorMessage m b
f =
(HasCallStack => Sem r b) -> Sem r b
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => Sem r b) -> Sem r b)
-> (HasCallStack => Sem r b) -> Sem r b
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime -> String -> Sem r b -> Sem r b
forall b (r :: EffectRow).
(HasCallStack, Member (Embed IO) r, Member Hedgehog r,
Member Log r) =>
NominalDiffTime -> NominalDiffTime -> String -> Sem r b -> Sem r b
byDurationM NominalDiffTime
period NominalDiffTime
duration String
errorMessage (Sem r b -> Sem r b) -> Sem r b -> Sem r b
forall a b. (a -> b) -> a -> b
$ m b -> Sem r b
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed m b
f
byDurationM :: forall b r. ()
=> HasCallStack
=> Member (Embed IO) r
=> Member Hedgehog r
=> Member Log r
=> NominalDiffTime
-> NominalDiffTime
-> String
-> Sem r b
-> Sem r b
byDurationM :: forall b (r :: EffectRow).
(HasCallStack, Member (Embed IO) r, Member Hedgehog r,
Member Log r) =>
NominalDiffTime -> NominalDiffTime -> String -> Sem r b -> Sem r b
byDurationM NominalDiffTime
period NominalDiffTime
duration String
errorMessage Sem r b
f = (HasCallStack => Sem r b) -> Sem r b
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => Sem r b) -> Sem r b)
-> (HasCallStack => Sem r b) -> Sem r b
forall a b. (a -> b) -> a -> b
$ do
UTCTime
deadline <- NominalDiffTime -> UTCTime -> UTCTime
DTC.addUTCTime NominalDiffTime
duration (UTCTime -> UTCTime) -> Sem r UTCTime -> Sem r UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
DTC.getCurrentTime
NominalDiffTime -> UTCTime -> String -> Sem r b -> Sem r b
forall a (r :: EffectRow).
(HasCallStack, Member Hedgehog r, Member Log r,
Member (Embed IO) r) =>
NominalDiffTime -> UTCTime -> String -> Sem r a -> Sem r a
byDeadlineM NominalDiffTime
period UTCTime
deadline String
errorMessage Sem r b
f