polysemy-test 0.10.0.1 → 0.11.0.1

raw patch · 4 files changed

+199/−48 lines, 4 filesdep ~basedep ~hedgehogdep ~incipit-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, hedgehog, incipit-core, polysemy, polysemy-test, tasty, tasty-hedgehog

API changes (from Hackage documentation)

Files

• lib/Polysemy/Test.hs +20/−3
• lib/Polysemy/Test/Data/TestError.hs +45/−5
• lib/Polysemy/Test/Run.hs +116/−22
• polysemy-test.cabal +18/−18

@@ -34,18 +34,27 @@   interpretHedgehog,   -- * Running 'Hedgehog' and 'Test' as 'TestT'   runTestAutoWith,+  runTestAutoWithSkippable,   runTestAuto,+  runTestAutoSkippable,   runTest,+  runTestSkippable,   runTestInSubdir,+  runTestInSubdirSkippable,   unwrapLiftedTestT,+  unwrapLiftedTestTSkippable,   semToTestT,+  semToTestTSkippable,   semToTestTFinal,+  semToTestTFinalSkippable,   -- * Utilities   UnitTest,   unitTest,   unitTestTimes,-  TestError (TestError),+  TestError (TestError, SkipTest),   testError,+  skipTest,+  SkipTestDefaultValue (..), ) where  import qualified Data.Text as Text@@ -56,7 +65,7 @@  import Polysemy.Test.Data.Hedgehog (Hedgehog, liftH) import Polysemy.Test.Data.Test (Test, fixture, fixturePath, tempDir, tempFile, tempFileContent, testDir)-import Polysemy.Test.Data.TestError (TestError (TestError), testError)+import Polysemy.Test.Data.TestError (SkipTestDefaultValue (..), TestError (TestError, SkipTest), skipTest, testError) import Polysemy.Test.Hedgehog (   assert,   assertClose,@@ -82,11 +91,18 @@   interpretTestKeepTemp,   runTest,   runTestAuto,+  runTestAutoSkippable,   runTestAutoWith,+  runTestAutoWithSkippable,   runTestInSubdir,+  runTestInSubdirSkippable,+  runTestSkippable,   semToTestT,   semToTestTFinal,+  semToTestTFinalSkippable,+  semToTestTSkippable,   unwrapLiftedTestT,+  unwrapLiftedTestTSkippable,   )  -- |Convenience type alias for tests.@@ -132,8 +148,9 @@ {- $intro @ import Path (relfile)-import Polysemy.Test import Test.Tasty (defaultMain)++import Polysemy.Test  test_fixture :: UnitTest test_fixture =

@@ -2,8 +2,10 @@  -- |TestError data type, Internal module Polysemy.Test.Data.TestError (-  TestError (TestError, UnsafeTestError),+  TestError (TestError, SkipTest, UnsafeTestError),   testError,+  skipTest,+  SkipTestDefaultValue (..), ) where  -- | An error that occurred in the test machinery.@@ -11,19 +13,28 @@ -- The pattern synonym is used for construction to ensure that the call site's stack is stored. -- There is no 'IsString' instance because it can't propagate the call stack. -- Use 'testError' to throw a string literal.+--+-- The 'Bool' field indicates whether this is a skip request (@True@) or a regular error (@False@). data TestError where-  UnsafeTestError :: HasCallStack => Text -> TestError+  UnsafeTestError :: HasCallStack => Bool -> Text -> TestError  deriving stock instance Eq TestError deriving stock instance Show TestError  -- | Construct a test error so that the call site's stack is stored in the value, for printing the correct location in -- hedgehog messages.+--+-- Match on errors that aren't skip requests. pattern TestError :: HasCallStack => HasCallStack => Text -> TestError-pattern TestError err <- UnsafeTestError err where-  TestError err = withFrozenCallStack $ UnsafeTestError err-{-# complete TestError #-}+pattern TestError err <- UnsafeTestError False err where+  TestError err = withFrozenCallStack $ UnsafeTestError False err +-- | Match on skip requests.+pattern SkipTest :: HasCallStack => HasCallStack => Text -> TestError+pattern SkipTest err <- UnsafeTestError True err++{-# complete TestError, SkipTest #-}+ -- | Throw a 'TestError' with the call site's stack. testError ::   ∀ a r .@@ -33,3 +44,32 @@   Sem r a testError msg =   withFrozenCallStack $ throw (TestError msg)++-- | Skip the current test with a reason message.+--+-- This is intended for tests that require specific environmental conditions (e.g. programs in @$PATH@) that cannot be+-- checked at the test entry point.+-- The test will only be skipped if a fallback value is available, either via 'SkipTestDefaultValue' or an explicit+-- override.+skipTest ::+  ∀ a r .+  HasCallStack =>+  Member (Error TestError) r =>+  Text ->+  Sem r a+skipTest msg =+  withFrozenCallStack $ throw (UnsafeTestError True msg)++-- | Provides a default fallback value for skipped tests.+--+-- When a test calls 'skipTest', the runner can recover with the fallback value instead of failing.+-- The base instance returns 'Nothing', meaning skipped tests will fail.+-- The @()@ instance returns @'Just' ()@, allowing @'TestT' IO ()@ tests to be skipped silently.+class SkipTestDefaultValue a where+  skipTestDefaultValue :: Maybe a+  skipTestDefaultValue = Nothing++instance {-# overlappable #-} SkipTestDefaultValue a where++instance SkipTestDefaultValue () where+  skipTestDefaultValue = Just ()

@@ -5,12 +5,12 @@  import qualified Control.Exception as Base import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (ExceptT))+import Control.Monad.Trans.Except (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 Hedgehog.Internal.Property (Failure, Journal, TestT (..), failWith) import Path (Abs, Dir, Path, parseAbsDir, parseRelDir, (</>)) import Path.IO (canonicalizePath, createTempDir, getCurrentDir, getTempDir, removeDirRecur) import System.IO.Error (IOError)@@ -18,7 +18,7 @@ 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 Polysemy.Test.Data.TestError (SkipTestDefaultValue (..), TestError (..)) import qualified Polysemy.Test.Files as Files import Polysemy.Test.Hedgehog (rewriteHedgehog) @@ -102,11 +102,20 @@   ∀ m r a .   Monad m =>   Member (Hedgehog m) r =>+  Maybe a ->   Either TestError a ->   Sem r a-errorToFailure = \case+errorToFailure fallback = \case   Right a -> pure a-  Left (TestError e) -> liftH @m (failWith Nothing (toString e))+  Left (SkipTest msg)+    | Just fb <- fallback+    -> pure fb+    | otherwise+    -> liftH @m (failWith Nothing (cannotSkip <> toString msg))+  Left (TestError msg) ->+    liftH @m (failWith Nothing (toString msg))+  where+    cannotSkip = "Test requested to be skipped, but no default result was provided. Original message: "  failToFailure ::   Member (Error TestError) r =>@@ -114,41 +123,80 @@ failToFailure =   failToError (TestError . toText) --- |Run 'Hedgehog' and its dependent effects that correspond to the monad stack of 'TestT', exposing the monadic state.-unwrapLiftedTestT ::+-- |Like 'unwrapLiftedTestT', but with an explicit fallback value override for 'SkipTest'.+unwrapLiftedTestTSkippable ::   ∀ m r a .   Monad m =>+  SkipTestDefaultValue a =>   Member (Embed m) r =>+  Maybe a ->   Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->   Sem r (Journal, Either Failure a)-unwrapLiftedTestT =+unwrapLiftedTestTSkippable override =   runWriter .   runError .   rewriteHedgehog .   raise2Under .-  (>>= errorToFailure @m) .+  (>>= errorToFailure @m fallback) .   runError .   failToFailure+  where+    fallback = override <|> skipTestDefaultValue +-- |Run 'Hedgehog' and its dependent effects that correspond to the monad stack of 'TestT', exposing the monadic state.+unwrapLiftedTestT ::+  ∀ m r a .+  Monad m =>+  SkipTestDefaultValue a =>+  Member (Embed m) r =>+  Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->+  Sem r (Journal, Either Failure a)+unwrapLiftedTestT =+  unwrapLiftedTestTSkippable Nothing+ -- |Run 'Hedgehog' with 'unwrapLiftedTestT' and wrap it back into the 'TestT' stack. semToTestT ::   Monad m =>+  SkipTestDefaultValue a =>   Member (Embed m) r =>   (∀ x . Sem r x -> m x) ->   Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->   TestT m a-semToTestT runSem sem = do-  (journal, result) <- lift (runSem (unwrapLiftedTestT sem))+semToTestT =+  semToTestTSkippable Nothing++-- |Like 'semToTestT', but with an explicit fallback value override for 'SkipTest'.+semToTestTSkippable ::+  Monad m =>+  SkipTestDefaultValue a =>+  Member (Embed m) r =>+  Maybe a ->+  (∀ x . Sem r x -> m x) ->+  Sem (Fail : Error TestError : Hedgehog m : Error Failure : r) a ->+  TestT m a+semToTestTSkippable override runSem sem = do+  (journal, result) <- lift (runSem (unwrapLiftedTestTSkippable override sem))   TestT (ExceptT (result <$ MTL.tell journal))  -- |'Final' version of 'semToTestT'. semToTestTFinal ::   Monad m =>+  SkipTestDefaultValue a =>   Sem [Fail, Error TestError, Hedgehog m, Error Failure, Embed m, Final m] a ->   TestT m a semToTestTFinal =   semToTestT (runFinal . embedToFinal) +-- |Like 'semToTestTFinal', but with an explicit fallback value override for 'SkipTest'.+semToTestTFinalSkippable ::+  Monad m =>+  SkipTestDefaultValue a =>+  Maybe a ->+  Sem [Fail, Error TestError, Hedgehog m, Error Failure, Embed m, Final m] a ->+  TestT m a+semToTestTFinalSkippable override =+  semToTestTSkippable override (runFinal . embedToFinal)+ type TestEffects =   [     Test,@@ -164,24 +212,46 @@ -- |Convenience combinator that runs both 'Hedgehog' and 'Test' and rewraps the result in @'TestT' IO@, ready for -- execution as a property. runTest ::+  SkipTestDefaultValue a =>   Path Abs Dir ->   Sem TestEffects a ->   TestT IO a-runTest dir =-  semToTestTFinal .+runTest =+  runTestSkippable Nothing++-- |Like 'runTest', but with an explicit fallback value override for 'SkipTest'.+runTestSkippable ::+  SkipTestDefaultValue a =>+  Maybe a ->+  Path Abs Dir ->+  Sem TestEffects a ->+  TestT IO a+runTestSkippable override dir =+  semToTestTFinalSkippable override .   resourceToIOFinal .   interpretTest dir --- |Same as 'runTest', but uses 'interpretTestInSubdir'.-runTestInSubdir ::+-- |Like 'runTestInSubdir', but with an explicit fallback value override for 'SkipTest'.+runTestInSubdirSkippable ::+  SkipTestDefaultValue a =>+  Maybe a ->   Text ->   Sem TestEffects a ->   TestT IO a-runTestInSubdir prefix =-  semToTestTFinal .+runTestInSubdirSkippable override prefix =+  semToTestTFinalSkippable override .   resourceToIOFinal .   interpretTestInSubdir prefix +-- |Same as 'runTest', but uses 'interpretTestInSubdir'.+runTestInSubdir ::+  SkipTestDefaultValue a =>+  Text ->+  Sem TestEffects a ->+  TestT IO a+runTestInSubdir =+  runTestInSubdirSkippable Nothing+ callingTestDir ::   Members [Error TestError, Embed IO] r =>   HasCallStack =>@@ -201,24 +271,48 @@     parseDir cwd dirPrefix =       parseAbsDir dirPrefix <|> (cwd </>) <$> parseRelDir dirPrefix +-- |Like 'runTestAutoWith', but with an explicit fallback value override for 'SkipTest'.+runTestAutoWithSkippable ::+  HasCallStack =>+  SkipTestDefaultValue a =>+  Members [Resource, Embed IO] r =>+  Maybe a ->+  (∀ x . Sem r x -> IO x) ->+  Sem (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a ->+  TestT IO a+runTestAutoWithSkippable override runSem sem =+  semToTestTSkippable override runSem do+    base <- callingTestDir+    interpretTest base sem+ -- |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'. runTestAutoWith ::   HasCallStack =>+  SkipTestDefaultValue a =>   Members [Resource, Embed IO] r =>   (∀ x . Sem r x -> IO x) ->   Sem (Test : Fail : Error TestError : Hedgehog IO : Error Failure : r) a ->   TestT IO a-runTestAutoWith runSem sem =-  semToTestT runSem do-    base <- callingTestDir-    interpretTest base sem+runTestAutoWith =+  runTestAutoWithSkippable Nothing +-- |Like 'runTestAuto', but with an explicit fallback value override for 'SkipTest'.+runTestAutoSkippable ::+  HasCallStack =>+  SkipTestDefaultValue a =>+  Maybe a ->+  Sem [Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO] a ->+  TestT IO a+runTestAutoSkippable override =+  runTestAutoWithSkippable override (runFinal . resourceToIOFinal . embedToFinal)+ -- |Version of 'runTestAutoWith' specialized to @'Final' IO@ runTestAuto ::   HasCallStack =>+  SkipTestDefaultValue a =>   Sem [Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO] a ->   TestT IO a runTestAuto =-  runTestAutoWith (runFinal . resourceToIOFinal . embedToFinal)+  runTestAutoSkippable Nothing

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.1.+-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack  name:           polysemy-test-version:        0.10.0.1+version:        0.11.0.1 synopsis:       Polysemy effects for testing description:    See https://hackage.haskell.org/package/polysemy-test/docs/Polysemy-Test.html category:       Test@@ -55,8 +55,10 @@       LiberalTypeSynonyms       MonadComprehensions       MultiWayIf+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures@@ -72,18 +74,16 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-      OverloadedRecordDot-      NoFieldSelectors   ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      base >=4.16.4.0 && <4.21-    , hedgehog >=1.1.1 && <1.6-    , incipit-core >=0.3.0.0 && <0.7+      base >=4.17.2.1 && <4.22+    , hedgehog >=1.4 && <1.8+    , incipit-core >=0.4.1.0 && <0.8     , path >=0.9.1 && <0.10     , path-io >=1.6.3 && <1.9-    , polysemy >=1.6.0.0 && <1.10-    , tasty >=1.4.3 && <1.6-    , tasty-hedgehog >=1.1.0.0 && <1.5+    , polysemy >=1.9.1.0 && <1.10+    , tasty >=1.5.2 && <1.6+    , tasty-hedgehog >=1.4.0.2 && <1.5     , transformers >=0.5.6.2 && <0.7   mixins:       base hiding (Prelude)@@ -116,8 +116,10 @@       LiberalTypeSynonyms       MonadComprehensions       MultiWayIf+      NoFieldSelectors       OverloadedLabels       OverloadedLists+      OverloadedRecordDot       OverloadedStrings       PackageImports       PartialTypeSignatures@@ -133,17 +135,15 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-      OverloadedRecordDot-      NoFieldSelectors   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:-      base >=4.16.4.0 && <4.21-    , hedgehog >=1.1.1 && <1.6-    , incipit-core >=0.3.0.0 && <0.7+      base >=4.17.2.1 && <4.22+    , hedgehog >=1.4 && <1.8+    , incipit-core >=0.4.1.0 && <0.8     , path >=0.9.1 && <0.10-    , polysemy >=1.6.0.0 && <1.10-    , polysemy-test-    , tasty >=1.4.3 && <1.6+    , polysemy >=1.9.1.0 && <1.10+    , polysemy-test <0.12+    , tasty >=1.5.2 && <1.6   mixins:       base hiding (Prelude)     , incipit-core (IncipitCore as Prelude)