polysemy-test 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+265/−93 lines, 9 filesdep +basedep +transformersdep −base-nopreludedep ~hedgehogdep ~pathdep ~path-ioPVP ok

version bump matches the API change (PVP)

Dependencies added: base, transformers

Dependencies removed: base-noprelude

Dependency ranges changed: hedgehog, path, path-io, polysemy, polysemy-plugin, relude, string-interpolate, tasty, tasty-hedgehog

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• lib/Polysemy/Test.hs +38/−5
• lib/Polysemy/Test/Data/Hedgehog.hs +6/−6
• lib/Polysemy/Test/Hedgehog.hs +78/−17
• lib/Polysemy/Test/Run.hs +96/−41
• polysemy-test.cabal +27/−21
• test/Main.hs +3/−1
• test/Polysemy/Test/Test/FilesTest.hs +3/−2
• test/Polysemy/Test/Test/HedgehogTest.hs +8/−0

@@ -1,3 +1,9 @@+# 0.3.0.0++* Add type parameter for the monad used by `TestT` to `Hedgehog`+* Interpret `Hedgehog` with Polysemy counterparts to `TestT`'s monad stack.+* Add `evalError`, which converts a Polysemy `Error` effect into an assertion.+ # 0.1.0.0  * initial release

@@ -10,21 +10,32 @@   module Polysemy.Test.Data.Test,   tempFileLines,   fixtureLines,+  interpretTestKeepTemp,   interpretTest,   interpretTestInSubdir,-  runTestAuto,-  runTest,-  runTestInSubdir,   -- * Hedgehog effect   module Polysemy.Test.Data.Hedgehog,   assert,   (===),+  (/==),   assertRight,+  assertJust,   evalEither,+  evalMaybe,+  evalError,   interpretHedgehog,+  -- * Running 'Hedgehog' and 'Test' as 'TestT'+  runTestAutoWith,+  runTestAuto,+  runTest,+  runTestInSubdir,+  unwrapLiftedTestT,+  semToTestT,+  semToTestTFinal,   -- * Utilities   UnitTest,   unitTest,+  TestError(TestError), ) where  import qualified Data.Text as Text@@ -35,8 +46,30 @@  import Polysemy.Test.Data.Hedgehog (Hedgehog, liftH) import Polysemy.Test.Data.Test (Test, fixture, fixturePath, tempDir, tempFile, tempFileContent, testDir)-import Polysemy.Test.Hedgehog (assert, assertRight, evalEither, interpretHedgehog, (===))-import Polysemy.Test.Run (interpretTest, interpretTestInSubdir, runTest, runTestAuto, runTestInSubdir)+import Polysemy.Test.Data.TestError (TestError(TestError))+import Polysemy.Test.Hedgehog (+  assert,+  assertJust,+  assertRight,+  evalEither,+  evalError,+  evalMaybe,+  interpretHedgehog,+  (/==),+  (===),+  )+import Polysemy.Test.Run (+  interpretTest,+  interpretTestInSubdir,+  interpretTestKeepTemp,+  runTest,+  runTestAuto,+  runTestAutoWith,+  runTestInSubdir,+  semToTestT,+  semToTestTFinal,+  unwrapLiftedTestT,+  )  -- |Convenience type alias for tests. type UnitTest = TestT IO ()

@@ -7,19 +7,19 @@ import Hedgehog (TestT)  -- |Convenience effect for embedding Hedgehog assertions.-data Hedgehog :: Effect where-  LiftH :: TestT IO a -> Hedgehog m a+data Hedgehog m :: Effect where+  LiftH :: TestT m a -> Hedgehog m n a --- |Lift a @'TestT' IO@ into Sem.+-- |Lift a @'TestT' m@ into Sem. -- -- >>> liftH (Hedgehog.evalEither (Left 0)) -- liftH (Hedgehog.evalEither (Left 0)) -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -- │ 0 liftH ::-  ∀ a r .-  Member Hedgehog r =>-  TestT IO a ->+  ∀ m a r .+  Member (Hedgehog m) r =>+  TestT m a ->   Sem r a liftH =   send . LiftH

@@ -2,31 +2,48 @@  module Polysemy.Test.Hedgehog where +import qualified Control.Monad.Trans.Writer.Lazy as MTL import qualified Hedgehog as Native-import Hedgehog (TestT)+import Hedgehog.Internal.Property (Failure, Journal, TestT(TestT))+import Polysemy.Writer (Writer, tell)  import qualified Polysemy.Test.Data.Hedgehog as Hedgehog import Polysemy.Test.Data.Hedgehog (Hedgehog, liftH)  -- |Interpret 'Hedgehog' into @'TestT' IO@ by simple embedding of the native combinators. interpretHedgehog ::-  Member (Embed (TestT IO)) r =>-  InterpreterFor Hedgehog r+  Member (Embed (TestT m)) r =>+  InterpreterFor (Hedgehog m) r interpretHedgehog =   interpret \case     Hedgehog.LiftH t ->       embed t +-- |Interpret 'Hedgehog' in terms of @'Error' 'Failure'@ and @'Writer' 'Journal'@, which correspond to the monad stack+-- wrapped by 'TestT'.+rewriteHedgehog ::+  Members [Error Failure, Writer Journal, Embed m] r =>+  InterpreterFor (Hedgehog m) r+rewriteHedgehog =+  interpret \case+    Hedgehog.LiftH (TestT t) -> do+      (result, journal) <- embed (MTL.runWriterT (runExceptT t))+      tell journal+      fromEither result+ -- |Embeds 'Hedgehog.assert'. assert ::-  ∀ r .+  ∀ m r .+  Monad m =>   HasCallStack =>-  Member Hedgehog r =>+  Member (Hedgehog m) r =>   Bool ->   Sem r () assert a =   withFrozenCallStack $ liftH (Native.assert a) +infix 4 ===+ -- |Embeds 'Hedgehog.==='. -- -- >>> 5 === 6@@ -36,22 +53,47 @@ -- │ - 5 -- │ + 6 (===) ::+  ∀ a m r .+  Monad m =>   Eq a =>   Show a =>   HasCallStack =>-  Member Hedgehog r =>+  Member (Hedgehog m) r =>   a ->   a ->   Sem r () a === b =   withFrozenCallStack $ liftH (a Native.=== b) +infix 4 /==++-- |Embeds 'Hedgehog./=='.+--+-- >>> 5 /== 5+-- 5 /== 5+-- ^^^^^^^+-- │ ━━━ Failed (no differences) ━━━+-- │ 5+(/==) ::+  ∀ a m r .+  Monad m =>+  Eq a =>+  Show a =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  a ->+  a ->+  Sem r ()+a /== b =+  withFrozenCallStack $ liftH (a Native./== b)+ -- |Embeds 'Hedgehog.evalEither'. evalEither ::-  ∀ a e r .+  ∀ a m e r .   Show e =>+  Monad m =>   HasCallStack =>-  Member Hedgehog r =>+  Member (Hedgehog m) r =>   Either e a ->   Sem r a evalEither e =@@ -60,12 +102,13 @@ -- |Given a reference value, unpacks an 'Either' with 'evalEither' and applies '===' to the result in the -- 'Right' case, and produces a test failure in the 'Left' case. assertRight ::-  ∀ a e r .-  Show e =>+  ∀ a m e r .   Eq a =>+  Show e =>   Show a =>+  Monad m =>   HasCallStack =>-  Member Hedgehog r =>+  Member (Hedgehog m) r =>   a ->   Either e a ->   Sem r ()@@ -76,21 +119,39 @@   ValueIsNothing   deriving Show +-- |Like 'evalEither', but for 'Maybe'.+evalMaybe ::+  ∀ a m r .+  Monad m =>+  HasCallStack =>+  Member (Hedgehog m) r =>+  Maybe a ->+  Sem r a+evalMaybe ma =+  withFrozenCallStack $ evalEither (maybeToRight ValueIsNothing ma)++-- |Given a reference value, asserts that the scrutinee is 'Just' and its contained value matches the target. assertJust ::+  ∀ a m r .   Eq a =>   Show a =>+  Monad m =>   HasCallStack =>-  Member Hedgehog r =>+  Member (Hedgehog m) r =>   a ->   Maybe a ->   Sem r () assertJust target ma =   withFrozenCallStack $ assertRight target (maybeToRight ValueIsNothing ma) -evalMaybe ::+-- |Run a Polysemy 'Error' effect and assert its result.+evalError ::+  ∀ e a m r .+  Show e =>+  Monad m =>   HasCallStack =>-  Member Hedgehog r =>-  Maybe a ->+  Member (Hedgehog m) r =>+  Sem (Error e : r) a ->   Sem r a-evalMaybe ma =-  withFrozenCallStack $ evalEither (maybeToRight ValueIsNothing ma)+evalError sem =+  withFrozenCallStack $ evalEither =<< runError sem

@@ -3,21 +3,22 @@ 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, 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 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.Resource (Resource, bracket, resourceToIOFinal)+import Polysemy.Writer (runLazyWriter) import System.IO.Error (IOError) -import Polysemy.Test.Data.Hedgehog (Hedgehog)+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 (interpretHedgehog)+import Polysemy.Test.Hedgehog (rewriteHedgehog)  ignoringIOErrors ::   IO () ->@@ -32,41 +33,62 @@ interpretTestIn' ::   Member (Embed IO) r =>   Path Abs Dir ->+  Path Abs Dir ->   InterpreterFor Test r-interpretTestIn' base =+interpretTestIn' base tempBase =   interpret \case     Test.TestDir ->       pure base     Test.TempDir path ->-      Files.tempDir base path+      Files.tempDir tempBase path     Test.TempFile content path ->-      Files.tempFile base content path+      Files.tempFile tempBase content path     Test.TempFileContent path ->-      Files.tempFileContent base path+      Files.tempFileContent tempBase 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.+createTemp ::+  Members [Error TestError, Embed IO] r =>+  Sem r (Path Abs Dir)+createTemp =+  fromEither =<< (embed . runExceptT) do+    systemTmp <- getTempDir+    createTempDir systemTmp "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 'reldir' or the functions 'parseAbsDir' and 'parseRelDir'.+interpretTestKeepTemp ::+  Members [Error TestError, Embed IO] r =>+  Path Abs Dir ->+  InterpreterFor Test r+interpretTestKeepTemp base sem = do+  tempBase <- createTemp+  (interpretTestIn' base tempBase) sem++-- |like 'interpretTestKeepTemp', but deletes the temp dir after the test. interpretTest ::-  Member (Embed IO) r =>+  Members [Error TestError, Resource, 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+  bracket createTemp release use+  where+    release tempBase =+      embed (ignoringIOErrors (removeDirRecur tempBase))+    use tempBase =+      (interpretTestIn' base tempBase) 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 =>+  Members [Error TestError, Resource, Embed IO] r =>   Text ->   InterpreterFor Test r interpretTestInSubdir prefix sem = do@@ -77,48 +99,71 @@ type TestEffects =   [     Error TestError,+    Hedgehog IO,     Embed IO,-    Hedgehog,-    Embed (TestT IO),-    Final (TestT IO)+    Final IO   ]  errorToFailure ::-  Member (Embed (TestT IO)) r =>+  Monad m =>+  Member (Hedgehog m) r =>   Either TestError a ->   Sem r a errorToFailure = \case   Right a -> pure a-  Left (TestError e) -> embed (failWith Nothing (toString e))+  Left (TestError e) -> liftH (failWith Nothing (toString e)) -runTestIO ::-  Sem TestEffects a ->-  TestT IO a-runTestIO =-  runFinal .-  embedToFinal @(TestT IO) .-  interpretHedgehog .-  runEmbedded lift .+-- |Run 'Hedgehog' and its dependent effects that correspond to the monad stack of 'TestT', exposing the monadic state.+unwrapLiftedTestT ::+  Monad m =>+  Member (Embed m) r =>+  Sem (Error TestError : Hedgehog m : r) a ->+  Sem r (Journal, Either Failure a)+unwrapLiftedTestT =+  runLazyWriter .+  runError .+  rewriteHedgehog .+  raiseUnder2 .   (>>= errorToFailure) .   runError --- |Convenience combinator that runs both 'Hedgehog' and 'Test' and uses the final monad @'TestT' IO@, ready for+-- |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 (Error TestError : Hedgehog m : r) a ->+  TestT m a+semToTestT run sem = do+  (journal, result) <- lift (run (unwrapLiftedTestT sem))+  TestT (ExceptT (result <$ MTL.tell journal))++semToTestTFinal ::+  Monad m =>+  Sem [Error TestError, Hedgehog m, Embed m, Final m] a ->+  TestT m a+semToTestTFinal =+  semToTestT (runFinal . embedToFinal)++-- |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 (Test : TestEffects) a ->+  Sem [Test, Resource, Error TestError, Hedgehog IO, Embed IO, Final IO] a ->   TestT IO a runTest dir =-  runTestIO .+  semToTestTFinal .+  resourceToIOFinal .   interpretTest dir  -- |Same as 'runTest', but uses 'interpretTestInSubdir'. runTestInSubdir ::   Text ->-  Sem (Test : TestEffects) a ->+  Sem (Test : Resource : TestEffects) a ->   TestT IO a runTestInSubdir prefix =-  runTestIO .+  semToTestTFinal .+  resourceToIOFinal .   interpretTestInSubdir prefix  callingTestDir ::@@ -140,14 +185,24 @@     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.+-- |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 ::+runTestAutoWith ::   HasCallStack =>-  Sem (Test : TestEffects) a ->+  Members [Resource, Embed IO] r =>+  (∀ x . Sem r x -> IO x) ->+  Sem (Test : Error TestError : Hedgehog IO : r) a ->   TestT IO a-runTestAuto sem = do-  runTestIO do+runTestAutoWith run sem =+  semToTestT run do     base <- callingTestDir     interpretTest base sem++-- |Version of 'runTestAutoWith' specialized to @'Final' IO@+runTestAuto ::+  HasCallStack =>+  Sem [Test, Error TestError, Hedgehog IO, Embed IO, Resource, Final IO] a ->+  TestT IO a+runTestAuto =+  runTestAutoWith (runFinal . resourceToIOFinal . embedToFinal)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-test-version:        0.2.0.0+version:        0.3.0.0 synopsis:       Polysemy effects for testing description:    Please see the README on Github at <https://github.com/tek/polysemy-test> category:       Test@@ -39,19 +39,22 @@   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+      base >=4 && <5     , containers     , either-    , hedgehog-    , path-    , path-io-    , polysemy-    , polysemy-plugin-    , relude-    , string-interpolate-    , tasty-    , tasty-hedgehog+    , hedgehog >=1.0.2 && <1.1+    , path >=0.8 && <0.9+    , path-io >=0.3.1 && <0.4+    , polysemy >=1.3.0 && <1.4+    , polysemy-plugin >=0.2.5 && <0.3+    , relude >=0.7 && <0.8+    , string-interpolate >=0.1 && <0.2+    , tasty >=1.2.3 && <1.3+    , tasty-hedgehog >=1 && <1.1     , text+    , transformers+  mixins:+      base hiding (Prelude)   default-language: Haskell2010  test-suite polysemy-test-unit@@ -59,27 +62,30 @@   main-is: Main.hs   other-modules:       Polysemy.Test.Test.FilesTest+      Polysemy.Test.Test.HedgehogTest       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+      base >=4 && <5     , containers     , either-    , hedgehog-    , path-    , path-io-    , polysemy-    , polysemy-plugin+    , hedgehog >=1.0.2 && <1.1+    , path >=0.8 && <0.9+    , path-io >=0.3.1 && <0.4+    , polysemy >=1.3.0 && <1.4+    , polysemy-plugin >=0.2.5 && <0.3     , polysemy-test-    , relude-    , string-interpolate+    , relude >=0.7 && <0.8+    , string-interpolate >=0.1 && <0.2     , tasty-    , tasty-hedgehog+    , tasty-hedgehog >=1 && <1.1     , text+    , transformers   mixins:-      polysemy-test hiding (Polysemy.Test.Prelude)+      base hiding (Prelude)+    , polysemy-test hiding (Polysemy.Test.Prelude)     , polysemy-test (Polysemy.Test.Prelude as Prelude)   default-language: Haskell2010

@@ -4,12 +4,14 @@  import Polysemy.Test (unitTest) import Polysemy.Test.Test.FilesTest (test_fixture, test_tempFile)+import Polysemy.Test.Test.HedgehogTest (test_hedgehogRewrite)  tests :: TestTree tests =   testGroup "all" [     unitTest "read fixtures" test_fixture,-    unitTest "write and read temp files" test_tempFile+    unitTest "write and read temp files" test_tempFile,+    unitTest "rewrite TestT to Sem" test_hedgehogRewrite   ]  main :: IO ()

@@ -2,9 +2,9 @@  import qualified Data.Text as Text import qualified Data.Text.IO as Text-import Path (relfile, toFilePath)+import Path (File, Rel, relfile, toFilePath) -import Polysemy.Test (UnitTest, fixtureLines, runTestAuto, runTestInSubdir, tempFileLines, (===))+import Polysemy.Test (UnitTest, fixtureLines, runTestAuto, runTestInSubdir, tempFileLines, (/==), (===)) import qualified Polysemy.Test.Data.Test as Test  test_fixture :: UnitTest@@ -15,6 +15,7 @@     fixContent2 <- Text.lines <$> embed (Text.readFile (toFilePath fixPath))     fixContent1 === fixContent2     fixContent1 === ["file", "content"]+    fixContent1 /== ["file", "content", "and more"]   where     fixRel =       [relfile|files/file1|]

@@ -0,0 +1,8 @@+module Polysemy.Test.Test.HedgehogTest where++import Polysemy.Test (UnitTest, (/==))+import Polysemy.Test.Run (semToTestTFinal)++test_hedgehogRewrite :: UnitTest+test_hedgehogRewrite =+  semToTestTFinal ((1 :: Int) /== 2)