{-# OPTIONS_HADDOCK hide #-}

module Polysemy.Test.Run where

import Control.Exception (catch)
import qualified Data.Text as Text
import GHC.Stack.Types (SrcLoc(SrcLoc, srcLocModule, srcLocFile))
import Hedgehog (TestT)
import Hedgehog.Internal.Property (failWith)
import Path (Abs, Dir, Path, parseAbsDir, parseRelDir, reldir, (</>))
import Path.IO (canonicalizePath, getCurrentDir, removeDirRecur)
import Polysemy.Embed (runEmbedded)
import System.IO.Error (IOError)

import Polysemy.Test.Data.Hedgehog (Hedgehog)
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 (interpretHedgehog)

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 ->
  InterpreterFor Test r
interpretTestIn' :: Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base =
  (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
base 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
base [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
base 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

-- |Interpret 'Test' so that all file system operations are performed in the directory @base@.
-- The @temp@ directory will be removed before running.
--
-- 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 'reldir' or the functions 'parseAbsDir' and 'parseRelDir'.
interpretTest ::
  Member (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
  let tempDir' :: Path Abs Dir
tempDir' = Path Abs Dir
base Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|temp|]
  IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> IO ()
ignoringIOErrors (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tempDir'))
  (Path Abs Dir -> Sem (Test : r) a -> Sem r a
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> InterpreterFor Test r
interpretTestIn' Path Abs Dir
base) 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 ::
  Member (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 (FilePath -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir @IO (Text -> FilePath
forall a. ToString a => a -> FilePath
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).
Member (Embed IO) r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
base) Sem (Test : r) a
sem

type TestEffects =
  [
    Error TestError,
    Embed IO,
    Hedgehog,
    Embed (TestT IO),
    Final (TestT IO)
  ]

errorToFailure ::
  Member (Embed (TestT IO)) 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 IO a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Maybe Diff -> FilePath -> TestT IO a
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
e))

runTestIO ::
  Sem TestEffects a ->
  TestT IO a
runTestIO :: Sem TestEffects a -> TestT IO a
runTestIO =
  Sem '[Final (TestT IO)] a -> TestT IO a
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final (TestT IO)] a -> TestT IO a)
-> (Sem TestEffects a -> Sem '[Final (TestT IO)] a)
-> Sem TestEffects a
-> TestT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow) a.
(Member (Final (TestT IO)) r, Functor (TestT IO)) =>
Sem (Embed (TestT IO) : r) a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal @(TestT IO) (Sem '[Embed (TestT IO), Final (TestT IO)] a
 -> Sem '[Final (TestT IO)] a)
-> (Sem TestEffects a
    -> Sem '[Embed (TestT IO), Final (TestT IO)] a)
-> Sem TestEffects a
-> Sem '[Final (TestT IO)] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a
-> Sem '[Embed (TestT IO), Final (TestT IO)] a
forall (r :: EffectRow).
Member (Embed (TestT IO)) r =>
InterpreterFor Hedgehog r
interpretHedgehog (Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a
 -> Sem '[Embed (TestT IO), Final (TestT IO)] a)
-> (Sem TestEffects a
    -> Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a)
-> Sem TestEffects a
-> Sem '[Embed (TestT IO), Final (TestT IO)] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall x. IO x -> TestT IO x)
-> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a
-> Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a
forall (m1 :: * -> *) (m2 :: * -> *) (r :: EffectRow) a.
Member (Embed m2) r =>
(forall x. m1 x -> m2 x) -> Sem (Embed m1 : r) a -> Sem r a
runEmbedded forall x. IO x -> TestT IO x
forall (t :: Effect) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a
 -> Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a)
-> (Sem TestEffects a
    -> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a)
-> Sem TestEffects a
-> Sem '[Hedgehog, Embed (TestT IO), Final (TestT IO)] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Sem
  '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)]
  (Either TestError a)
-> (Either TestError a
    -> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a)
-> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either TestError a
-> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a
forall (r :: EffectRow) a.
Member (Embed (TestT IO)) r =>
Either TestError a -> Sem r a
errorToFailure) (Sem
   '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)]
   (Either TestError a)
 -> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a)
-> (Sem TestEffects a
    -> Sem
         '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)]
         (Either TestError a))
-> Sem TestEffects a
-> Sem '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem TestEffects a
-> Sem
     '[Embed IO, Hedgehog, Embed (TestT IO), Final (TestT IO)]
     (Either TestError a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError

-- |Convenience combinator that runs both 'Hedgehog' and 'Test' and uses the final monad @'TestT' IO@, ready for
-- execution as a property.
runTest ::
  Path Abs Dir ->
  Sem (Test : TestEffects) a ->
  TestT IO a
runTest :: Path Abs Dir -> Sem (Test : TestEffects) a -> TestT IO a
runTest Path Abs Dir
dir =
  Sem TestEffects a -> TestT IO a
forall a. Sem TestEffects a -> TestT IO a
runTestIO (Sem TestEffects a -> TestT IO a)
-> (Sem (Test : TestEffects) a -> Sem TestEffects a)
-> Sem (Test : TestEffects) a
-> TestT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Path Abs Dir -> InterpreterFor Test TestEffects
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
dir

-- |Same as 'runTest', but uses 'interpretTestInSubdir'.
runTestInSubdir ::
  Text ->
  Sem (Test : TestEffects) a ->
  TestT IO a
runTestInSubdir :: Text -> Sem (Test : TestEffects) a -> TestT IO a
runTestInSubdir Text
prefix =
  Sem TestEffects a -> TestT IO a
forall a. Sem TestEffects a -> TestT IO a
runTestIO (Sem TestEffects a -> TestT IO a)
-> (Sem (Test : TestEffects) a -> Sem TestEffects a)
-> Sem (Test : TestEffects) a
-> TestT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> InterpreterFor Test TestEffects
forall (r :: EffectRow).
Member (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 -> FilePath
srcLocFile = FilePath -> Text
forall a. ToText a => a -> Text
toText -> Text
file, srcLocModule :: SrcLoc -> FilePath
srcLocModule = FilePath -> 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 (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 -> FilePath -> Maybe (Path Abs Dir)
forall (f :: * -> *).
(Alternative f, MonadThrow f) =>
Path Abs Dir -> FilePath -> f (Path Abs Dir)
parseDir Path Abs Dir
cwd (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
dirPrefix))
  where
    emptyCallStack :: TestError
emptyCallStack =
      Text -> TestError
TestError Text
"empty call stack"
    deepestSrcLoc :: Maybe SrcLoc
deepestSrcLoc =
      (FilePath, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((FilePath, SrcLoc) -> SrcLoc)
-> Maybe (FilePath, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FilePath, SrcLoc)] -> Maybe (FilePath, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe ([(FilePath, SrcLoc)] -> [(FilePath, SrcLoc)]
forall a. [a] -> [a]
reverse (CallStack -> [(FilePath, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack))
    badSrcLoc :: TestError
badSrcLoc =
      Text -> TestError
TestError Text
"call stack couldn't be processed"
    parseDir :: Path Abs Dir -> FilePath -> f (Path Abs Dir)
parseDir Path Abs Dir
cwd FilePath
dirPrefix =
      FilePath -> f (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir FilePath
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
<$> FilePath -> f (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir FilePath
dirPrefix

-- |Wrapper for 'runTest' 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 : TestEffects) a ->
  TestT IO a
runTestAuto :: Sem (Test : TestEffects) a -> TestT IO a
runTestAuto Sem (Test : TestEffects) a
sem = do
  Sem TestEffects a -> TestT IO a
forall a. Sem TestEffects a -> TestT IO a
runTestIO do
    Path Abs Dir
base <- Sem TestEffects (Path Abs Dir)
forall (r :: EffectRow).
(Members '[Error TestError, Embed IO] r, HasCallStack) =>
Sem r (Path Abs Dir)
callingTestDir
    Path Abs Dir -> Sem (Test : TestEffects) a -> Sem TestEffects a
forall (r :: EffectRow).
Member (Embed IO) r =>
Path Abs Dir -> InterpreterFor Test r
interpretTest Path Abs Dir
base Sem (Test : TestEffects) a
sem