polysemy-test 0.7.0.0 → 0.11.0.1
raw patch · 7 files changed
Files
- changelog.md +0/−2
- lib/Polysemy/Test.hs +21/−3
- lib/Polysemy/Test/Data/TestError.hs +72/−7
- lib/Polysemy/Test/Hedgehog.hs +1/−1
- lib/Polysemy/Test/Run.hs +116/−22
- polysemy-test.cabal +31/−83
- test/Polysemy/Test/Test/HedgehogTest.hs +14/−3
changelog.md view
@@ -1,5 +1,3 @@-# Unreleased- # 0.7.0.0 * Add `unitTestTimes`, converting `UnitTest` to `TestTree` with a specified number of test runs.
lib/Polysemy/Test.hs view
@@ -34,17 +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@@ -55,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))+import Polysemy.Test.Data.TestError (SkipTestDefaultValue (..), TestError (TestError, SkipTest), skipTest, testError) import Polysemy.Test.Hedgehog ( assert, assertClose,@@ -81,11 +91,18 @@ interpretTestKeepTemp, runTest, runTestAuto,+ runTestAutoSkippable, runTestAutoWith,+ runTestAutoWithSkippable, runTestInSubdir,+ runTestInSubdirSkippable,+ runTestSkippable, semToTestT, semToTestTFinal,+ semToTestTFinalSkippable,+ semToTestTSkippable, unwrapLiftedTestT,+ unwrapLiftedTestTSkippable, ) -- |Convenience type alias for tests.@@ -131,8 +148,9 @@ {- $intro @ import Path (relfile)-import Polysemy.Test import Test.Tasty (defaultMain)++import Polysemy.Test test_fixture :: UnitTest test_fixture =
lib/Polysemy/Test/Data/TestError.hs view
@@ -1,10 +1,75 @@ {-# options_haddock prune #-} --- |TestError Newtype, Internal-module Polysemy.Test.Data.TestError where+-- |TestError data type, Internal+module Polysemy.Test.Data.TestError (+ TestError (TestError, SkipTest, UnsafeTestError),+ testError,+ skipTest,+ SkipTestDefaultValue (..),+) where --- |An error that occured in the test machinery.-newtype TestError =- TestError { unTestError :: Text }- deriving (Eq, Show)- deriving newtype (IsString)+-- | An error that occurred in the test machinery.+--+-- 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 => 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 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 .+ HasCallStack =>+ Member (Error TestError) r =>+ Text ->+ 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 ()
lib/Polysemy/Test/Hedgehog.hs view
@@ -220,7 +220,7 @@ data ValueIsNothing = ValueIsNothing- deriving Show+ deriving stock Show -- |Like 'evalEither', but for 'Maybe'. evalMaybe ::
lib/Polysemy/Test/Run.hs view
@@ -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
polysemy-test.cabal view
@@ -1,19 +1,19 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- 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.7.0.0-synopsis: Polysemy Effects for Testing+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 homepage: https://github.com/tek/polysemy-test#readme bug-reports: https://github.com/tek/polysemy-test/issues author: Torsten Schmits maintainer: hackage@tryp.io-copyright: 2022 Torsten Schmits+copyright: 2025 Torsten Schmits license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple@@ -41,83 +41,57 @@ default-extensions: AllowAmbiguousTypes ApplicativeDo- BangPatterns- BinaryLiterals BlockArguments- ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields- DoAndIfThenElse DuplicateRecordFields- EmptyCase- EmptyDataDecls- ExistentialQuantification- FlexibleContexts- FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving- InstanceSigs- KindSignatures LambdaCase LiberalTypeSynonyms- MultiParamTypeClasses+ MonadComprehensions MultiWayIf- NamedFieldPuns+ NoFieldSelectors OverloadedLabels OverloadedLists+ OverloadedRecordDot OverloadedStrings PackageImports PartialTypeSignatures- PatternGuards PatternSynonyms- PolyKinds QuantifiedConstraints QuasiQuotes- RankNTypes RecordWildCards RecursiveDo RoleAnnotations- ScopedTypeVariables- StandaloneDeriving TemplateHaskell- TupleSections- TypeApplications TypeFamilies TypeFamilyDependencies- TypeOperators- TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -Wall -Wredundant-constraints -Wunused-packages+ ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends:- base >=4.12 && <5- , hedgehog >=1.0.2- , incipit-core >=0.4- , path >=0.7- , path-io >=0.2- , polysemy >=1.3- , tasty >=1.1- , tasty-hedgehog >=1.0.0.2- , transformers+ 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.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) , incipit-core (IncipitCore as Prelude) , incipit-core hiding (IncipitCore)- default-language: Haskell2010+ default-language: GHC2021 -test-suite polysemy-test-unit+test-suite polysemy-test-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules:@@ -128,76 +102,50 @@ default-extensions: AllowAmbiguousTypes ApplicativeDo- BangPatterns- BinaryLiterals BlockArguments- ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields- DoAndIfThenElse DuplicateRecordFields- EmptyCase- EmptyDataDecls- ExistentialQuantification- FlexibleContexts- FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving- InstanceSigs- KindSignatures LambdaCase LiberalTypeSynonyms- MultiParamTypeClasses+ MonadComprehensions MultiWayIf- NamedFieldPuns+ NoFieldSelectors OverloadedLabels OverloadedLists+ OverloadedRecordDot OverloadedStrings PackageImports PartialTypeSignatures- PatternGuards PatternSynonyms- PolyKinds QuantifiedConstraints QuasiQuotes- RankNTypes RecordWildCards RecursiveDo RoleAnnotations- ScopedTypeVariables- StandaloneDeriving TemplateHaskell- TupleSections- TypeApplications TypeFamilies TypeFamilyDependencies- TypeOperators- TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -Wall -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+ 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.12 && <5- , hedgehog >=1.0.2- , incipit-core >=0.4- , path >=0.7- , polysemy >=1.3- , polysemy-test- , tasty >=1.1+ 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.9.1.0 && <1.10+ , polysemy-test <0.12+ , tasty >=1.5.2 && <1.6 mixins: base hiding (Prelude) , incipit-core (IncipitCore as Prelude) , incipit-core hiding (IncipitCore)- default-language: Haskell2010+ default-language: GHC2021
test/Polysemy/Test/Test/HedgehogTest.hs view
@@ -1,12 +1,13 @@ module Polysemy.Test.Test.HedgehogTest where -import Hedgehog (TestT, assert)-import Hedgehog.Internal.Property (Failure (Failure), runTestT)+import Hedgehog (TestT, assert, (===))+import Hedgehog.Internal.Property (Failure (Failure), failWith, runTestT)+import Hedgehog.Internal.Source (spanStartLine) import Polysemy.Test (UnitTest, runTestAuto, (/==)) import Polysemy.Test.Data.Hedgehog (Hedgehog) import Polysemy.Test.Data.Test (Test)-import Polysemy.Test.Data.TestError (TestError)+import Polysemy.Test.Data.TestError (TestError (TestError)) import Polysemy.Test.Hedgehog (assertClose) import Polysemy.Test.Run (semToTestTFinal) @@ -50,3 +51,13 @@ test_close = do hedgehogSuccess (assertClose @_ @IO (1.11111 :: Double) 1.111111111111) hedgehogFail (assertClose @_ @IO (1.11 :: Double) 1.111111111111)++test_stack :: UnitTest+test_stack = do+ (r, _) <- liftIO $ runTestT $ runTestAuto do+ throw (TestError "error")+ pure False+ case r of+ Right _ -> failWith Nothing "not an error"+ Left (Failure Nothing _ _) -> failWith Nothing "no source span"+ Left (Failure (Just spn) _ _) -> 58 === spanStartLine spn