Run.hs

{-# 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 ioe =
  catch ioe handler
  where
    handler :: Monad m => IOError -> m ()
    handler =
      const unit

interpretTestIn' ::
  Member (Embed IO) r =>
  Path Abs Dir ->
  InterpreterFor Test r
interpretTestIn' base =
  interpret \case
    Test.TestDir ->
      pure base
    Test.TempDir path ->
      Files.tempDir base path
    Test.TempFile content path ->
      Files.tempFile base content path
    Test.TempFileContent path ->
      Files.tempFileContent base path
    Test.FixturePath path ->
      Files.fixturePath base path
    Test.Fixture path ->
      Files.fixture base 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 base sem = do
  let tempDir' = base </> [reldir|temp|]
  embed (ignoringIOErrors (removeDirRecur tempDir'))
  (interpretTestIn' base) 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 prefix sem = do
  prefixPath <- embed (parseRelDir @IO (toString prefix))
  base <- embed (canonicalizePath @_ @IO prefixPath)
  (interpretTest base) 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 = \case
  Right a -> pure a
  Left (TestError e) -> embed (failWith Nothing (toString e))

runTestIO ::
  Sem TestEffects a ->
  TestT IO a
runTestIO =
  runFinal .
  embedToFinal @(TestT IO) .
  interpretHedgehog .
  runEmbedded lift .
  (>>= errorToFailure) .
  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 dir =
  runTestIO .
  interpretTest dir

-- |Same as 'runTest', but uses 'interpretTestInSubdir'.
runTestInSubdir ::
  Text ->
  Sem (Test : TestEffects) a ->
  TestT IO a
runTestInSubdir prefix =
  runTestIO .
  interpretTestInSubdir prefix

callingTestDir ::
  Members [Error TestError, Embed IO] r =>
  HasCallStack =>
  Sem r (Path Abs Dir)
callingTestDir = do
  SrcLoc { srcLocFile = toText -> file, srcLocModule = toText -> modl } <- note emptyCallStack deepestSrcLoc
  dirPrefix <- note badSrcLoc (Text.stripSuffix (Text.replace "." "/" modl <> ".hs") file)
  cwd <- embed getCurrentDir
  note badSrcLoc (parseDir cwd (toString dirPrefix))
  where
    emptyCallStack =
      TestError "empty call stack"
    deepestSrcLoc =
      snd <$> listToMaybe (reverse (getCallStack callStack))
    badSrcLoc =
      TestError "call stack couldn't be processed"
    parseDir cwd dirPrefix =
      parseAbsDir dirPrefix <|> (cwd </>) <$> parseRelDir 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 = do
  runTestIO do
    base <- callingTestDir
    interpretTest base sem