Hedgehog improvements

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

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 #-}
+{-# 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 #-}

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 ())

components/core/Effectful/Zoo/Resource.hs

@@ -0,0 +1,6 @@
+module Effectful.Zoo.Resource
+  ( Resource,
+    runResource,
+  ) where
+
+import Effectful.Resource

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

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 #-}

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

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

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

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

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