diff --git a/components/core/Effectful/Zoo/DataLog/Api.hs b/components/core/Effectful/Zoo/DataLog/Api.hs index e43eedf..0aad9b2 100644 --- a/components/core/Effectful/Zoo/DataLog/Api.hs +++ b/components/core/Effectful/Zoo/DataLog/Api.hs @@ -19,7 +19,7 @@ import GHC.Stack qualified as GHC import HaskellWorks.Prelude import System.IO qualified as IO -dataLog :: () +dataLog :: forall i r. () => HasCallStack => r <: DataLog i => i diff --git a/components/core/Effectful/Zoo/FileSystem.hs b/components/core/Effectful/Zoo/FileSystem.hs index a4d0802..42e0187 100644 --- a/components/core/Effectful/Zoo/FileSystem.hs +++ b/components/core/Effectful/Zoo/FileSystem.hs @@ -17,6 +17,7 @@ module Effectful.Zoo.FileSystem runFileSystem, getCurrentDirectory, + canonicalizePath, ) where import Data.Aeson (FromJSON) @@ -191,4 +192,15 @@ getCurrentDirectory :: () getCurrentDirectory = withFrozenCallStack do unsafeFileSystemEff_ D.getCurrentDirectory & trapIO @IOException throw -{-# INLINE getCurrentDirectory #-} \ No newline at end of file +{-# INLINE getCurrentDirectory #-} + +canonicalizePath :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => FilePath + -> Eff r FilePath +canonicalizePath fp = withFrozenCallStack do + unsafeFileSystemEff_ (D.canonicalizePath fp) + & trapIO @IOException throw +{-# INLINE canonicalizePath #-} diff --git a/components/core/Effectful/Zoo/Log/Dynamic.hs b/components/core/Effectful/Zoo/Log/Dynamic.hs index e6907e8..f68207a 100644 --- a/components/core/Effectful/Zoo/Log/Dynamic.hs +++ b/components/core/Effectful/Zoo/Log/Dynamic.hs @@ -23,7 +23,7 @@ data Log i :: Effect where type instance DispatchOf (Log a) = Dynamic -runLog :: () +runLog :: forall i a r. () => r <: IOE => UnliftStrategy -> (CallStack -> LogMessage i -> Eff r ()) diff --git a/components/core/Effectful/Zoo/Resource.hs b/components/core/Effectful/Zoo/Resource.hs new file mode 100644 index 0000000..f7af2d0 --- /dev/null +++ b/components/core/Effectful/Zoo/Resource.hs @@ -0,0 +1,6 @@ +module Effectful.Zoo.Resource + ( Resource, + runResource, + ) where + +import Effectful.Resource diff --git a/components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs b/components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs index 0f83f1c..a1dbd38 100644 --- a/components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs +++ b/components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs @@ -2,22 +2,22 @@ module Effectful.Zoo.Hedgehog.Test.PropertySpec where +import Effectful.Zoo.Hedgehog import Effectful.Zoo.Hedgehog.Effect.Run import HaskellWorks.Prelude -import Hedgehog hiding (property, forAll) import Hedgehog qualified as H import Hedgehog.Gen qualified as G import Hedgehog.Range qualified as R -property_spec :: H.PropertyT IO () -property_spec = property do +tasty_property_spec :: PropertyT IO () +tasty_property_spec = property do a <- forAll $ G.int (R.linear 0 100) True === True a === a H.success -test_spec :: H.TestT IO () -test_spec = unit do +tasty_unit_spec :: TestT IO () +tasty_unit_spec = unit do True === True True === True H.success diff --git a/components/hedgehog-test/Main.hs b/components/hedgehog-test/Main.hs index 1d0568e..70c55f5 100644 --- a/components/hedgehog-test/Main.hs +++ b/components/hedgehog-test/Main.hs @@ -1,17 +1 @@ -module Main where - -import Effectful.Zoo.Hedgehog.Api.Tasty -import Effectful.Zoo.Hedgehog.Test.PropertySpec -import Test.Tasty (TestTree, defaultMain, testGroup) -import HaskellWorks.Prelude - -tests :: TestTree -tests = - testGroup "all" - [ toTestTree "Simple property spec" property_spec - , toTestTree "Simple test spec" test_spec - ] - -main :: IO () -main = - defaultMain tests +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs index c14d806..e027637 100644 --- a/components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api.hs @@ -1,5 +1,9 @@ module Effectful.Zoo.Hedgehog.Api - ( module Effectful.Zoo.Hedgehog.Api.Assert, + ( Property, + PropertyT, + Test, + TestT, + module Effectful.Zoo.Hedgehog.Api.Assert, module Effectful.Zoo.Hedgehog.Api.Hedgehog, module Effectful.Zoo.Hedgehog.Api.Failure, module Effectful.Zoo.Hedgehog.Api.Journal, @@ -9,3 +13,5 @@ import Effectful.Zoo.Hedgehog.Api.Assert import Effectful.Zoo.Hedgehog.Api.Failure import Effectful.Zoo.Hedgehog.Api.Hedgehog import Effectful.Zoo.Hedgehog.Api.Journal +import Effectful.Zoo.Hedgehog.Api.Tasty.Orphans () +import Hedgehog diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs index 64efa69..748905c 100644 --- a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs @@ -5,6 +5,7 @@ module Effectful.Zoo.Hedgehog.Api.Journal jot_, jotWithCallStack, + jotTextWithCallStack, jotString, jotString_, @@ -42,6 +43,11 @@ module Effectful.Zoo.Hedgehog.Api.Journal jotEachIO, jotEachIO_, + jotPkgInputFile, + jotPkgGoldenFile, + jotRootInputFile, + jotTempFile, + jotLogTextWithCallStack, jotShowDataLog, @@ -68,8 +74,12 @@ import Effectful.Zoo.DataLog.Dynamic import Effectful.Zoo.DataLog.Dynamic qualified as DataLog import Effectful.Zoo.Error.Static import Effectful.Zoo.Hedgehog.Api.Hedgehog +import Effectful.Zoo.Hedgehog.Data.PackagePath +import Effectful.Zoo.Hedgehog.Data.ProjectRoot +import Effectful.Zoo.Hedgehog.Data.Workspace import Effectful.Zoo.Hedgehog.Effect.Hedgehog import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Reader.Static import GHC.Stack qualified as GHC import HaskellWorks.Prelude import HaskellWorks.String @@ -88,6 +98,15 @@ jotWithCallStack :: forall m. () jotWithCallStack cs a = writeLog $ H.Annotation (H.getCaller cs) a +-- | Annotate the given string at the context supplied by the callstack. +jotTextWithCallStack :: forall m. () + => MonadTest m + => CallStack + -> Text + -> m () +jotTextWithCallStack cs a = + writeLog $ H.Annotation (H.getCaller cs) $ T.unpack a + -- | Annotate with the given string. jot :: forall m. () => HasCallStack @@ -588,6 +607,61 @@ jotEachIO_ f = !as <- evalIO f for_ as $ jotWithCallStack GHC.callStack . show +-- | Return the input file path after annotating it relative to the package directory +jotPkgInputFile :: forall r. () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Hedgehog + => r <: Reader PackagePath + => FilePath + -> Eff r FilePath +jotPkgInputFile fp = withFrozenCallStack $ do + PackagePath { filePath = pkgPath } <- ask + jotString_ $ pkgPath <> "/" <> fp + return fp + +-- | Return the golden file path after annotating it relative to the package directory +jotPkgGoldenFile :: forall r. () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Hedgehog + => r <: Reader PackagePath + => FilePath + -> Eff r FilePath +jotPkgGoldenFile fp = withFrozenCallStack $ do + PackagePath { filePath = pkgPath } <- ask + jotString_ $ pkgPath <> "/" <> fp + return fp + +jotRootInputFile :: forall r. () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Hedgehog + => r <: Reader ProjectRoot + => FilePath + -> Eff r FilePath +jotRootInputFile fp = withFrozenCallStack $ do + ProjectRoot { filePath = pkgPath } <- ask + jotString $ pkgPath <> "/" <> fp + +-- | Return the test file path after annotating it relative to the project root directory +jotTempFile :: forall r. () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Hedgehog + => r <: Reader Workspace + => FilePath + -> Eff r FilePath +jotTempFile fp = withFrozenCallStack $ do + Workspace { filePath = workspace } <- ask + let relPath = workspace <> "/" <> fp + jotString_ $ workspace <> "/" <> relPath + return relPath + jotLogTextWithCallStack :: forall m. () => HasCallStack => MonadTest m diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty/Orphans.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty/Orphans.hs new file mode 100644 index 0000000..cca75ed --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty/Orphans.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Effectful.Zoo.Hedgehog.Api.Tasty.Orphans where + +import Data.Monoid +import HaskellWorks.Prelude +import Hedgehog (PropertyT, TestT) +import Hedgehog qualified as H +import Test.Tasty.Discover +import Test.Tasty.Discover.TastyInfo +import Test.Tasty.Hedgehog + +instance Tasty (PropertyT IO ()) where + tasty info = pure . testProperty testName . H.property + where testName = fromMaybe "" $ getLast info.name + +instance Tasty (TestT IO ()) where + tasty info = tasty info . H.test diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Run.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Run.hs index 6aabf36..8b2c7f5 100644 --- a/components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Run.hs +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Run.hs @@ -18,22 +18,34 @@ import Effectful import Effectful.Concurrent import Effectful.Concurrent.STM import Effectful.Concurrent.STM qualified as CC +import Effectful.Environment +import Effectful.FileSystem import Effectful.Zoo.Core import Effectful.Zoo.Error.Static +import Effectful.Zoo.Hedgehog.Api.Failure +import Effectful.Zoo.Hedgehog.Api.Journal import Effectful.Zoo.Hedgehog.Api.MonadAssertion import Effectful.Zoo.Hedgehog.Effect.Hedgehog import Effectful.Zoo.Hedgehog.Effect.HedgehogGen +import Effectful.Zoo.Log.Data.LogMessage +import Effectful.Zoo.Log.Dynamic +import Effectful.Zoo.Resource import HaskellWorks.Control.Monad import HaskellWorks.Prelude +import HaskellWorks.ToText import Hedgehog (Gen) import Hedgehog qualified as H import Hedgehog.Internal.Property qualified as H property :: () => Eff - [ HedgehogGen + [ Log Text + , HedgehogGen , Hedgehog , Error H.Failure + , Resource + , FileSystem + , Environment , Concurrent , IOE ] () @@ -43,7 +55,16 @@ property f = do tvAction <- liftIO IO.newEmptyTMVarIO CEL.bracket do liftIO $ IO.forkFinally - (f & runHedgehogGenProperty tvAction & runHedgehogProperty tvAction & runError @H.Failure & runConcurrent & runEff) + do f + & runLog @Text (ConcUnlift Persistent Unlimited) logTextToHedgehog + & runHedgehogGenProperty tvAction + & runHedgehogProperty tvAction + & runError @H.Failure + & runResource + & runFileSystem + & runEnvironment + & runConcurrent + & runEff (liftIO . IO.atomically . IO.putTMVar tvResult) do liftIO . IO.killThread do \_ -> do @@ -65,10 +86,25 @@ property f = do Just (Right (Right (Left (_, e)))) -> throwAssertion e Just (Right (Right (Right a))) -> pure $ Just a +logTextToHedgehog :: () + => r <: Concurrent + => r <: Hedgehog + => r <: Error Failure + => CallStack + -> LogMessage Text + -> Eff r () +logTextToHedgehog callStack msg = do + let LogMessage severity text = msg + jotTextWithCallStack callStack $ toText severity <> " " <> text + unit :: () => Eff - [ Hedgehog + [ Log Text + , Hedgehog , Error H.Failure + , Resource + , FileSystem + , Environment , Concurrent , IOE ] () @@ -78,7 +114,14 @@ unit f = do tvAction <- liftIO IO.newEmptyTMVarIO CEL.bracket do liftIO $ IO.forkFinally - (f & runHedgehogUnit tvAction & runError @H.Failure & runConcurrent & runEff) + do f & runLog @Text (ConcUnlift Persistent Unlimited) logTextToHedgehog + & runHedgehogUnit tvAction + & runError @H.Failure + & runResource + & runFileSystem + & runEnvironment + & runConcurrent + & runEff (liftIO . IO.atomically . IO.putTMVar tvResult) do liftIO . IO.killThread do \_ -> do diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal index b607679..ec89b6e 100644 --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -58,6 +58,7 @@ common resourcet { build-depends: resourcet >= common resourcet-effectful { build-depends: resourcet-effectful >= 1.0.1 && < 2 } common stm { build-depends: stm >= 2.5.1 && < 3 } common tasty { build-depends: tasty >= 1.5 && < 2 } +common tasty-discover { build-depends: tasty-discover >= 5 && < 6 } common tasty-hedgehog { build-depends: tasty-hedgehog >= 1.1.0.0 && < 1.5 } common temporary { build-depends: temporary >= 1.3 && < 2 } common testcontainers { build-depends: testcontainers >= 0.5 && < 0.6 } @@ -133,6 +134,7 @@ library core effectful, hw-prelude, process, + resourcet-effectful, text, temporary, time, @@ -175,6 +177,7 @@ library core Effectful.Zoo.Prim Effectful.Zoo.Process Effectful.Zoo.Reader.Static + Effectful.Zoo.Resource Effectful.Zoo.Unsafe ghc-options: -fplugin=Effectful.Plugin hs-source-dirs: components/core @@ -298,6 +301,7 @@ library hedgehog lifted-base, resourcet, stm, + tasty-discover, tasty-hedgehog, tasty, text, @@ -325,6 +329,7 @@ library hedgehog Effectful.Zoo.Hedgehog.Api.Range Effectful.Zoo.Hedgehog.Api.Stack Effectful.Zoo.Hedgehog.Api.Tasty + Effectful.Zoo.Hedgehog.Api.Tasty.Orphans Effectful.Zoo.Hedgehog.Api.Workspace Effectful.Zoo.Hedgehog.Data Effectful.Zoo.Hedgehog.Data.PackagePath @@ -370,14 +375,16 @@ library testcontainers-localstack hs-source-dirs: components/testcontainers-localstack test-suite effectful-zoo-test - import: project-config, + import: base, project-config, effectful-zoo-hedgehog, hedgehog, hw-prelude, tasty, + tasty-discover, type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Effectful.Zoo.Hedgehog.Test.PropertySpec + build-tool-depends: tasty-discover:tasty-discover hs-source-dirs: components/hedgehog-test ghc-options: -threaded -rtsopts