{-# options_haddock prune #-}

-- |Test Interpreters, Internal
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 =
  IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Base.catch IO ()
ioe IOError -> IO ()
forall (m :: * -> *). Monad m => IOError -> m ()
handler
  where
    handler :: Monad m => IOError -> m ()
    handler :: forall (m :: * -> *). Monad m => IOError -> m ()
handler =
      m () -> IOError -> m ()
forall a b. a -> b -> a
const m ()
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 (rInitial :: EffectRow) x.
 Test (Sem rInitial) x -> Sem r x)
-> Sem (Test : r) a -> Sem r a
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 ->
      Path Abs Dir -> Sem r (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
base
    Test.TempDir Path Rel Dir
path ->
      Path Abs Dir -> Path Rel Dir -> Sem r (Path Abs Dir)
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 ->
      Path Abs Dir -> [Text] -> Path Rel File -> Sem r (Path Abs File)
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 ->
      Path Abs Dir -> Path Rel File -> Sem r Text
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 ->
      Path Abs Dir -> Path Rel p -> Sem r (Path Abs p)
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 ->
      Path Abs Dir -> Path Rel File -> Sem r Text
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 =
  Either TestError (Path Abs Dir) -> Sem r (Path Abs Dir)
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either TestError (Path Abs Dir) -> Sem r (Path Abs Dir))
-> (Either Text (Path Abs Dir) -> Either TestError (Path Abs Dir))
-> Either Text (Path Abs Dir)
-> Sem r (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> TestError)
-> Either Text (Path Abs Dir) -> Either TestError (Path Abs Dir)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> TestError
TestError (Either Text (Path Abs Dir) -> Sem r (Path Abs Dir))
-> Sem r (Either Text (Path Abs Dir)) -> Sem r (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Path Abs Dir) -> Sem r (Either Text (Path Abs Dir))
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny do
    Path Abs Dir
systemTmp <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
    Path Abs Dir -> String -> IO (Path Abs Dir)
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> String -> m (Path Abs Dir)
createTempDir Path Abs Dir
systemTmp String
"polysemy-test-"

-- |Interpret 'Test' so that fixtures are read from the directory @base@ and temp operations are performed in
-- @/tmp/polysemy-test-XXX@.
--
-- This library uses 'Path' for all file system related tasks, so in order to construct paths manually, you'll have to
-- use the quasiquoters 'Path.absdir' and 'Path.reldir' or the functions 'parseAbsDir' and 'parseRelDir'.
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 <- Sem r (Path Abs Dir)
forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp
  Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
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

-- |like 'interpretTestKeepTemp', but deletes the temp dir after the test.
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
  Sem r (Path Abs Dir)
-> (Path Abs Dir -> Sem r ())
-> (Path Abs Dir -> Sem r a)
-> Sem r a
forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem r (Path Abs Dir)
forall (r :: EffectRow).
Members '[Error TestError, Embed IO] r =>
Sem r (Path Abs Dir)
createTemp Path Abs Dir -> Sem r ()
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 =
      IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> IO ()
ignoringIOErrors (Path b Dir -> IO ()
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 =
      Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
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

-- |Call 'interpretTest' with the subdirectory @prefix@ of the current working directory as the base dir, which is
-- most likely something like @test@.
-- This is not necessarily consistent, it depends on which directory your test runner uses as cwd.
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 <- IO (Path Rel Dir) -> Sem r (Path Rel Dir)
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 (Text -> String
forall a. ToString a => a -> String
toString Text
prefix))
  Path Abs Dir
base <- IO (Path Abs Dir) -> Sem r (Path Abs Dir)
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)
  Path Abs Dir -> InterpreterFor Test r
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 -> a -> Sem r 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 (Maybe Diff -> String -> TestT m a
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (Text -> String
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 =
  (String -> TestError) -> Sem (Fail : r) a -> Sem r a
forall e (r :: EffectRow) a.
Member (Error e) r =>
(String -> e) -> Sem (Fail : r) a -> Sem r a
failToError (Text -> TestError
TestError (Text -> TestError) -> (String -> Text) -> String -> TestError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)

-- |Run 'Hedgehog' and its dependent effects that correspond to the monad stack of 'TestT', exposing the monadic state.
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 =
  Sem (Writer Journal : r) (Either Failure a)
-> Sem r (Journal, Either Failure a)
forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter (Sem (Writer Journal : r) (Either Failure a)
 -> Sem r (Journal, Either Failure a))
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Writer Journal : r) (Either Failure a))
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem r (Journal, Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Error Failure : Writer Journal : r) a
-> Sem (Writer Journal : r) (Either Failure a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError (Sem (Error Failure : Writer Journal : r) a
 -> Sem (Writer Journal : r) (Either Failure a))
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Error Failure : Writer Journal : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Writer Journal : r) (Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Hedgehog m : Error Failure : Writer Journal : r) a
-> Sem (Error Failure : Writer Journal : r) a
forall (m :: * -> *) (r :: EffectRow).
Members '[Error Failure, Writer Journal, Embed m] r =>
InterpreterFor (Hedgehog m) r
rewriteHedgehog (Sem (Hedgehog m : Error Failure : Writer Journal : r) a
 -> Sem (Error Failure : Writer Journal : r) a)
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Hedgehog m : Error Failure : Writer Journal : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Error Failure : Writer Journal : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Hedgehog m : Error Failure : r) a
-> Sem (Hedgehog m : Error Failure : Writer Journal : r) a
forall (e3 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (e2 :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e1 : e2 : r) a -> Sem (e1 : e2 : e3 : r) a
raise2Under (Sem (Hedgehog m : Error Failure : r) a
 -> Sem (Hedgehog m : Error Failure : Writer Journal : r) a)
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Hedgehog m : Error Failure : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Hedgehog m : Error Failure : Writer Journal : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Sem (Hedgehog m : Error Failure : r) (Either TestError a)
-> (Either TestError a -> Sem (Hedgehog m : Error Failure : r) a)
-> Sem (Hedgehog m : Error Failure : r) a
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) (Sem (Hedgehog m : Error Failure : r) (Either TestError a)
 -> Sem (Hedgehog m : Error Failure : r) a)
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Hedgehog m : Error Failure : r) (Either TestError a))
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Hedgehog m : Error Failure : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Hedgehog m : Error Failure : r) (Either TestError a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError (Sem (Error TestError : Hedgehog m : Error Failure : r) a
 -> Sem (Hedgehog m : Error Failure : r) (Either TestError a))
-> (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
    -> Sem (Error TestError : Hedgehog m : Error Failure : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Hedgehog m : Error Failure : r) (Either TestError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem (Error TestError : Hedgehog m : Error Failure : r) a
forall (r :: EffectRow).
Member (Error TestError) r =>
InterpreterFor Fail r
failToFailure

-- |Run 'Hedgehog' with 'unwrapLiftedTestT' and wrap it back into the 'TestT' stack.
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) <- m (Journal, Either Failure a)
-> TestT m (Journal, Either Failure a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Sem r (Journal, Either Failure a) -> m (Journal, Either Failure a)
forall x. Sem r x -> m x
runSem (Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a
-> Sem r (Journal, Either Failure a)
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))
  ExceptT Failure (WriterT Journal m) a -> TestT m a
forall (m :: * -> *) a.
ExceptT Failure (WriterT Journal m) a -> TestT m a
TestT (WriterT Journal m (Either Failure a)
-> ExceptT Failure (WriterT Journal m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Failure a
result Either Failure a
-> WriterT Journal m () -> WriterT Journal m (Either Failure a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Journal -> WriterT Journal m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
MTL.tell Journal
journal))

-- |'Final' version of 'semToTestT'.
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 x. Sem '[Embed m, Final m] x -> m x)
-> Sem
     '[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
       Final m]
     a
-> TestT m a
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 (Sem '[Final m] x -> m x
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final m] x -> m x)
-> (Sem '[Embed m, Final m] x -> Sem '[Final m] x)
-> Sem '[Embed m, Final m] x
-> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem '[Embed m, Final m] x -> Sem '[Final m] x
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
  ]

-- |Convenience combinator that runs both 'Hedgehog' and 'Test' and rewraps the result in @'TestT' IO@, ready for
-- execution as a property.
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 =
  Sem
  '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
    Final IO]
  a
-> TestT IO a
forall (m :: * -> *) a.
Monad m =>
Sem
  '[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
    Final m]
  a
-> TestT m a
semToTestTFinal (Sem
   '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
     Final IO]
   a
 -> TestT IO a)
-> (Sem TestEffects a
    -> Sem
         '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
           Final IO]
         a)
-> Sem TestEffects a
-> TestT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
    Embed IO, Final IO]
  a
-> Sem
     '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
       Final IO]
     a
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal (Sem
   '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
     Embed IO, Final IO]
   a
 -> Sem
      '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
        Final IO]
      a)
-> (Sem TestEffects a
    -> Sem
         '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
           Embed IO, Final IO]
         a)
-> Sem TestEffects a
-> Sem
     '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
       Final IO]
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Path Abs Dir
-> InterpreterFor
     Test
     '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
       Embed IO, Final IO]
forall (r :: EffectRow).
Members '[Error TestError, Resource, Embed IO] r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
dir

-- |Same as 'runTest', but uses 'interpretTestInSubdir'.
runTestInSubdir ::
  Text ->
  Sem TestEffects a ->
  TestT IO a
runTestInSubdir :: forall a. Text -> Sem TestEffects a -> TestT IO a
runTestInSubdir Text
prefix =
  Sem
  '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
    Final IO]
  a
-> TestT IO a
forall (m :: * -> *) a.
Monad m =>
Sem
  '[Fail, Error TestError, Hedgehog m, Error Failure, Embed m,
    Final m]
  a
-> TestT m a
semToTestTFinal (Sem
   '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
     Final IO]
   a
 -> TestT IO a)
-> (Sem TestEffects a
    -> Sem
         '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
           Final IO]
         a)
-> Sem TestEffects a
-> TestT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
    Embed IO, Final IO]
  a
-> Sem
     '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
       Final IO]
     a
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal (Sem
   '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
     Embed IO, Final IO]
   a
 -> Sem
      '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
        Final IO]
      a)
-> (Sem TestEffects a
    -> Sem
         '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
           Embed IO, Final IO]
         a)
-> Sem TestEffects a
-> Sem
     '[Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO,
       Final IO]
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text
-> InterpreterFor
     Test
     '[Resource, Fail, Error TestError, Hedgehog IO, Error Failure,
       Embed IO, Final IO]
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 = String -> Text
forall a. ToText a => a -> Text
toText -> Text
file, srcLocModule :: SrcLoc -> String
srcLocModule = String -> Text
forall a. ToText a => a -> Text
toText -> Text
modl } <- TestError -> Maybe SrcLoc -> Sem r SrcLoc
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TestError
emptyCallStack Maybe SrcLoc
deepestSrcLoc
  Text
dirPrefix <- TestError -> Maybe Text -> Sem r Text
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 Text -> Text -> Text
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 IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  TestError -> Maybe (Path Abs Dir) -> Sem r (Path Abs Dir)
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TestError
badSrcLoc (Path Abs Dir -> String -> Maybe (Path Abs Dir)
forall {f :: * -> *}.
(Alternative f, MonadThrow f) =>
Path Abs Dir -> String -> f (Path Abs Dir)
parseDir Path Abs Dir
cwd (Text -> String
forall a. ToString a => a -> String
toString Text
dirPrefix))
  where
    emptyCallStack :: TestError
emptyCallStack =
      Text -> TestError
TestError Text
"empty call stack"
    deepestSrcLoc :: Maybe SrcLoc
deepestSrcLoc =
      (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe ([(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack))
    badSrcLoc :: TestError
badSrcLoc =
      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 =
      String -> f (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dirPrefix f (Path Abs Dir) -> f (Path Abs Dir) -> f (Path Abs Dir)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Path Abs Dir
cwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel Dir -> Path Abs Dir)
-> f (Path Rel Dir) -> f (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
dirPrefix

-- |Wrapper for 'semToTestT' that uses the call stack to determine the base dir of the test run.
-- Note that if you wrap this function, you'll have to use the 'HasCallStack' constraint to supply the implicit
-- 'GHC.Stack.Types.CallStack'.
runTestAutoWith ::
  HasCallStack =>
  Members [Resource, Embed IO] r =>
  (∀ x . Sem r x -> IO x) ->
  Sem (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a ->
  TestT IO a
runTestAutoWith :: forall (r :: EffectRow) a.
(HasCallStack, Members '[Resource, Embed IO] r) =>
(forall x. Sem r x -> IO x)
-> Sem
     (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a
-> TestT IO a
runTestAutoWith forall x. Sem r x -> IO x
runSem Sem
  (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a
sem =
  (forall x. Sem r x -> IO x)
-> Sem (Fail : Error TestError : Hedgehog IO : Error Failure : r) a
-> TestT IO a
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 -> IO x
runSem do
    Path Abs Dir
base <- Sem
  (Fail : Error TestError : Hedgehog IO : Error Failure : r)
  (Path Abs Dir)
forall (r :: EffectRow).
(Members '[Error TestError, Embed IO] r, HasCallStack) =>
Sem r (Path Abs Dir)
callingTestDir
    Path Abs Dir
-> InterpreterFor
     Test (Fail : Error TestError : Hedgehog IO : Error Failure : r)
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 : r) a
sem

-- |Version of 'runTestAutoWith' specialized to @'Final' IO@
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 =
  (forall x. Sem '[Embed IO, Resource, Final IO] x -> IO x)
-> Sem
     '[Test, Fail, Error TestError, Hedgehog IO, Error Failure,
       Embed IO, Resource, Final IO]
     a
-> TestT IO a
forall (r :: EffectRow) a.
(HasCallStack, Members '[Resource, Embed IO] r) =>
(forall x. Sem r x -> IO x)
-> Sem
     (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a
-> TestT IO a
runTestAutoWith (Sem '[Final IO] x -> IO x
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final IO] x -> IO x)
-> (Sem '[Embed IO, Resource, Final IO] x -> Sem '[Final IO] x)
-> Sem '[Embed IO, Resource, Final IO] x
-> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem '[Resource, Final IO] x -> Sem '[Final IO] x
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal (Sem '[Resource, Final IO] x -> Sem '[Final IO] x)
-> (Sem '[Embed IO, Resource, Final IO] x
    -> Sem '[Resource, Final IO] x)
-> Sem '[Embed IO, Resource, Final IO] x
-> Sem '[Final IO] x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem '[Embed IO, Resource, Final IO] x
-> Sem '[Resource, Final IO] x
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal)