From 56f3eedcd7a0724171613e72afdf6855cf5abbe6 Mon Sep 17 00:00:00 2001
From: Pablo Lamela <pablo.lamela@iohk.io>
Date: Tue, 24 Sep 2024 17:49:49 +0200
Subject: [PATCH] Add `expectFailure` combinator

---
 src/Hedgehog/Extras/Test/Base.hs | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs
index 5e364e0f..6843fcff 100644
--- a/src/Hedgehog/Extras/Test/Base.hs
+++ b/src/Hedgehog/Extras/Test/Base.hs
@@ -48,6 +48,7 @@ module Hedgehog.Extras.Test.Base
 
   , failWithCustom
   , failMessage
+  , expectFailure
 
   , assertByDeadlineM
   , assertByDeadlineIO
@@ -140,6 +141,14 @@ failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs)
 failMessage :: MonadTest m => CallStack -> String -> m a
 failMessage cs = failWithCustom cs Nothing
 
+-- | Invert the behavior of a property: success becomes failure and vice versa.
+expectFailure :: HasCallStack => H.TestT IO m -> H.PropertyT IO ()
+expectFailure prop = GHC.withFrozenCallStack $ do
+  (res, _) <- H.evalIO $ H.runTestT prop
+  case res of
+    Left _ -> pure () -- Property failed so we succeed
+    _ -> H.failWith Nothing "Expected the test to fail but it passed" -- Property passed but we expected a failure
+
 -- | Create a workspace directory which will exist for at least the duration of
 -- the supplied block.
 --