{-# options_haddock prune #-}
module Polysemy.Test.Run where
import qualified Control.Exception as Base
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT))
import qualified Control.Monad.Trans.Writer.Lazy as MTL
import qualified Data.Text as Text
import GHC.Stack (callStack)
import GHC.Stack.Types (SrcLoc (SrcLoc, srcLocFile), getCallStack, srcLocModule)
import Hedgehog.Internal.Property (Failure, Journal, TestT (TestT), failWith)
import Path (Abs, Dir, Path, parseAbsDir, parseRelDir, (</>))
import Path.IO (canonicalizePath, createTempDir, getCurrentDir, getTempDir, removeDirRecur)
import System.IO.Error (IOError)
import Polysemy.Test.Data.Hedgehog (Hedgehog, liftH)
import qualified Polysemy.Test.Data.Test as Test
import Polysemy.Test.Data.Test (Test)
import Polysemy.Test.Data.TestError (TestError (TestError))
import qualified Polysemy.Test.Files as Files
import Polysemy.Test.Hedgehog (rewriteHedgehog)
ignoringIOErrors ::
IO () ->
IO ()
ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors IO ()
ioe =
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Base.catch IO ()
ioe forall (m :: * -> *). Monad m => IOError -> m ()
handler
where
handler :: Monad m => IOError -> m ()
handler :: forall (m :: * -> *). Monad m => IOError -> m ()
handler =
forall a b. a -> b -> a
const forall (f :: * -> *). Applicative f => f ()
unit
interpretTestIn' ::
Member (Embed IO) r =>
Path Abs Dir ->
Path Abs Dir ->
InterpreterFor Test r
interpretTestIn' :: forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base Path Abs Dir
tempBase =
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
Test (Sem rInitial) x
Test.TestDir ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
base
Test.TempDir Path Rel Dir
path ->
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Rel Dir -> Sem r (Path Abs Dir)
Files.tempDir Path Abs Dir
tempBase Path Rel Dir
path
Test.TempFile [Text]
content Path Rel File
path ->
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> [Text] -> Path Rel File -> Sem r (Path Abs File)
Files.tempFile Path Abs Dir
tempBase [Text]
content Path Rel File
path
Test.TempFileContent Path Rel File
path ->
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Rel File -> Sem r Text
Files.tempFileContent Path Abs Dir
tempBase Path Rel File
path
Test.FixturePath Path Rel p
path ->
forall p (r :: EffectRow).
Path Abs Dir -> Path Rel p -> Sem r (Path Abs p)
Files.fixturePath Path Abs Dir
base Path Rel p
path
Test.Fixture Path Rel File
path ->
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Rel File -> Sem r Text
Files.fixture Path Abs Dir
base Path Rel File
path
createTemp ::
Members [Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp :: forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp =
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (HasCallStack, HasCallStack) => Text -> TestError
TestError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny do
Path Abs Dir
systemTmp <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> String -> m (Path Abs Dir)
createTempDir Path Abs Dir
systemTmp String
"polysemy-test-"
interpretTestKeepTemp ::
Members [Error TestError, Embed IO] r =>
Path Abs Dir ->
InterpreterFor Test r
interpretTestKeepTemp :: forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTestKeepTemp Path Abs Dir
base Sem (Test : r) a
sem = do
Path Abs Dir
tempBase <- forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base Path Abs Dir
tempBase Sem (Test : r) a
sem
interpretTest ::
Members [Error TestError, Resource, Embed IO] r =>
Path Abs Dir ->
InterpreterFor Test r
interpretTest :: forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
base Sem (Test : r) a
sem = do
forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp forall {r :: EffectRow} {b}.
Member (Embed IO) r =>
Path b Dir -> Sem r ()
release Path Abs Dir -> Sem r a
use
where
release :: Path b Dir -> Sem r ()
release Path b Dir
tempBase =
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> IO ()
ignoringIOErrors (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
tempBase))
use :: Path Abs Dir -> Sem r a
use Path Abs Dir
tempBase =
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base Path Abs Dir
tempBase Sem (Test : r) a
sem
interpretTestInSubdir ::
Members [Error TestError, Resource, Embed IO] r =>
Text ->
InterpreterFor Test r
interpretTestInSubdir :: forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Text -> InterpreterFor Test r
interpretTestInSubdir Text
prefix Sem (Test : r) a
sem = do
Path Rel Dir
prefixPath <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir @IO (forall a. ToString a => a -> String
toString Text
prefix))
Path Abs Dir
base <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath @_ @IO Path Rel Dir
prefixPath)
forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
base Sem (Test : r) a
sem
errorToFailure ::
∀ m r a .
Monad m =>
Member (Hedgehog m) r =>
Either TestError a ->
Sem r a
errorToFailure :: forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Hedgehog m) r) =>
Either TestError a -> Sem r a
errorToFailure = \case
Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left (TestError Text
e) -> forall (m :: * -> *) a (r :: EffectRow).
Member (Hedgehog m) r =>
TestT m a -> Sem r a
liftH @m (forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith forall a. Maybe a
Nothing (forall a. ToString a => a -> String
toString Text
e))
failToFailure ::
Member (Error TestError) r =>
InterpreterFor Fail r
failToFailure :: forall (r :: EffectRow).
Member (Error TestError) r =>
InterpreterFor Fail r
failToFailure =
forall e (r :: EffectRow) a.
Member (Error e) r =>
(String -> e) -> Sem (Fail : r) a -> Sem r a
failToError ((HasCallStack, HasCallStack) => Text -> TestError
TestError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText)
unwrapLiftedTestT ::
∀ m r a .
Monad m =>
Member (Embed m) r =>
Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->
Sem r (Journal, Either Failure a)
unwrapLiftedTestT :: forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Embed m) r) =>
Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem r (Journal, Either Failure a)
unwrapLiftedTestT =
forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (m :: * -> *) (r :: EffectRow).
Members '[Error Failure, Writer Journal, Embed m] r =>
InterpreterFor (Hedgehog m) r
rewriteHedgehog forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (e3 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
(e2 :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e1 : e2 : r) a -> Sem (e1 : e2 : e3 : r) a
raise2Under forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Hedgehog m) r) =>
Either TestError a -> Sem r a
errorToFailure @m) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow).
Member (Error TestError) r =>
InterpreterFor Fail r
failToFailure
semToTestT ::
Monad m =>
Member (Embed m) r =>
(∀ x . Sem r x -> m x) ->
Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->
TestT m a
semToTestT :: forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Embed m) r) =>
(forall x. Sem r x -> m x)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> TestT m a
semToTestT forall x. Sem r x -> m x
runSem Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
sem = do
(Journal
journal, Either Failure a
result) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall x. Sem r x -> m x
runSem (forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Embed m) r) =>
Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem r (Journal, Either Failure a)
unwrapLiftedTestT Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
sem))
forall (m :: * -> *) a.
ExceptT Failure (WriterT Journal m) a -> TestT m a
TestT (forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Failure a
result forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
MTL.tell Journal
journal))
semToTestTFinal ::
Monad m =>
Sem [Fail, Error TestError, Hedgehog m, Error Failure, Embed m, Final m] a ->
TestT m a
semToTestTFinal :: forall (m :: * -> *) a.
Monad m =>
Sem
'[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
Final m]
a
-> TestT m a
semToTestTFinal =
forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Embed m) r) =>
(forall x. Sem r x -> m x)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> TestT m a
semToTestT (forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal)
type TestEffects =
[
Test,
Resource,
Fail,
Error TestError,
Hedgehog IO,
Error Failure,
Embed IO,
Final IO
]
runTest ::
Path Abs Dir ->
Sem TestEffects a ->
TestT IO a
runTest :: forall a. Path Abs Dir -> Sem TestEffects a -> TestT IO a
runTest Path Abs Dir
dir =
forall (m :: * -> *) a.
Monad m =>
Sem
'[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
Final m]
a
-> TestT m a
semToTestTFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
dir
runTestInSubdir ::
Text ->
Sem TestEffects a ->
TestT IO a
runTestInSubdir :: forall a. Text -> Sem TestEffects a -> TestT IO a
runTestInSubdir Text
prefix =
forall (m :: * -> *) a.
Monad m =>
Sem
'[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
Final m]
a
-> TestT m a
semToTestTFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Text -> InterpreterFor Test r
interpretTestInSubdir Text
prefix
callingTestDir ::
Members [Error TestError, Embed IO] r =>
HasCallStack =>
Sem r (Path Abs Dir)
callingTestDir :: forall (r :: EffectRow).
(Members '[Error TestError, Embed IO] r, HasCallStack) =>
Sem r (Path Abs Dir)
callingTestDir = do
SrcLoc { srcLocFile :: SrcLoc -> String
srcLocFile = forall a. ToText a => a -> Text
toText -> Text
file, srcLocModule :: SrcLoc -> String
srcLocModule = forall a. ToText a => a -> Text
toText -> Text
modl } <- forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TestError
emptyCallStack Maybe SrcLoc
deepestSrcLoc
Text
dirPrefix <- forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TestError
badSrcLoc (Text -> Text -> Maybe Text
Text.stripSuffix (Text -> Text -> Text -> Text
Text.replace Text
"." Text
"/" Text
modl forall a. Semigroup a => a -> a -> a
<> Text
".hs") Text
file)
Path Abs Dir
cwd <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @IO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TestError
badSrcLoc (forall {f :: * -> *}.
(Alternative f, MonadThrow f) =>
Path Abs Dir -> String -> f (Path Abs Dir)
parseDir Path Abs Dir
cwd (forall a. ToString a => a -> String
toString Text
dirPrefix))
where
emptyCallStack :: TestError
emptyCallStack =
(HasCallStack, HasCallStack) => Text -> TestError
TestError Text
"empty call stack"
deepestSrcLoc :: Maybe SrcLoc
deepestSrcLoc =
forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
listToMaybe (forall a. [a] -> [a]
reverse (CallStack -> [(String, SrcLoc)]
getCallStack HasCallStack => CallStack
callStack))
badSrcLoc :: TestError
badSrcLoc =
(HasCallStack, HasCallStack) => Text -> TestError
TestError Text
"call stack couldn't be processed"
parseDir :: Path Abs Dir -> String -> f (Path Abs Dir)
parseDir Path Abs Dir
cwd String
dirPrefix =
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dirPrefix forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Path Abs Dir
cwd </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
dirPrefix
runTestAuto ::
HasCallStack =>
Sem [Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO] a ->
TestT IO a
runTestAuto :: forall a.
HasCallStack =>
Sem
'[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
Embed IO, Resource, Final IO]
a
-> TestT IO a
runTestAuto Sem
'[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
Embed IO, Resource, Final IO]
a
sem =
forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Embed m) r) =>
(forall x. Sem r x -> m x)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> TestT m a
semToTestT (forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal) do
Path Abs Dir
base <- forall (r :: EffectRow).
(Members '[Error TestError, Embed IO] r, HasCallStack) =>
Sem r (Path Abs Dir)
callingTestDir
forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
base Sem
'[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
Embed IO, Resource, Final IO]
a
sem