tests + fix to missing case

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/Test.hs

@@ -378,7 +378,8 @@ runATest st f =
               -- 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,46 @@
+{-# LANGUAGE TypeApplications #-}
+module Main where
+
+import Test.QuickCheck
+import System.Exit
+
+assert :: String -> Bool -> IO  ()
+assert s False = do
+  putStrLn $ s ++ " failed!"
+  exitFailure
+assert _ _     = pure ()
+
+quickCheckYes, quickCheckNo :: Property -> IO ()
+quickCheckYes p = do
+  res <- quickCheckResult p
+  if isSuccess res
+  then pure ()
+  else exitFailure
+quickCheckNo p = do
+  res <- quickCheckResult p
+  if isSuccess res
+  then exitFailure
+  else pure ()
+
+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