{-# options_haddock hide #-}

module Polysemy.Test.Run where

import Control.Exception (catch)
import qualified Control.Monad.Trans.Writer.Lazy as MTL
import qualified Data.Text as Text
import GHC.Stack.Types (SrcLoc (SrcLoc, srcLocFile), 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 Polysemy.Fail (Fail, failToError)
import Polysemy.Resource (Resource, bracket, resourceToIOFinal)
import Polysemy.Writer (runWriter)
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
catch IO ()
ioe IOError -> IO ()
forall (m :: * -> *). Monad m => IOError -> m ()
handler
  where
    handler :: Monad m => IOError -> m ()
    handler :: 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' :: Path Abs Dir -> Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base Path Abs Dir
tempBase =
  (forall x (rInitial :: EffectRow).
 Test (Sem rInitial) x -> Sem r x)
-> Sem (Test : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). 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 ->
      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 content 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 ->
      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 ->
      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 ->
      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 :: 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 a c b. (a -> c) -> Either a b -> Either c b
mapLeft 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 :: 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 -> Sem (Test : r) a -> Sem r a
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 :: 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.
MemberWithError 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.
(Find (Embed IO) r, LocateEffect (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 -> Sem (Test : r) a -> Sem r a
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 :: 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 (String -> IO (Path Rel Dir)
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 (Path Rel Dir -> IO (AbsPath (Path Rel Dir))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath @_ @IO Path Rel Dir
prefixPath)
  (Path Abs Dir -> Sem (Test : r) a -> Sem r a
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 :: 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) -> TestT m a -> Sem r a
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 :: 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 : r) a ->
  Sem r (Journal, Either Failure a)
unwrapLiftedTestT :: Sem (Fail : Error TestError : Hedgehog m : 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 : r) a
    -> Sem (Writer Journal : r) (Either Failure a))
-> Sem (Fail : Error TestError : Hedgehog m : 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 : r) a
    -> Sem (Error Failure : Writer Journal : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : 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 : r) a
    -> Sem (Hedgehog m : Error Failure : Writer Journal : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : r) a
-> Sem (Error Failure : Writer Journal : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Hedgehog m : r) a
-> Sem (Hedgehog m : Error Failure : Writer Journal : r) a
forall (e2 :: Effect) (e3 :: Effect) (e1 :: Effect)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : e3 : r) a
raiseUnder2 (Sem (Hedgehog m : r) a
 -> Sem (Hedgehog m : Error Failure : Writer Journal : r) a)
-> (Sem (Fail : Error TestError : Hedgehog m : r) a
    -> Sem (Hedgehog m : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : r) a
-> Sem (Hedgehog m : Error Failure : Writer Journal : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Sem (Hedgehog m : r) (Either TestError a)
-> (Either TestError a -> Sem (Hedgehog m : r) a)
-> Sem (Hedgehog m : r) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (r :: EffectRow) a.
(Monad m, Member (Hedgehog m) r) =>
Either TestError a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
(Monad m, Member (Hedgehog m) r) =>
Either TestError a -> Sem r a
errorToFailure @m) (Sem (Hedgehog m : r) (Either TestError a)
 -> Sem (Hedgehog m : r) a)
-> (Sem (Fail : Error TestError : Hedgehog m : r) a
    -> Sem (Hedgehog m : r) (Either TestError a))
-> Sem (Fail : Error TestError : Hedgehog m : r) a
-> Sem (Hedgehog m : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Error TestError : Hedgehog m : r) a
-> Sem (Hedgehog m : 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 : r) a
 -> Sem (Hedgehog m : r) (Either TestError a))
-> (Sem (Fail : Error TestError : Hedgehog m : r) a
    -> Sem (Error TestError : Hedgehog m : r) a)
-> Sem (Fail : Error TestError : Hedgehog m : r) a
-> Sem (Hedgehog m : r) (Either TestError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Fail : Error TestError : Hedgehog m : r) a
-> Sem (Error TestError : Hedgehog m : 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 : r) a ->
  TestT m a
semToTestT :: (forall x. Sem r x -> m x)
-> Sem (Fail : Error TestError : Hedgehog m : r) a -> TestT m a
semToTestT forall x. Sem r x -> m x
run Sem (Fail : Error TestError : Hedgehog m : r) a
sem = do
  (Journal
journal, Either Failure a
result) <- m (Journal, Either Failure a)
-> TestT m (Journal, Either Failure a)
forall (t :: Effect) (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
run (Sem (Fail : Error TestError : Hedgehog m : 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 : r) a
-> Sem r (Journal, Either Failure a)
unwrapLiftedTestT Sem (Fail : Error TestError : Hedgehog m : 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, Embed m, Final m] a ->
  TestT m a
semToTestTFinal :: Sem '[Fail, Error TestError, Hedgehog m, 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, 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 : 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,
    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 :: Path Abs Dir -> Sem TestEffects a -> TestT IO a
runTest Path Abs Dir
dir =
  Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a
-> TestT IO a
forall (m :: * -> *) a.
Monad m =>
Sem '[Fail, Error TestError, Hedgehog m, Embed m, Final m] a
-> TestT m a
semToTestTFinal (Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a
 -> TestT IO a)
-> (Sem TestEffects a
    -> Sem '[Fail, Error TestError, Hedgehog IO, 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, Embed IO, Final IO]
  a
-> Sem '[Fail, Error TestError, Hedgehog IO, 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, Embed IO, Final IO]
   a
 -> Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a)
-> (Sem TestEffects a
    -> Sem
         '[Resource, Fail, Error TestError, Hedgehog IO, Embed IO, Final IO]
         a)
-> Sem TestEffects a
-> Sem '[Fail, Error TestError, Hedgehog IO, 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, 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 :: Text -> Sem TestEffects a -> TestT IO a
runTestInSubdir Text
prefix =
  Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a
-> TestT IO a
forall (m :: * -> *) a.
Monad m =>
Sem '[Fail, Error TestError, Hedgehog m, Embed m, Final m] a
-> TestT m a
semToTestTFinal (Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a
 -> TestT IO a)
-> (Sem TestEffects a
    -> Sem '[Fail, Error TestError, Hedgehog IO, 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, Embed IO, Final IO]
  a
-> Sem '[Fail, Error TestError, Hedgehog IO, 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, Embed IO, Final IO]
   a
 -> Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a)
-> (Sem TestEffects a
    -> Sem
         '[Resource, Fail, Error TestError, Hedgehog IO, Embed IO, Final IO]
         a)
-> Sem TestEffects a
-> Sem '[Fail, Error TestError, Hedgehog IO, Embed IO, Final IO] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text
-> InterpreterFor
     Test
     '[Resource, Fail, Error TestError, Hedgehog IO, 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 :: 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 <- IO (Path Abs Dir) -> Sem r (Path Abs Dir)
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 : r) a ->
  TestT IO a
runTestAutoWith :: (forall x. Sem r x -> IO x)
-> Sem (Test : Fail : Error TestError : Hedgehog IO : r) a
-> TestT IO a
runTestAutoWith forall x. Sem r x -> IO x
run Sem (Test : Fail : Error TestError : Hedgehog IO : r) a
sem =
  (forall x. Sem r x -> IO x)
-> Sem (Fail : Error TestError : Hedgehog IO : 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 : r) a -> TestT m a
semToTestT forall x. Sem r x -> IO x
run do
    Path Abs Dir
base <- Sem (Fail : Error TestError : Hedgehog IO : r) (Path Abs Dir)
forall (r :: EffectRow).
(Members '[Error TestError, Embed IO] r, HasCallStack) =>
Sem r (Path Abs Dir)
callingTestDir
    Path Abs Dir
-> Sem (Test : Fail : Error TestError : Hedgehog IO : r) a
-> Sem (Fail : Error TestError : Hedgehog IO : r) a
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 : r) a
sem

-- |Version of 'runTestAutoWith' specialized to @'Final' IO@
runTestAuto ::
  HasCallStack =>
  Sem [Test, Fail, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] a ->
  TestT IO a
runTestAuto :: Sem
  '[Test, Fail, Error TestError, Hedgehog IO, 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, 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 : 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)