From bc20ad3c48d165725c09a412c5c09037c867844a Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Sat, 21 Sep 2024 17:15:49 +0200
Subject: [PATCH 1/2] Speed up heavy use of mapTotalResult

---
 QuickCheck.cabal                | 11 +++++++++++
 src/Test/QuickCheck/Property.hs | 13 ++++++++-----
 src/Test/QuickCheck/Test.hs     |  3 ++-
 tests/TabulateSlow.hs           | 15 +++++++++++++++
 4 files changed, 36 insertions(+), 6 deletions(-)
 create mode 100644 tests/TabulateSlow.hs

diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index ad64ec72..284ba327 100644
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -287,3 +287,14 @@ Test-Suite test-quickcheck-monoids
       cpp-options: -DNO_SEMIGROUP_SUPERCLASS
     if !impl(ghc >= 8.0)
       cpp-options: -DNO_SEMIGROUP_CLASS
+
+Test-Suite test-quickcheck-tabulate-slow
+    type: exitcode-stdio-1.0
+    Default-language: Haskell2010
+    hs-source-dirs: tests
+    main-is: TabulateSlow.hs
+    build-depends: base, QuickCheck
+    if !impl(ghc >= 8.4)
+      cpp-options: -DNO_SEMIGROUP_SUPERCLASS
+    if !impl(ghc >= 8.0)
+      cpp-options: -DNO_SEMIGROUP_CLASS
diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs
index 3bc0ae34..4b6af70a 100644
--- a/src/Test/QuickCheck/Property.hs
+++ b/src/Test/QuickCheck/Property.hs
@@ -141,7 +141,7 @@ instance Testable prop => Testable (Gen prop) where
   property mp = MkProperty $ do p <- mp; unProperty (property p)
 
 instance Testable Property where
-  property (MkProperty mp) = MkProperty (fmap protectProp mp)
+  property = id
 
 -- | Do I/O inside a property.
 {-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-}
@@ -241,10 +241,13 @@ protectProp (MkProp r) = MkProp (IORose . protectRose . return $ r)
 
 -- | Wrap all the Results in a rose tree in exception handlers.
 protectResults :: Rose Result -> Rose Result
-protectResults = onRose $ \x rs ->
-  IORose $ do
-    y <- protectResult (return x)
-    return (MkRose y (map protectResults rs))
+protectResults = IORose . protect'
+  where
+    protect' :: Rose Result -> IO (Rose Result)
+    protect' (MkRose x rs) = do
+      y <- protectResult (return x)
+      return (MkRose y (map protectResults rs))
+    protect' (IORose m) = m >>= protect'
 
 -- ** Result type
 
diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs
index 8f913b49..d3b61bb1 100644
--- a/src/Test/QuickCheck/Test.hs
+++ b/src/Test/QuickCheck/Test.hs
@@ -201,7 +201,8 @@ quickCheckResult p = quickCheckWithResult stdArgs p
 -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.
 quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
 quickCheckWithResult a p =
-  withState a (\s -> test s (property p))
+  let MkProperty mp = property p
+  in withState a (\s -> test s $ MkProperty $ fmap protectProp mp)
 
 -- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'.
 recheck :: Testable prop => Result -> prop -> IO ()
diff --git a/tests/TabulateSlow.hs b/tests/TabulateSlow.hs
new file mode 100644
index 00000000..4c67d9c3
--- /dev/null
+++ b/tests/TabulateSlow.hs
@@ -0,0 +1,15 @@
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+prop_tabulateALot :: Int -> Property
+prop_tabulateALot x =
+  tabulates 1000
+  where
+    tabulates 0 = x === x
+    tabulates n =
+      tabulate "World" ["Hello"] $
+      tabulate "Hello" (["World" | even n] ++ ["There" | odd n]) $
+      tabulates (n - 1)
+
+main = do
+  quickCheck $ forAll arbitrary prop_tabulateALot

From ee5977004c67fb4de9ac11439271cadc6a033d78 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Mon, 23 Sep 2024 09:06:51 +0200
Subject: [PATCH 2/2] Better test

---
 tests/TabulateSlow.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/tests/TabulateSlow.hs b/tests/TabulateSlow.hs
index 4c67d9c3..7ac89ff5 100644
--- a/tests/TabulateSlow.hs
+++ b/tests/TabulateSlow.hs
@@ -1,5 +1,7 @@
 import Test.QuickCheck
 import Test.QuickCheck.Monadic
+import Control.Monad
+import System.Exit
 
 prop_tabulateALot :: Int -> Property
 prop_tabulateALot x =
@@ -12,4 +14,5 @@ prop_tabulateALot x =
       tabulates (n - 1)
 
 main = do
-  quickCheck $ forAll arbitrary prop_tabulateALot
+  r <- quickCheckResult $ within 10000 $ forAll arbitrary prop_tabulateALot
+  unless (isSuccess r) exitFailure