Add withDiscardRatio with a similar interface to withMaxSuccess

QuickCheck.cabal

@@ -246,3 +246,12 @@ Test-Suite test-quickcheck-misc
     build-depends: base, QuickCheck
     if !flag(templateHaskell) || !impl(ghc >= 7.10) || impl(haste)
         buildable: False
+
+Test-Suite test-quickcheck-discard
+    type: exitcode-stdio-1.0
+    Default-language: Haskell2010
+    hs-source-dirs: tests
+    main-is: DiscardRatio.hs
+    build-depends: base, QuickCheck
+    if !flag(templateHaskell) || !impl(ghc >= 7.10) || impl(haste)
+        buildable: False

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,12 +373,13 @@ 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
                 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1
-                , randomSeed = rnd2
+                , maxDiscardedRatio         = fromMaybe (maxDiscardedRatio st) (maybeDiscardedRatio res)
+                , randomSeed                = rnd2
                 } f
 
        MkResult{ok = Just False} -> -- failed test

tests/DiscardRatio.hs

@@ -0,0 +1,42 @@
+module Main where
+
+import Control.Monad
+import System.Exit
+import Test.QuickCheck
+
+assert :: String -> Bool -> IO  ()
+assert s False = do
+  putStrLn $ s ++ " failed!"
+  exitFailure
+assert _ _     = pure ()
+
+quickCheckYes, quickCheckNo :: Property -> IO ()
+quickCheckYes p = do
+  res <- quickCheckResult p
+  unless (isSuccess res) exitFailure
+quickCheckNo p = do
+  res <- quickCheckResult p
+  when (isSuccess res) exitFailure
+
+check :: Result -> Int -> Int -> IO ()
+check res n d = do
+  quickCheckYes $ once $ n === numTests res
+  quickCheckYes $ once $ d === numDiscarded res
+
+main :: IO ()
+main = do
+  putStrLn "Testing: False ==> True"
+  res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True
+  check res 0 200
+
+  putStrLn "Testing: x == x"
+  res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x
+  check res 100 0
+
+  -- The real ratio is 20, if 1 works or 40 doesn't it's
+  -- probably because we broke something!
+  let p50 = forAll (choose (1, 1000)) $ \ x -> (x :: Int) < 50 ==> True
+  putStrLn "Expecting failure (discard ratio 1): x < 50 ==> True"
+  quickCheckNo $ withDiscardRatio 1 p50
+  putStrLn "Expecting success (discard ratio 40): x < 50 ==> True"
+  quickCheckYes $ withDiscardRatio 40 p50