From 428152ffb3903e44588f80826864d52de4b96ebf Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Thu, 21 Mar 2024 13:49:57 +0100
Subject: [PATCH 1/3] introduce `suchThatDiscard`

---
 src/Test/QuickCheck.hs     |  1 +
 src/Test/QuickCheck/Gen.hs | 11 +++++++++++
 tests/DiscardRatio.hs      |  4 ++++
 3 files changed, 16 insertions(+)

diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs
index 0ce960f1..3c0eb24c 100644
--- a/src/Test/QuickCheck.hs
+++ b/src/Test/QuickCheck.hs
@@ -112,6 +112,7 @@ module Test.QuickCheck
   , suchThat
   , suchThatMap
   , suchThatMaybe
+  , suchThatDiscard
   , applyArbitrary2
   , applyArbitrary3
   , applyArbitrary4
diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs
index aca58183..79e6bee6 100644
--- a/src/Test/QuickCheck/Gen.hs
+++ b/src/Test/QuickCheck/Gen.hs
@@ -35,6 +35,7 @@ import Control.Applicative
   ( Applicative(..) )
 
 import Test.QuickCheck.Random
+import Test.QuickCheck.Exception
 import Data.List (sortBy)
 import Data.Ord
 import Data.Maybe
@@ -293,6 +294,16 @@ gen `suchThatMaybe` p = sized (\n -> try n (2*n))
         x <- resize m gen
         if p x then return (Just x) else try (m+1) n
 
+-- | Tries to generate a value that satisfies a predicate.
+-- If it fails to do so it discards the test case if the result
+-- is used in the test.
+suchThatDiscard :: Gen a -> (a -> Bool) -> Gen a
+suchThatDiscard g p = do
+  a <- g
+  if p a
+  then pure a
+  else discard
+
 -- | Randomly uses one of the given generators. The input list
 -- must be non-empty.
 oneof :: WITHCALLSTACK([Gen a] -> Gen a)
diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs
index db6f84b5..83a0e53d 100644
--- a/tests/DiscardRatio.hs
+++ b/tests/DiscardRatio.hs
@@ -49,3 +49,7 @@ main = do
   putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True"
   quickCheckYes $ withDiscardRatio 40 p50
   quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50
+
+  quickCheckNo $ forAll  (choose (1 :: Int, 10) `suchThatDiscard` const False) $ \ x -> x == x
+  quickCheckYes $ forAll (choose (1 :: Int, 10) `suchThatDiscard` const False) $ \ _ -> True
+  quickCheckYes $ forAll (choose (1 :: Int, 10) `suchThatDiscard` (> 3))       $ \ x -> x == x

From 698b171a5075e3ef67eb435f45ddf2b5a08c6a77 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Thu, 4 Apr 2024 10:26:11 +0200
Subject: [PATCH 2/3] discardUnless

---
 src/Test/QuickCheck.hs     | 2 +-
 src/Test/QuickCheck/Gen.hs | 4 ++--
 tests/DiscardRatio.hs      | 6 +++---
 3 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs
index 3c0eb24c..06d77eca 100644
--- a/src/Test/QuickCheck.hs
+++ b/src/Test/QuickCheck.hs
@@ -112,7 +112,7 @@ module Test.QuickCheck
   , suchThat
   , suchThatMap
   , suchThatMaybe
-  , suchThatDiscard
+  , discardUnless
   , applyArbitrary2
   , applyArbitrary3
   , applyArbitrary4
diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs
index 79e6bee6..fc867917 100644
--- a/src/Test/QuickCheck/Gen.hs
+++ b/src/Test/QuickCheck/Gen.hs
@@ -297,8 +297,8 @@ gen `suchThatMaybe` p = sized (\n -> try n (2*n))
 -- | Tries to generate a value that satisfies a predicate.
 -- If it fails to do so it discards the test case if the result
 -- is used in the test.
-suchThatDiscard :: Gen a -> (a -> Bool) -> Gen a
-suchThatDiscard g p = do
+discardUnless :: Gen a -> (a -> Bool) -> Gen a
+discardUnless g p = do
   a <- g
   if p a
   then pure a
diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs
index 83a0e53d..0c776cd9 100644
--- a/tests/DiscardRatio.hs
+++ b/tests/DiscardRatio.hs
@@ -50,6 +50,6 @@ main = do
   quickCheckYes $ withDiscardRatio 40 p50
   quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50
 
-  quickCheckNo $ forAll  (choose (1 :: Int, 10) `suchThatDiscard` const False) $ \ x -> x == x
-  quickCheckYes $ forAll (choose (1 :: Int, 10) `suchThatDiscard` const False) $ \ _ -> True
-  quickCheckYes $ forAll (choose (1 :: Int, 10) `suchThatDiscard` (> 3))       $ \ x -> x == x
+  quickCheckNo $ forAll  (choose (1 :: Int, 10) `discardUnless` const False) $ \ x -> x == x
+  quickCheckYes $ forAll (choose (1 :: Int, 10) `discardUnless` const False) $ \ _ -> True
+  quickCheckYes $ forAll (choose (1 :: Int, 10) `discardUnless` (> 3))       $ \ x -> x == x

From 8a992e844bc0c955a532e1220eae07fc1eb4af07 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Thu, 4 Apr 2024 10:27:38 +0200
Subject: [PATCH 3/3] slightly faster

---
 src/Test/QuickCheck/Gen.hs | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs
index fc867917..ba0d60e3 100644
--- a/src/Test/QuickCheck/Gen.hs
+++ b/src/Test/QuickCheck/Gen.hs
@@ -298,11 +298,7 @@ gen `suchThatMaybe` p = sized (\n -> try n (2*n))
 -- If it fails to do so it discards the test case if the result
 -- is used in the test.
 discardUnless :: Gen a -> (a -> Bool) -> Gen a
-discardUnless g p = do
-  a <- g
-  if p a
-  then pure a
-  else discard
+discardUnless g p = (\ a -> if p a then a else discard) <$> g
 
 -- | Randomly uses one of the given generators. The input list
 -- must be non-empty.