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..49adbc53 --- /dev/null +++ b/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