From 118c9f97f94dabd930bc09d5710633e55095e536 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Sat, 23 Mar 2024 11:39:49 +0100
Subject: [PATCH] Add `quickCheckCounterexample`

---
 src/Test/QuickCheck.hs          |  4 ++++
 src/Test/QuickCheck/Property.hs |  7 +++++++
 src/Test/QuickCheck/Test.hs     | 17 +++++++++++++++++
 3 files changed, 28 insertions(+)

diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs
index 50032201..333d5fdf 100644
--- a/src/Test/QuickCheck.hs
+++ b/src/Test/QuickCheck.hs
@@ -45,6 +45,10 @@ module Test.QuickCheck
   , quickCheckWith
   , quickCheckWithResult
   , quickCheckResult
+#ifndef NO_TYPEABLE
+  , quickCheckCounterexample
+  , quickCheckWithCounterexample
+#endif
   , recheck
   , isSuccess
     -- ** Running tests verbosely
diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs
index e1217680..c57778e7 100644
--- a/src/Test/QuickCheck/Property.hs
+++ b/src/Test/QuickCheck/Property.hs
@@ -269,6 +269,13 @@ coerceCounterexample (Cex a) = case cast a of
 castCounterexample :: Typeable a => Counterexample -> Maybe a
 castCounterexample (Cex a) = cast a
 
+data Counterexamples = NoCounterexamples
+                     | forall a. (Typeable a, Show a) => a :! Counterexamples
+
+toCounterexamples :: [Counterexample] -> Counterexamples
+toCounterexamples [] = NoCounterexamples
+toCounterexamples (Cex a : ces) = a :! toCounterexamples ces
+
 #define COUNTEREXAMPLES(a) , theCounterexamples a
 #else
 #define COUNTEREXAMPLES(a)
diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs
index 0e4f5015..3ad61261 100644
--- a/src/Test/QuickCheck/Test.hs
+++ b/src/Test/QuickCheck/Test.hs
@@ -202,6 +202,23 @@ quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
 quickCheckWithResult a p =
   withState a (\s -> test s (property p))
 
+#ifndef NO_TYPEABLE
+-- | Test a property and get counterexamples as a result. Can be used like:
+--
+-- @
+-- $> x :! _ <- quickCheckCounterexample $ \ x -> withCounterexample (x :: Int) (x > 0)
+-- *** Failed! Falsified (after 1 test):
+-- 0
+-- $> x
+-- 0
+quickCheckCounterexample :: Testable prop => prop -> IO Counterexamples
+quickCheckCounterexample = quickCheckWithCounterexample stdArgs
+
+-- | Test a property, using test arguments, and get counterexamples as a result.
+quickCheckWithCounterexample :: Testable prop => Args -> prop -> IO Counterexamples
+quickCheckWithCounterexample args p = toCounterexamples . counterexamples <$> quickCheckWithResult args p
+#endif
+
 -- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'.
 recheck :: Testable prop => Result -> prop -> IO ()
 recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once