New success and classify function

haskell-works · Nov 4, 2024 · 9e9774f · 9e9774f
1 parent 8557539
commit 9e9774f
Show file tree

Hide file tree

Showing 2 changed files with 17 additions and 0 deletions.
diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog.hs
@@ -27,6 +27,7 @@ module HaskellWorks.Polysemy.Hedgehog
     trapFailJsonPretty,
     trapFailYaml,
 
+    success,
     failure,
     failMessage,
     assert,
@@ -46,6 +47,7 @@ module HaskellWorks.Polysemy.Hedgehog
     evalIO_,
     evalM_,
 
+    classify,
     forAll,
 
     catchAssertion,

diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Effect/Hedgehog.hs
@@ -17,6 +17,8 @@ module HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog
     trapAssertion,
 
     forAll,
+    classify,
+    success,
 
     hedgehogToMonadTestFinal,
     hedgehogToPropertyFinal,
@@ -53,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
@@ -112,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 ->
@@ -156,3 +165,9 @@ forAll :: forall a r. ()
   -> Sem r a
 forAll =
   embed . H.forAll
+
+success :: forall r. ()
+  => Member Hedgehog r
+  => Sem r ()
+success =
+  pure ()