{-# 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 =
  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-"

-- |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 <- 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

-- |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
  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

-- |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 <- 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)

-- |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 =
  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

-- |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) <- 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))

-- |'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 (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
  ]

-- |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 =
  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

-- |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 =
  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

-- |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'.
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