Merge pull request #53 from haskell-works/newhoggy/support-for-proper…

…ty-testing Support for property testing
haskell-works · Nov 4, 2024 · a6062d7 · a6062d7
2 parents ba77aca + 9e9774f
commit a6062d7
Show file tree

Hide file tree

Showing 6 changed files with 74 additions and 3 deletions.
diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog.hs
@@ -1,6 +1,7 @@
 
 module HaskellWorks.Polysemy.Hedgehog
-  ( propertyOnce,
+  ( property,
+    propertyOnce,
 
     Hedgehog,
 
@@ -26,8 +27,10 @@ module HaskellWorks.Polysemy.Hedgehog
     trapFailJsonPretty,
     trapFailYaml,
 
+    success,
     failure,
     failMessage,
+    assert,
     (===),
 
     byDeadlineIO,
@@ -44,6 +47,9 @@ module HaskellWorks.Polysemy.Hedgehog
     evalIO_,
     evalM_,
 
+    classify,
+    forAll,
+
     catchAssertion,
     throwAssertion,
     trapAssertion,

diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs
@@ -4,6 +4,7 @@
 module HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog
   ( Hedgehog,
 
+    assert,
     assertEquals,
     catchAssertion,
     eval,
@@ -15,6 +16,10 @@ module HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog
     throwAssertion,
     trapAssertion,
 
+    forAll,
+    classify,
+    success,
+
     hedgehogToMonadTestFinal,
     hedgehogToPropertyFinal,
     hedgehogToTestFinal,
@@ -36,6 +41,10 @@ import           Polysemy
 import           Polysemy.Final
 
 data Hedgehog m rv where
+  Assert :: HasCallStack
+    => Bool
+    -> Hedgehog m ()
+
   AssertEquals :: (HasCallStack, Eq a, Show a)
     => a
     -> a
@@ -46,6 +55,11 @@ data Hedgehog m rv where
     -> (H.Failure -> m a)
     -> Hedgehog m a
 
+  Classify ::  HasCallStack
+    => H.LabelName
+    -> Bool
+    -> Hedgehog m ()
+
   Eval :: HasCallStack
     => a
     -> Hedgehog m a
@@ -95,6 +109,8 @@ hedgehogToMonadTestFinal :: forall a r m. ()
   => Sem (Hedgehog ': r) a
   -> Sem r a
 hedgehogToMonadTestFinal = interpretFinal \case
+  Assert t ->
+    liftS $ H.assert t
   AssertEquals a b ->
     liftS $ a H.=== b
   CatchAssertion f h -> do
@@ -103,6 +119,8 @@ hedgehogToMonadTestFinal = interpretFinal \case
     h' <- bindS h
     pure $ I.catchAssertion f' $ \e -> do
       h' (e <$ s)
+  Classify labelName b ->
+    liftS $ H.classify labelName b
   Eval a ->
     liftS $ H.eval a
   EvalIO f ->
@@ -138,3 +156,18 @@ catchExToPropertyFinal :: forall a r. ()
   -> Sem r a
 catchExToPropertyFinal = catchExToFinal
 {-# INLINE catchExToPropertyFinal #-}
+
+forAll :: forall a r. ()
+  => Member (Embed (H.PropertyT IO)) r
+  => Member Hedgehog r
+  => Show a
+  => H.Gen a
+  -> Sem r a
+forAll =
+  embed . H.forAll
+
+success :: forall r. ()
+  => Member Hedgehog r
+  => Sem r ()
+success =
+  pure ()
diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Gen.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Gen.hs
@@ -0,0 +1,5 @@
+module HaskellWorks.Polysemy.Hedgehog.Gen
+  ( module G
+  ) where
+
+import           Hedgehog.Gen as G
diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs
@@ -1,5 +1,6 @@
 module HaskellWorks.Polysemy.Hedgehog.Property
   ( Property,
+    property,
     propertyOnce,
   ) where
 
@@ -19,7 +20,7 @@ import           Polysemy.Log
 import           Polysemy.Resource
 import           Polysemy.Time.Interpreter.Ghc
 
-propertyOnce :: ()
+property :: ()
   => Sem
         [ Log
         , DataLog (LogEntry LogMessage)
@@ -32,7 +33,7 @@ propertyOnce :: ()
         , Final (H.PropertyT IO)
         ] ()
   -> H.Property
-propertyOnce f =
+property f =
     f & interpretLogDataLog
       & setLogLevelFromEnv "LOG_LEVEL" Info
       & interpretDataLogHedgehog formatLogEntry getLogEntryCallStack
@@ -45,3 +46,20 @@ propertyOnce f =
       & runFinal
       & H.property
       & H.withTests 1
+
+propertyOnce :: ()
+  => Sem
+        [ Log
+        , DataLog (LogEntry LogMessage)
+        , DataLog Text
+        , GhcTime
+        , Hedgehog
+        , Embed IO
+        , Embed (H.PropertyT IO)
+        , Resource
+        , Final (H.PropertyT IO)
+        ] ()
+  -> H.Property
+propertyOnce f =
+    f & property
+      & H.withTests 1
diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Range.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Range.hs
@@ -0,0 +1,5 @@
+module HaskellWorks.Polysemy.Hedgehog.Range
+  ( module R
+  ) where
+
+import           Hedgehog.Range as R
diff --git a/hw-polysemy.cabal b/hw-polysemy.cabal
@@ -201,11 +201,13 @@ library hedgehog
                         HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog.Internal
                         HaskellWorks.Polysemy.Hedgehog.Effect.Log
                         HaskellWorks.Polysemy.Hedgehog.Eval
+                        HaskellWorks.Polysemy.Hedgehog.Gen
                         HaskellWorks.Polysemy.Hedgehog.Golden
                         HaskellWorks.Polysemy.Hedgehog.Jot
                         HaskellWorks.Polysemy.Hedgehog.Process
                         HaskellWorks.Polysemy.Hedgehog.Process.Internal
                         HaskellWorks.Polysemy.Hedgehog.Property
+                        HaskellWorks.Polysemy.Hedgehog.Range
                         HaskellWorks.Polysemy.Hedgehog.Test
                         HaskellWorks.Polysemy.Hedgehog.Time
                         HaskellWorks.Polysemy.Hedgehog.Ulid
@@ -289,11 +291,13 @@ library
                         HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog.Internal,
                         HaskellWorks.Polysemy.Hedgehog.Effect.Log,
                         HaskellWorks.Polysemy.Hedgehog.Eval,
+                        HaskellWorks.Polysemy.Hedgehog.Gen,
                         HaskellWorks.Polysemy.Hedgehog.Golden,
                         HaskellWorks.Polysemy.Hedgehog.Jot,
                         HaskellWorks.Polysemy.Hedgehog.Process,
                         HaskellWorks.Polysemy.Hedgehog.Process.Internal,
                         HaskellWorks.Polysemy.Hedgehog.Property,
+                        HaskellWorks.Polysemy.Hedgehog.Range,
                         HaskellWorks.Polysemy.Hedgehog.Test,
                         HaskellWorks.Polysemy.Hedgehog.Workspace,
                         HaskellWorks.Polysemy.Prelude,