introduce discardUnless

src/Test/QuickCheck.hs

@@ -112,6 +112,7 @@ module Test.QuickCheck
   , suchThat
   , suchThatMap
   , suchThatMaybe
+  , suchThatDiscard
   , applyArbitrary2
   , applyArbitrary3
   , applyArbitrary4

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)

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