add withDiscardRatio with a similar interface to withMaxSuccess

src/Test/QuickCheck.hs

@@ -271,6 +271,7 @@ module Test.QuickCheck
   , withMaxSuccess
   , within
   , discardAfter
+  , withDiscardRatio
   , once
   , again
   , mapSize

src/Test/QuickCheck/Property.hs

@@ -257,31 +257,33 @@ data CallbackKind = Counterexample    -- ^ Affected by the 'verbose' combinator
 -- | The result of a single test.
 data Result
   = MkResult
-  { ok                 :: Maybe Bool
+  { ok                  :: Maybe Bool
     -- ^ result of the test case; Nothing = discard
-  , expect             :: Bool
+  , expect              :: Bool
     -- ^ indicates what the expected result of the property is
-  , reason             :: String
+  , reason              :: String
     -- ^ a message indicating what went wrong
-  , theException       :: Maybe AnException
+  , theException        :: Maybe AnException
     -- ^ the exception thrown, if any
-  , abort              :: Bool
+  , abort               :: Bool
     -- ^ if True, the test should not be repeated
-  , maybeNumTests      :: Maybe Int
+  , maybeNumTests       :: Maybe Int
     -- ^ stop after this many tests
-  , maybeCheckCoverage :: Maybe Confidence
+  , maybeCheckCoverage  :: Maybe Confidence
     -- ^ required coverage confidence
-  , labels             :: [String]
+  , maybeDiscardedRatio :: Maybe Int
+    -- ^ maximum number of discarded tests per successful test
+  , labels              :: [String]
     -- ^ test case labels
-  , classes            :: [String]
+  , classes             :: [String]
     -- ^ test case classes
-  , tables             :: [(String, String)]
+  , tables              :: [(String, String)]
     -- ^ test case tables
-  , requiredCoverage   :: [(Maybe String, String, Double)]
+  , requiredCoverage    :: [(Maybe String, String, Double)]
     -- ^ required coverage
-  , callbacks          :: [Callback]
+  , callbacks           :: [Callback]
     -- ^ the callbacks for this test case
-  , testCase           :: [String]
+  , testCase            :: [String]
     -- ^ the generated test case
   }
 
@@ -307,19 +309,20 @@ succeeded, failed, rejected :: Result
   where
     result =
       MkResult
-      { ok                 = undefined
-      , expect             = True
-      , reason             = ""
-      , theException       = Nothing
-      , abort              = False
-      , maybeNumTests      = Nothing
-      , maybeCheckCoverage = Nothing
-      , labels             = []
-      , classes            = []
-      , tables             = []
-      , requiredCoverage   = []
-      , callbacks          = []
-      , testCase           = []
+      { ok                  = undefined
+      , expect              = True
+      , reason              = ""
+      , theException        = Nothing
+      , abort               = False
+      , maybeNumTests       = Nothing
+      , maybeCheckCoverage  = Nothing
+      , maybeDiscardedRatio = Nothing
+      , labels              = []
+      , classes             = []
+      , tables              = []
+      , requiredCoverage    = []
+      , callbacks           = []
+      , testCase            = []
       }
 
 --------------------------------------------------------------------------
@@ -469,6 +472,16 @@ again = mapTotalResult (\res -> res{ abort = False })
 withMaxSuccess :: Testable prop => Int -> prop -> Property
 withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n })
 
+-- | Configures how many times a property is allowed to be discarded before failing.
+--
+-- For example,
+--
+-- > quickCheck (withDiscardRatio 10 p)
+--
+-- will allow @p@ to fail up to 10 times per successful test.
+withDiscardRatio :: Testable prop => Int -> prop -> Property
+withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n })
+
 -- | Check that all coverage requirements defined by 'cover' and 'coverTable'
 -- are met, using a statistically sound test, and fail if they are not met.
 --
@@ -918,6 +931,7 @@ disjoin ps =
                    abort = False,
                    maybeNumTests = Nothing,
                    maybeCheckCoverage = Nothing,
+                   maybeDiscardedRatio = Nothing,
                    labels = [],
                    classes = [],
                    tables = [],

src/Test/QuickCheck/State.hs

@@ -69,7 +69,7 @@ data Confidence =
     -- If the coverage requirement is met, and the certainty parameter is @n@,
     -- then you should get a false positive at most one in @n@ runs of QuickCheck.
     -- The default value is @10^9@.
-    -- 
+    --
     -- Lower values will speed up 'checkCoverage' at the cost of false
     -- positives.
     --

src/Test/QuickCheck/Test.hs

@@ -354,6 +354,7 @@ runATest st f =
 
      let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st
                  , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res)
+                 , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st) (maybeDiscardedRatio res)
                  , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st)
                  , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1)))
                  , S.tables =
@@ -372,7 +373,7 @@ runATest st f =
                  , randomSeed = rnd2
                  } f
 
-       MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test
+       MkResult{ok = Nothing} -> -- discarded test
          do continue giveUp
               -- Don't add coverage info from this test
               st{ numDiscardedTests         = numDiscardedTests st' + 1