diff --git a/lib/Polysemy/Test.hs b/lib/Polysemy/Test.hs --- a/lib/Polysemy/Test.hs +++ b/lib/Polysemy/Test.hs @@ -33,7 +33,6 @@ assertClose, interpretHedgehog, -- * Running 'Hedgehog' and 'Test' as 'TestT' - runTestAutoWith, runTestAuto, runTest, runTestInSubdir, @@ -44,7 +43,8 @@ UnitTest, unitTest, unitTestTimes, - TestError(TestError), + TestError (TestError), + testError, ) where import qualified Data.Text as Text @@ -55,7 +55,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 (TestError (TestError), testError) import Polysemy.Test.Hedgehog ( assert, assertClose, @@ -81,7 +81,6 @@ interpretTestKeepTemp, runTest, runTestAuto, - runTestAutoWith, runTestInSubdir, semToTestT, semToTestTFinal, diff --git a/lib/Polysemy/Test/Data/TestError.hs b/lib/Polysemy/Test/Data/TestError.hs --- a/lib/Polysemy/Test/Data/TestError.hs +++ b/lib/Polysemy/Test/Data/TestError.hs @@ -1,10 +1,35 @@ {-# options_haddock prune #-} --- |TestError Newtype, Internal -module Polysemy.Test.Data.TestError where +-- |TestError data type, Internal +module Polysemy.Test.Data.TestError ( + TestError (TestError, UnsafeTestError), + testError, +) 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. +data TestError where + UnsafeTestError :: HasCallStack => 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. +pattern TestError :: HasCallStack => HasCallStack => Text -> TestError +pattern TestError err <- UnsafeTestError err where + TestError err = withFrozenCallStack $ UnsafeTestError err +{-# complete TestError #-} + +-- | 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) diff --git a/lib/Polysemy/Test/Hedgehog.hs b/lib/Polysemy/Test/Hedgehog.hs --- a/lib/Polysemy/Test/Hedgehog.hs +++ b/lib/Polysemy/Test/Hedgehog.hs @@ -220,7 +220,7 @@ data ValueIsNothing = ValueIsNothing - deriving Show + deriving stock Show -- |Like 'evalEither', but for 'Maybe'. evalMaybe :: diff --git a/lib/Polysemy/Test/Run.hs b/lib/Polysemy/Test/Run.hs --- a/lib/Polysemy/Test/Run.hs +++ b/lib/Polysemy/Test/Run.hs @@ -204,21 +204,11 @@ -- |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 => - 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 - --- |Version of 'runTestAutoWith' specialized to @'Final' IO@ runTestAuto :: HasCallStack => Sem [Test, Fail, Error TestError, Hedgehog IO, Error Failure, Embed IO, Resource, Final IO] a -> TestT IO a -runTestAuto = - runTestAutoWith (runFinal . resourceToIOFinal . embedToFinal) +runTestAuto sem = + semToTestT (runFinal . resourceToIOFinal . embedToFinal) do + base <- callingTestDir + interpretTest base sem diff --git a/polysemy-test.cabal b/polysemy-test.cabal --- a/polysemy-test.cabal +++ b/polysemy-test.cabal @@ -1,27 +1,25 @@ 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.35.2. -- -- see: https://github.com/sol/hpack name: polysemy-test -version: 0.7.0.0 -synopsis: Polysemy Effects for Testing +version: 0.8.0.0 +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: 2023 Torsten Schmits license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple extra-source-files: readme.md changelog.md -data-files: - test/fixtures/files/file1 source-repository head type: git @@ -41,83 +39,56 @@ 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 MultiWayIf - NamedFieldPuns OverloadedLabels OverloadedLists 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 + OverloadedRecordDot + NoFieldSelectors + 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 + base ==4.* + , hedgehog >=1.0.2 && <1.3 + , incipit-core >=0.4 && <0.6 + , path >=0.7 && <0.10 + , path-io >=1.7 && <1.9 + , polysemy >=1.3 && <1.10 + , tasty >=1.1 && <1.5 + , tasty-hedgehog >=1.1 && <1.5 , transformers 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 +99,49 @@ 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 MultiWayIf - NamedFieldPuns OverloadedLabels OverloadedLists 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 + 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.12 && <5 - , hedgehog >=1.0.2 - , incipit-core >=0.4 - , path >=0.7 - , polysemy >=1.3 + base ==4.* + , hedgehog >=1.0.2 && <1.3 + , incipit-core >=0.4 && <0.6 + , path >=0.7 && <0.10 + , polysemy >=1.3 && <1.10 , polysemy-test - , tasty >=1.1 + , tasty >=1.1 && <1.5 mixins: base hiding (Prelude) , incipit-core (IncipitCore as Prelude) , incipit-core hiding (IncipitCore) - default-language: Haskell2010 + default-language: GHC2021 diff --git a/test/Polysemy/Test/Test/HedgehogTest.hs b/test/Polysemy/Test/Test/HedgehogTest.hs --- a/test/Polysemy/Test/Test/HedgehogTest.hs +++ b/test/Polysemy/Test/Test/HedgehogTest.hs @@ -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 diff --git a/test/fixtures/files/file1 b/test/fixtures/files/file1 deleted file mode 100644 --- a/test/fixtures/files/file1 +++ /dev/null @@ -1,2 +0,0 @@ -file -content