Speed up heavy use of mapTotalResult

Author: MaximilianAlgehed

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

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
 

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 ()

tests/TabulateSlow.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE NumericUnderscores #-}
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+prop_tabulateALot :: Int -> Property
+prop_tabulateALot x =
+  tabulates 1_000
+  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