packages feed

polysemy-test (empty) → 0.1.0.0

raw patch · 16 files changed

+1012/−0 lines, 16 filesdep +base-nopreludedep +containersdep +either

Dependencies added: base-noprelude, containers, either, hedgehog, path, path-io, polysemy, polysemy-plugin, polysemy-test, relude, string-interpolate, tasty, tasty-hedgehog, text

Files

+ Changelog.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++* initial release
+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2020 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,57 @@+# About++This package provides utilities for testing [Polysemy] programs:++* An effect, `Test`, that gives access to temporary files and fixtures+* An effect, `Hedgehog`, for lifted [Hedgehog] assertions++# Example++```haskell+import Path (relfile)+import Polysemy.Test+import Test.Tasty (defaultMain)++test_fixture :: UnitTest+test_fixture =+  runTestAuto do+    fixContent1 <- fixtureLines fixRel+    fixPath <- Test.fixturePath fixRel+    fixContent2 <- Text.lines <$> embed (Text.readFile (toFilePath fixPath))+    fixContent1 === fixContent2+    fixContent1 === ["file", "content"]+  where+    fixRel =+      [relfile|files/file1|]++main :: IO ()+main =+  defaultMain (unitTest test_fixture)+```++# Fixtures++Any file that is located below the subdirectory `fixtures` inside the test+directory can be accessed using the constructors `Test.fixturePath`,+`Test.fixture` and `Text.fixtureLines`.++You can override the path used to look for the `fixtures` directory by using+`runTest` instead of `runTestAuto`.+The latter analyzes the call stack to determine the test directory.++# Temp Files++The constructors `Test.tempDir`, `Test.tempFile`, `Test.tempFileContent` and+`Test.tempFileLines` allow you to create and read files in the `temp` directory+within the test directory.++# Paths++All paths are of type `Path` from the package [path].++You can construct them using the quasiquoters `reldir`, `absdir` etc. or the+functions `parseRelDir`, `parseAbsDir` etc.++[Polysemy]: https://hackage.haskell.org/package/polysemy+[Hedgehog]: https://hackage.haskell.org/package/hedgehog+[path]: https://hackage.haskell.org/package/path
+ lib/Polysemy/Test.hs view
@@ -0,0 +1,84 @@+{-| polysemy-test -}+module Polysemy.Test (+  -- $intro+  -- * Test effect+  module Polysemy.Test.Data.Test,+  tempFileLines,+  fixtureLines,+  interpretTest,+  interpretTestInSubdir,+  runTestAuto,+  runTest,+  runTestInSubdir,+  -- * Hedgehog effect+  module Polysemy.Test.Data.Hedgehog,+  interpretHedgehog,+  -- * Utilities+  UnitTest,+  unitTest,+) where++import qualified Data.Text as Text+import Hedgehog (TestT, property, test, withTests)+import Path (File, Path, Rel)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++import Polysemy.Test.Data.Hedgehog (Hedgehog, assert, assertEqual, assertRight, evalEither, liftH, (===))+import Polysemy.Test.Data.Test (Test, fixture, fixturePath, tempDir, tempFile, tempFileContent, testDir)+import Polysemy.Test.Hedgehog (interpretHedgehog)+import Polysemy.Test.Run (interpretTest, interpretTestInSubdir, runTest, runTestAuto, runTestInSubdir)++-- |Convenience type alias for tests.+type UnitTest = TestT IO ()++-- |Convert a @'TestT' IO ()@ to a 'TestTree' ready for use with Tasty's machinery.+unitTest :: TestName -> UnitTest -> TestTree+unitTest desc =+  testProperty desc . withTests 1 . property . test++-- |Read the contents of a file relative to the fixture directory as a list of lines.+fixtureLines ::+  ∀ r .+  Member Test r =>+  Path Rel File ->+  Sem r [Text]+fixtureLines =+  fmap Text.lines . fixture++-- |Read the contents of a temporary file as a list of lines.+tempFileLines ::+  ∀ r .+  Member Test r =>+  Path Rel File ->+  Sem r [Text]+tempFileLines =+  fmap Text.lines . tempFileContent++{- $intro+This package provides utilities for testing Polysemy programs:++  (1) An effect, 'Test', that gives access to temporary files and fixtures+  (2) An effect, 'Hedgehog', for lifted Hedgehog assertions++@+import Polysemy.Test+import Test.Tasty (defaultMain)++test_fixture :: UnitTest+test_fixture =+  runTestAuto do+    fixContent1 <- fixtureLines fixRel+    fixPath <- Test.fixturePath fixRel+    fixContent2 <- Text.lines <$> embed (Text.readFile (toFilePath fixPath))+    fixContent1 === fixContent2+    fixContent1 === ["file", "content"]+  where+    fixRel =+      [relfile|files/file1|]+@++main :: IO ()+main =+  defaultMain (unitTest test_fixture)+-}
+ lib/Polysemy/Test/Assert.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Assert (+  module Polysemy.Test.Assert,+  assert,+  evalEither,+  (===),+) where++import Hedgehog (TestT, assert, evalEither, (===))++assertRight ::+  Eq a =>+  Show a =>+  Show e =>+  Monad m =>+  a ->+  Either e a ->+  TestT m ()+assertRight target =+  (target ===) <=< evalEither++data ValueIsNothing =+  ValueIsNothing+  deriving Show++assertJust ::+  Eq a =>+  Show a =>+  Monad m =>+  a ->+  Maybe a ->+  TestT m ()+assertJust target =+  assertRight target . maybeToRight ValueIsNothing++evalMaybe ::+  Monad m =>+  Maybe a ->+  TestT m a+evalMaybe =+  evalEither . maybeToRight ValueIsNothing
+ lib/Polysemy/Test/Data/Hedgehog.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Data.Hedgehog where++import Hedgehog (TestT)++import Polysemy (makeSem_)++-- |Convenience effect for embedding Hedgehog assertions.+data Hedgehog :: Effect where+  LiftH :: TestT IO a -> Hedgehog m a+  Assert :: Bool -> Hedgehog m ()+  AssertEqual :: (Eq a, Show a) => a -> a -> Hedgehog m ()+  EvalEither :: Show e => Either e a -> Hedgehog m a+  AssertRight :: (Show e, Eq a, Show a) => a -> Either e a -> Hedgehog m ()++makeSem_ ''Hedgehog++-- |Lift a @'TestT' IO@ into Sem.+-- >>> liftH (Hedgehog.evalEither (Right 0))+liftH ::+  ∀ a r .+  Member Hedgehog r =>+  TestT IO a ->+  Sem r a++-- |Embeds 'Hedgehog.assert'.+assert ::+  ∀ r .+  Member Hedgehog r =>+  Bool ->+  Sem r ()++-- |Embeds 'Hedgehog.(===)'.+assertEqual ::+  ∀ a r .+  Eq a =>+  Show a =>+  Member Hedgehog r =>+  a ->+  a ->+  Sem r ()++-- |Alias for 'assertEqual'.+-- >>> 5 === 6+(===) ::+  Eq a =>+  Show a =>+  Member Hedgehog r =>+  a ->+  a ->+  Sem r ()+(===) =+  assertEqual++-- |Embeds 'Hedgehog.evalEither'.+evalEither ::+  ∀ a e r .+  Show e =>+  Member Hedgehog r =>+  Either e a ->+  Sem r a++-- |Given a reference value, unpacks an 'Either' with 'evalEither' and applies 'assertEqual' to the result in the+-- 'Right' case, and produces a test failure in the 'Left' case.+assertRight ::+  ∀ a e r .+  Show e =>+  Eq a =>+  Show a =>+  Member Hedgehog r =>+  a ->+  Either e a ->+  Sem r ()++data ValueIsNothing =+  ValueIsNothing+  deriving Show++assertJust ::+  Eq a =>+  Show a =>+  Member Hedgehog r =>+  a ->+  Maybe a ->+  Sem r ()+assertJust target =+  assertRight target . maybeToRight ValueIsNothing++evalMaybe ::+  Member Hedgehog r =>+  Maybe a ->+  Sem r a+evalMaybe =+  evalEither . maybeToRight ValueIsNothing
+ lib/Polysemy/Test/Data/Test.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Data.Test where++import Path (Abs, Dir, File, Path, Rel)+import Polysemy (makeSem_)++-- |Operations for interacting with fixtures and temp files in a test.+data Test :: Effect where+  TestDir :: Test m (Path Abs Dir)+  TempDir :: Path Rel Dir -> Test m (Path Abs Dir)+  TempFile :: [Text] -> Path Rel File -> Test m (Path Abs File)+  TempFileContent :: Path Rel File -> Test m Text+  FixturePath :: Path Rel p -> Test m (Path Abs p)+  Fixture :: Path Rel File -> Test m Text++makeSem_ ''Test++-- |Return the base dir in which tests are executed.+testDir ::+  ∀ r .+  Member Test r =>+  Sem r (Path Abs Dir)++-- |Create a subdirectory of the directory for temporary files and return its absolute path.+tempDir ::+  ∀ r .+  Member Test r =>+  Path Rel Dir ->+  Sem r (Path Abs Dir)++-- |Write the specified lines of 'Text' to a file under the temp dir and return its absolute path.+tempFile ::+  ∀ r .+  Member Test r =>+  [Text] ->+  Path Rel File ->+  Sem r (Path Abs File)++-- |Read the contents of a temporary file.+tempFileContent ::+  ∀ r .+  Member Test r =>+  Path Rel File ->+  Sem r Text++-- |Construct a path relative to the fixture directory.+fixturePath ::+  ∀ p r .+  Member Test r =>+  Path Rel p ->+  Sem r (Path Abs p)++-- |Read the contents of a file relative to the fixture directory.+fixture ::+  ∀ r .+  Member Test r =>+  Path Rel File ->+  Sem r Text
+ lib/Polysemy/Test/Data/TestError.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Data.TestError where++newtype TestError =+  TestError { unTestError :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)
+ lib/Polysemy/Test/Files.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Files where++import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Path (Abs, Dir, File, Path, Rel, parent, reldir, toFilePath, (</>))+import Path.IO (createDirIfMissing)++tempPath ::+  Path Abs Dir ->+  Path Rel b ->+  Path Abs b+tempPath base path =+  base </> [reldir|temp|] </> path++tempDir ::+  Member (Embed IO) r =>+  Path Abs Dir ->+  Path Rel Dir ->+  Sem r (Path Abs Dir)+tempDir base path = do+  embed (createDirIfMissing @IO True fullPath)+  pure fullPath+  where+    fullPath =+      tempPath base path++readFile ::+  Member (Embed IO) r =>+  Path Abs File ->+  Sem r Text+readFile path =+  embed (Text.readFile (toFilePath path))++tempFile ::+  Member (Embed IO) r =>+  Path Abs Dir ->+  [Text] ->+  Path Rel File ->+  Sem r (Path Abs File)+tempFile base content path = do+  void (tempDir base (parent path))+  fullPath <$ embed (Text.writeFile (toFilePath fullPath) (Text.intercalate "\n" content))+  where+    fullPath =+      tempPath base path++tempFileContent ::+  Member (Embed IO) r =>+  Path Abs Dir ->+  Path Rel File ->+  Sem r Text+tempFileContent base path =+  readFile (tempPath base path)++fixturePath ::+  Path Abs Dir ->+  Path Rel p ->+  Sem r (Path Abs p)+fixturePath base path = do+  return $ base </> [reldir|fixtures|] </> path++fixture ::+  Member (Embed IO) r =>+  Path Abs Dir ->+  Path Rel File ->+  Sem r Text+fixture base subPath = do+  readFile =<< fixturePath base subPath
+ lib/Polysemy/Test/Hedgehog.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}++module Polysemy.Test.Hedgehog where++import qualified Hedgehog as Native+import Hedgehog (TestT, (===))++import qualified Polysemy.Test.Data.Hedgehog as Hedgehog+import Polysemy.Test.Data.Hedgehog (Hedgehog)++-- |Interpret 'Hedgehog' into @'TestT' IO@ by simple embedding of the native combinators.+interpretHedgehog ::+  Member (Embed (TestT IO)) r =>+  InterpreterFor Hedgehog r+interpretHedgehog =+  interpret \case+    Hedgehog.LiftH t ->+      embed t+    Hedgehog.Assert v ->+      embed (Native.assert v)+    Hedgehog.AssertEqual a1 a2 ->+      embed (a1 === a2)+    Hedgehog.EvalEither e ->+      embed (Native.evalEither e)+    Hedgehog.AssertRight a e ->+      embed ((a ===) =<< Native.evalEither e)
+ lib/Polysemy/Test/Prelude.hs view
@@ -0,0 +1,237 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Polysemy.Test.Prelude (+  module Polysemy.Test.Prelude,+  module Data.Either.Combinators,+  module Data.Foldable,+  module Data.Map.Strict,+  module Data.String.Interpolate,+  module Debug.Trace,+  module GHC.Err,+  module Polysemy,+  module Polysemy.AtomicState,+  module Polysemy.Error,+  module Polysemy.Internal.Bundle,+  module Polysemy.Reader,+  module Polysemy.State,+  module Relude,+) where++import Control.Exception (throwIO, try)+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldl, traverse_)+import Data.Map.Strict (Map, lookup)+import Data.String.Interpolate (i)+import qualified Data.Text as Text+import Debug.Trace (trace, traceShow)+import GHC.Err (undefined)+import GHC.IO.Unsafe (unsafePerformIO)+import Polysemy (+  Effect,+  EffectRow,+  Embed,+  Final,+  InterpreterFor,+  Member,+  Members,+  Sem,+  WithTactics,+  embed,+  embedToFinal,+  interpret,+  makeSem,+  pureT,+  raise,+  raiseUnder,+  raiseUnder2,+  raiseUnder3,+  reinterpret,+  runFinal,+  )+import Polysemy.AtomicState (AtomicState, atomicGet, atomicGets, atomicModify', atomicPut, runAtomicStateTVar)+import Polysemy.Error (Error, fromEither, mapError, note, runError, throw)+import Polysemy.Internal.Bundle (Append)+import Polysemy.Reader (Reader)+import Polysemy.State (State, evalState, get, gets, modify, modify', put, runState)+import Relude hiding (+  Reader,+  State,+  Type,+  ask,+  asks,+  evalState,+  filterM,+  get,+  gets,+  hoistEither,+  modify,+  modify',+  put,+  readFile,+  runReader,+  runState,+  state,+  trace,+  traceShow,+  undefined,+  )+import System.IO.Error (userError)++dbg :: Monad m => Text -> m ()+dbg msg = do+  () <- return $ unsafePerformIO (putStrLn (toString msg))+  return ()+{-# INLINE dbg #-}++dbgs :: Monad m => Show a => a -> m ()+dbgs a =+  dbg (show a)+{-# INLINE dbgs_ #-}++dbgs_ :: Monad m => Show a => a -> m a+dbgs_ a =+  a <$ dbg (show a)+{-# INLINE dbgs #-}++unit ::+  Applicative f =>+  f ()+unit =+  pure ()+{-# INLINE unit #-}++tuple ::+  Applicative f =>+  f a ->+  f b ->+  f (a, b)+tuple fa fb =+  (,) <$> fa <*> fb+{-# INLINE tuple #-}++unsafeLogSAnd :: Show a => a -> b -> b+unsafeLogSAnd a b =+  unsafePerformIO $ print a >> return b+{-# INLINE unsafeLogSAnd #-}++unsafeLogAnd :: Text -> b -> b+unsafeLogAnd a b =+  unsafePerformIO $ putStrLn (toString a) >> return b+{-# INLINE unsafeLogAnd #-}++unsafeLogS :: Show a => a -> a+unsafeLogS a =+  unsafePerformIO $ print a >> return a+{-# INLINE unsafeLogS #-}++liftT ::+  forall m f r e a .+  Functor f =>+  Sem r a ->+  Sem (WithTactics e f m r) (f a)+liftT =+  pureT <=< raise+{-# INLINE liftT #-}++hoistEither ::+  Member (Error e2) r =>+  (e1 -> e2) ->+  Either e1 a ->+  Sem r a+hoistEither f =+  fromEither . mapLeft f+{-# INLINE hoistEither #-}++hoistEitherWith ::+  (e -> Sem r a) ->+  Either e a ->+  Sem r a+hoistEitherWith f =+  either f pure+{-# INLINE hoistEitherWith #-}++hoistEitherShow ::+  Show e1 =>+  Member (Error e2) r =>+  (Text -> e2) ->+  Either e1 a ->+  Sem r a+hoistEitherShow f =+  fromEither . mapLeft (f . Text.replace "\\" "" . show)+{-# INLINE hoistEitherShow #-}++hoistErrorWith ::+  (e -> Sem r a) ->+  Sem (Error e : r) a ->+  Sem r a+hoistErrorWith f =+  hoistEitherWith f <=< runError+{-# INLINE hoistErrorWith #-}++tryAny ::+  Member (Embed IO) r =>+  IO a ->+  Sem r (Either Text a)+tryAny =+  embed . fmap (mapLeft show) . try @SomeException+{-# INLINE tryAny #-}++tryHoist ::+  Member (Embed IO) r =>+  (Text -> e) ->+  IO a ->+  Sem r (Either e a)+tryHoist f =+  fmap (mapLeft f) . tryAny+{-# INLINE tryHoist #-}++tryThrow ::+  Members [Embed IO, Error e] r =>+  (Text -> e) ->+  IO a ->+  Sem r a+tryThrow f =+  fromEither <=< tryHoist f+{-# INLINE tryThrow #-}++throwTextIO :: Text -> IO a+throwTextIO =+  throwIO . userError . toString+{-# INLINE throwTextIO #-}++throwEitherIO :: Either Text a -> IO a+throwEitherIO =+  traverseLeft throwTextIO+{-# INLINE throwEitherIO #-}++type a ++ b =+  Append a b++rightOr :: (a -> b) -> Either a b -> b+rightOr f =+  either f id+{-# INLINE rightOr #-}++traverseLeft ::+  Applicative m =>+  (a -> m b) ->+  Either a b ->+  m b+traverseLeft f =+  either f pure+{-# INLINE traverseLeft #-}++as ::+  Functor m =>+  a ->+  m b ->+  m a+as =+  (<$)+{-# INLINE as #-}++mneToList :: Maybe (NonEmpty a) -> [a]+mneToList =+  maybe [] toList+{-# INLINE mneToList #-}
+ lib/Polysemy/Test/Run.hs view
@@ -0,0 +1,153 @@+{-# 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
+ lib/Prelude.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_HADDOCK hide #-}++module Prelude (+  module Polysemy.Test.Prelude,+) where++import Polysemy.Test.Prelude
+ polysemy-test.cabal view
@@ -0,0 +1,86 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           polysemy-test+version:        0.1.0.0+synopsis:       Polysemy effects for testing+description:    Please see the README on Github at <https://github.com/tek/polysemy-test>+category:       Test+author:         Torsten Schmits+maintainer:     tek@tryp.io+copyright:      2020 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    Changelog.md++library+  exposed-modules:+      Polysemy.Test+      Polysemy.Test.Assert+      Polysemy.Test.Data.Hedgehog+      Polysemy.Test.Data.Test+      Polysemy.Test.Data.TestError+      Polysemy.Test.Files+      Polysemy.Test.Hedgehog+      Polysemy.Test.Prelude+      Polysemy.Test.Run+      Paths_polysemy_test+  other-modules:+      Prelude+  autogen-modules:+      Paths_polysemy_test+  hs-source-dirs:+      lib+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -Wall -fplugin=Polysemy.Plugin -O2 -flate-specialise -fspecialise-aggressively+  build-depends:+      base-noprelude+    , containers+    , either+    , hedgehog+    , path+    , path-io+    , polysemy+    , polysemy-plugin+    , relude+    , string-interpolate+    , tasty+    , tasty-hedgehog+    , text+  default-language: Haskell2010++test-suite polysemy-test-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Test.Test.FilesTest+      Paths_polysemy_test+  hs-source-dirs:+      test+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -Wall -fplugin=Polysemy.Plugin -O2 -flate-specialise -fspecialise-aggressively -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base-noprelude+    , containers+    , either+    , hedgehog+    , path+    , path-io+    , polysemy+    , polysemy-plugin+    , polysemy-test+    , relude+    , string-interpolate+    , tasty+    , tasty-hedgehog+    , text+  mixins:+      polysemy-test hiding (Polysemy.Test.Prelude)+    , polysemy-test (Polysemy.Test.Prelude as Prelude)+  default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,17 @@+module Main where++import Test.Tasty (TestTree, defaultMain, testGroup)++import Polysemy.Test (unitTest)+import Polysemy.Test.Test.FilesTest (test_fixture, test_tempFile)++tests :: TestTree+tests =+  testGroup "all" [+    unitTest "read fixtures" test_fixture,+    unitTest "write and read temp files" test_tempFile+  ]++main :: IO ()+main =+  defaultMain tests
+ test/Polysemy/Test/Test/FilesTest.hs view
@@ -0,0 +1,34 @@+module Polysemy.Test.Test.FilesTest where++import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Path (relfile, toFilePath)++import Polysemy.Test (UnitTest, fixtureLines, runTestInSubdir, runTestAuto, tempFileLines, (===))+import qualified Polysemy.Test.Data.Test as Test++test_fixture :: UnitTest+test_fixture =+  runTestAuto do+    fixContent1 <- fixtureLines fixRel+    fixPath <- Test.fixturePath fixRel+    fixContent2 <- Text.lines <$> embed (Text.readFile (toFilePath fixPath))+    fixContent1 === fixContent2+    fixContent1 === ["file", "content"]+  where+    fixRel =+      [relfile|files/file1|]++test_tempFile :: UnitTest+test_tempFile =+  runTestInSubdir "test" do+    tempFile <- Test.tempFile content path+    tempFileContent1 <- tempFileLines path+    tempFIleContent2 <- Text.lines <$> embed (Text.readFile (toFilePath tempFile))+    tempFileContent1 === tempFIleContent2+    tempFileContent1 === content+  where+    path =+      [relfile|tempfile/file1|]+    content =+      ["line1", "line2"]