From 7c51fc65311f83550366497ea62c10ba778ce6f3 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Mon, 18 Mar 2024 21:45:27 +0100
Subject: [PATCH] tests + fix to missing case

---
 QuickCheck.cabal            |  9 ++++++++
 src/Test/QuickCheck/Test.hs |  3 ++-
 tests/DiscardRatio.hs       | 46 +++++++++++++++++++++++++++++++++++++
 3 files changed, 57 insertions(+), 1 deletion(-)
 create mode 100644 tests/DiscardRatio.hs

diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index 6fc17ee4..9a1ac97e 100644
--- a/QuickCheck.cabal
+++ b/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
diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs
index 9f761ef4..bb436f15 100644
--- a/src/Test/QuickCheck/Test.hs
+++ b/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
diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs
new file mode 100644
index 00000000..dd3a489a
--- /dev/null
+++ b/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