QuickCheck 2.14.3 → 2.15

raw patch · 20 files changed

+653/−176 lines, 20 filesdep ~basedep ~containersdep ~splitmixPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, splitmix

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +38/−6
• changelog +30/−0
• examples/Heap.hs +10/−13
• examples/Set.hs +0/−6
• make-hugs +1/−1
• src/Test/QuickCheck.hs +43/−0
• src/Test/QuickCheck/Arbitrary.hs +39/−7
• src/Test/QuickCheck/Exception.hs +0/−2
• src/Test/QuickCheck/Features.hs +3/−3
• src/Test/QuickCheck/Gen.hs +22/−8
• src/Test/QuickCheck/Gen/Unsafe.hs +2/−3
• src/Test/QuickCheck/Modifiers.hs +1/−1
• src/Test/QuickCheck/Monadic.hs +73/−0
• src/Test/QuickCheck/Property.hs +110/−45
• src/Test/QuickCheck/State.hs +5/−3
• src/Test/QuickCheck/Test.hs +154/−76
• test-hugs +4/−1
• tests/DiscardRatio.hs +51/−0
• tests/Misc.hs +25/−1
• tests/Strictness.hs +42/−0

@@ -1,5 +1,5 @@ Name: QuickCheck-Version: 2.14.3+Version: 2.15 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3@@ -8,7 +8,15 @@ Author: Koen Claessen <koen@chalmers.se> Maintainer: Nick Smallbone <nick@smallbone.se> Bug-reports: https://github.com/nick8325/quickcheck/issues-Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4+Tested-with: GHC == 7.0.4  ||+                 == 7.2.2  ||+                 == 7.4.1  ||+                 == 7.4.2  ||+                 == 7.6.3  ||+                 == 7.8.4  ||+                 == 7.10.3 ||+                 == 8.0.2  ||+                 >= 8.2.2 && < 9.10 Homepage: https://github.com/nick8325/quickcheck Category:       Testing Synopsis:       Automatic testing of Haskell programs@@ -57,7 +65,7 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.14.3+  tag:      2.15  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.@@ -88,7 +96,7 @@   if impl(hugs)     cpp-options: -DNO_SPLITMIX   else-    Build-depends: splitmix >= 0.1 && <0.2+    Build-depends: splitmix >= 0.1.0.2 && <0.2    -- Modules that are always built.   Exposed-Modules:@@ -124,6 +132,9 @@   else     cpp-options: -DNO_TEMPLATE_HASKELL +  if !impl(ghc >= 8.0)+    cpp-options: -DNO_CALLSTACK+   if !impl(ghc >= 7.4)     cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS @@ -151,13 +162,16 @@   if !impl(ghc >= 8.0)     cpp-options: -DNO_MONADFAIL +  if impl(ghc >= 9.8)+    ghc-options: -Wno-x-partial+   -- Switch off most optional features on non-GHC systems.   if !impl(ghc)     -- If your Haskell compiler can cope without some of these, please     -- send a message to the QuickCheck mailing list!     cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS       -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS-      -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM+      -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM -DNO_CALLSTACK     if !impl(hugs) && !impl(uhc)       cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES @@ -237,12 +251,30 @@     hs-source-dirs: tests     main-is: Split.hs     build-depends: base, QuickCheck+    if impl(ghc >= 9.8)+      ghc-options: -Wno-x-partial +Test-Suite test-quickcheck-strictness+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Strictness.hs+    build-depends: base, QuickCheck, containers+    if !flag(templateHaskell) || !impl(ghc >= 7.10)+        buildable: False+ Test-Suite test-quickcheck-misc     type: exitcode-stdio-1.0     Default-language: Haskell2010     hs-source-dirs: tests     main-is: Misc.hs-    build-depends: base, QuickCheck+    build-depends: base, QuickCheck, containers     if !flag(templateHaskell) || !impl(ghc >= 7.10)         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

@@ -1,3 +1,33 @@+QuickCheck 2.15+	* BREAKING: properties without quantification are no longer implicitly+	  wrapped in once+	* Add witness property modifier and witnesses field in result on+	compilers that support Typeable to allow conveniently exposing+	counterexamples+	* Add assertException, assertExceptionIO, assertDeepException, and+	assertDeepExceptionIO (thanks to Alexey Kuleshevich)+	* Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators+	* Add recheck+	* Add HasCallStack to partial top-level functions+	* Updated some documentation+	* Fix overflow bug when calculating discard ratio+	* Fix error printing bug when shrinks are discarded+	* Fix withMaxSuccess not working when checkCoverage is turned on+	* Fix a bug whereby an unfortunately timed discard could unduly fail a+	property running with checkCoverage+	* Fix Arbitrary intance for Map breaking invariants from+	Data.Map.Strict (thanks to Neil Mayhew)+	* Fix non-covered classes not showing up in output as 0% covered+	* Fix Negative's Arbitrary instance discarding an unnecessary number+	of generated values.+	* Fix promote doing an unnecessary seed split+	* Fix a bug whereby maxSuccess and discardRatio would interact poorly+	to produce too few size increases.+	* Fix a couple of underflow bugs in generators for Small Natural and+	Ratio Natural+	* Fix a bug whereby the internal DISCARDED exception would show up+	user-side in sample+ QuickCheck 2.14.3 (released 2023-05-31) 	* Add shrinkBoundedEnum (thanks to Jonathan Knowles) 	* Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller)

@@ -148,20 +148,17 @@  -------------------------------------------------------------------------- -- the end.-{--  shrink Empty          = []-  shrink (Node x h1 h2) =-       [ h1, h2 ]-    ++ [ Node x  h1' h2  | h1' <- shrink h1, x  <=? h1' ]-    ++ [ Node x  h1  h2' | h2' <- shrink h2, x  <=? h2' ]-    ++ [ Node x' h1  h2  | x'  <- shrink x,  x' <=? h1, x' <=? h2 ]--} +-- shrink Empty          = []+-- shrink (Node x h1 h2) =+--      [ h1, h2 ]+--   ++ [ Node x  h1' h2  | h1' <- shrink h1, x  <=? h1' ]+--   ++ [ Node x  h1  h2' | h2' <- shrink h2, x  <=? h2' ]+--   ++ [ Node x' h1  h2  | x'  <- shrink x,  x' <=? h1, x' <=? h2 ]+ -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -{--prop_HeapIsNotSorted (h :: Heap Int) =-  expectFailure $-    toList h == toSortedList h--}+-- prop_HeapIsNotSorted (h :: Heap Int) =+--   expectFailure $+--     toList h == toSortedList h 

@@ -21,8 +21,6 @@  import Data.Maybe ---import Text.Show.Functions- -------------------------------------------------------------------------- -- binary search trees @@ -142,8 +140,6 @@   shrink t@(Node x s1 s2) = [ s1, s2 ]                          ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ] --- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a)- -------------------------------------------------------------------------- -- properties @@ -196,8 +192,6 @@   s ==? xs && xs == sort xs  where   xs = toSortedList s----  whenFail (putStrLn ("Result: " ++ show (fromList xs))) $  prop_FromList' (xs :: [Int]) =   shrinking shrink xs $ \xs' ->

@@ -18,7 +18,7 @@     -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \     -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \     -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \-    -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE \+    -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DNO_CALLSTACK \     "$src" > "$tgt" done 

@@ -28,6 +28,39 @@ instances for those types. See the <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> for details about how to do that.++When testing fails @quickCheck@ will try to give you a minimal counterexample to+your property:+@+import Test.QuickCheck++prop_reverse_bad :: [Int] -> Bool+prop_reverse_bad xs = reverse xs == xs++>>> quickCheck prop_reverse_bad+*** Failed! Falsified (after 3 tests and 3 shrinks):+[0,1]+@++However, beware because not all properties that ought to fail will fail when you expect+them to:++@+>>> quickCheck $ \ x y -> x == y++++ Ok, passed 100 tests.+@++That's because GHCi will default any type variables in your property to '()', so in the example+above @quickCheck@ was really testing that '()' is equal to itself. To avoid this behaviour it+is best practise to monomorphise your polymorphic properties when testing:++@+>>> quickCheck $ \ x y -> (x :: Int) == y+*** Failed! Falsified (after 4 tests and 3 shrinks):+0+1+@+ -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL@@ -45,6 +78,7 @@   , quickCheckWith   , quickCheckWithResult   , quickCheckResult+  , recheck   , isSuccess     -- ** Running tests verbosely   , verboseCheck@@ -271,6 +305,9 @@   , withMaxSuccess   , within   , discardAfter+  , withDiscardRatio+  , withMaxSize+  , withMaxShrinks   , once   , again   , mapSize@@ -281,6 +318,12 @@   , (.||.)   , disjoin     -- ** What to do on failure+#ifndef NO_TYPEABLE+  , Witness(..)+  , witness+  , coerceWitness+  , castWitness+#endif   , counterexample   , printTestCase   , whenFail

@@ -165,9 +165,14 @@ #endif  import qualified Data.Set as Set-import qualified Data.Map as Map import qualified Data.IntSet as IntSet+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as IntMap+#else+import qualified Data.Map as Map import qualified Data.IntMap as IntMap+#endif import qualified Data.Sequence as Sequence import qualified Data.Tree as Tree import Data.Bits@@ -409,7 +414,7 @@ instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where   gSubtermsIncl (K1 x) = [x] -instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where+instance GSubtermsIncl (K1 i a) b where   gSubtermsIncl (K1 _) = []  #endif@@ -496,8 +501,16 @@ -}  instance Integral a => Arbitrary (Ratio a) where-  arbitrary = arbitrarySizedFractional-  shrink    = shrinkRealFrac+  arbitrary = sized $ \ n -> do+    denom <- chooseInt (1, max 1 n)+    let lb | isNonNegativeType fromI = 0+           | otherwise = (-n*denom)+        -- NOTE: this is a trick to make sure we get around lack of scoped type+        -- variables by pinning the result-type of fromIntegral.+        fromI = fromIntegral+    numer <- chooseInt (lb, n*denom)+    pure $ fromI numer % fromI denom+  shrink = shrinkRealFrac  #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) instance Arbitrary a => Arbitrary (Complex a) where@@ -852,27 +865,36 @@   shrink = shrinkDecimal  -- Arbitrary instances for container types+-- | WARNING: Users working on the internals of the @Set@ type via e.g. @Data.Set.Internal@+-- should be aware that this instance aims to give a good representation of @Set a@+-- as mathematical sets but *does not* aim to provide a varied distribution over the+-- underlying representation. instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where   arbitrary = fmap Set.fromList arbitrary   shrink = map Set.fromList . shrink . Set.toList instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where   liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary   liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where   arbitrary = arbitrary1   shrink = shrink1+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary IntSet.IntSet where   arbitrary = fmap IntSet.fromList arbitrary   shrink = map IntSet.fromList . shrink . IntSet.toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary1 IntMap.IntMap where   liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary   liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (IntMap.IntMap a) where   arbitrary = arbitrary1   shrink = shrink1 instance Arbitrary1 Sequence.Seq where   liftArbitrary = fmap Sequence.fromList . liftArbitrary   liftShrink shr = map Sequence.fromList . liftShrink shr . toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (Sequence.Seq a) where   arbitrary = arbitrary1   shrink = shrink1@@ -1082,9 +1104,19 @@ -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Integral a => Gen a-arbitrarySizedIntegral =-  sized $ \n ->-  inBounds fromIntegral (chooseInt (-n, n))+arbitrarySizedIntegral+  | isNonNegativeType fromI = arbitrarySizedNatural+  | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n))+  where+    -- NOTE: this is a trick to make sure we get around lack of scoped type+    -- variables by pinning the result-type of fromIntegral.+    fromI = fromIntegral++isNonNegativeType :: Enum a => (Int -> a) -> Bool+isNonNegativeType fromI =+  case enumFromThen (fromI 1) (fromI 0) of+    [_, _] -> True+    _ -> False  -- | Generates a natural number. The number's maximum value depends on -- the size parameter.

@@ -75,8 +75,6 @@     notAsync e = Just e #endif ---tryEvaluateIO m = Right `fmap` m- evaluate :: a -> IO a evaluate = E.evaluate 

@@ -28,7 +28,7 @@     f res =       case ok res of         Just True-          | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) ->+          | not (features (P.labels res) (Set.fromList (map fst $ filter snd $ P.classes res)) `Set.isSubsetOf` feats) ->             res{ok = Just False, P.reason = "New feature found"}         _ -> res @@ -49,7 +49,7 @@ -- >   where count x xs = length (filter (== x) xs) -- -- 'labelledExamples' generates three example test cases, one for each label:--- +-- -- >>> labelledExamples prop_delete -- *** Found example of count x xs == 0 -- 0@@ -100,7 +100,7 @@             mapM_ (putLine (terminal state)) (failingTestCase res)             putStrLn ""             loop (Set.union feats feats')-              state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res}+              state{randomSeed = usedSeed res, replayStartSize = Just $ usedSize res}           _ -> do             out <- terminalOutput nullterm             putStr out

@@ -15,6 +15,8 @@ -------------------------------------------------------------------------- -- imports +import Test.QuickCheck.Exception+ import System.Random   ( Random   , random@@ -45,6 +47,12 @@ import Data.Int import Data.Bits import Control.Applicative+#ifndef NO_CALLSTACK+import GHC.Stack+#define WITHCALLSTACK(ty) HasCallStack => ty+#else+#define WITHCALLSTACK(ty) ty+#endif  -------------------------------------------------------------------------- -- ** Generator type@@ -57,7 +65,7 @@ -- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer> -- provide monad transformer versions of @Gen@. newtype Gen a = MkGen{-  unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed.+  unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed and size.                              -- If you just want to get a random value out, consider using 'generate'.   } @@ -134,7 +142,7 @@  -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter.-resize :: Int -> Gen a -> Gen a+resize :: WITHCALLSTACK(Int -> Gen a -> Gen a) resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" resize n (MkGen g) = MkGen (\r _ -> g r n) @@ -239,8 +247,14 @@ -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO () sample g =-  do cases <- sample' g-     mapM_ print cases+  sequence_ [ do r <- newQCGen+                 munit <- tryEvaluateIO (print $ unGen g r n)+                 case munit of+                  Left e+                    | isDiscard e -> putStrLn "<DISCARDED>"+                    | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map ("  " ++) (lines $ show e)+                  Right () -> return ()+            | n <- [0,2..20] ]  -------------------------------------------------------------------------- -- ** Floating point@@ -289,13 +303,13 @@  -- | Randomly uses one of the given generators. The input list -- must be non-empty.-oneof :: [Gen a] -> Gen a+oneof :: WITHCALLSTACK([Gen a] -> Gen a) oneof [] = error "QuickCheck.oneof used with empty list" oneof gs = chooseInt (0,length gs - 1) >>= (gs !!)  -- | Chooses one of the given generators, with a weighted random distribution. -- The input list must be non-empty.-frequency :: [(Int, Gen a)] -> Gen a+frequency :: WITHCALLSTACK([(Int, Gen a)] -> Gen a) frequency [] = error "QuickCheck.frequency used with empty list" frequency xs   | any (< 0) (map fst xs) =@@ -312,7 +326,7 @@   pick _ _  = error "QuickCheck.pick used with empty list"  -- | Generates one of the given values. The input list must be non-empty.-elements :: [a] -> Gen a+elements :: WITHCALLSTACK([a] -> Gen a) elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) @@ -330,7 +344,7 @@ -- among an initial segment of the list. The size of this initial -- segment increases with the size parameter. -- The input list must be non-empty.-growingElements :: [a] -> Gen a+growingElements :: WITHCALLSTACK([a] -> Gen a) growingElements [] = error "QuickCheck.growingElements used with empty list" growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs)   where

@@ -22,12 +22,11 @@  import Test.QuickCheck.Gen import Control.Monad+import Control.Applicative  -- | Promotes a monadic generator to a generator of monadic values. promote :: Monad m => m (Gen a) -> Gen (m a)-promote m = do-  eval <- delay-  return (liftM eval m)+promote m = flip liftM m <$> delay  -- | Randomly generates a function of type @'Gen' a -> a@, which -- you can then use to evaluate generators. Mostly useful in

@@ -283,7 +283,7 @@   fmap f (Negative x) = Negative (f x)  instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where-  arbitrary = fmap Negative (arbitrary `suchThat` (< 0))+  arbitrary = fmap Negative (fmap (negate . abs) arbitrary `suchThat` (< 0))   shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ]  --------------------------------------------------------------------------

@@ -72,6 +72,17 @@   , monadicST   , runSTGen #endif++  -- * Exceptions++#ifndef NO_EXCEPTIONS+  , assertException+  , assertExceptionIO+#ifndef NO_DEEPSEQ+  , assertDeepException+  , assertDeepExceptionIO+#endif+#endif   ) where  --------------------------------------------------------------------------@@ -95,6 +106,13 @@ import qualified Control.Monad.Fail as Fail #endif +#ifndef NO_DEEPSEQ+import Control.DeepSeq+#endif++#ifndef NO_EXCEPTIONS+import qualified Control.Exception as E+#endif -------------------------------------------------------------------------- -- type PropertyM @@ -296,6 +314,61 @@ runSTGen f = do   Capture eval <- capture   return (runST (eval f))+#endif++-- Exceptions+++#ifndef NO_EXCEPTIONS++-- | Evaluate the value to Weak Head Normal Form (WHNF) and fail if it does not result in+-- an expected exception being thrown.+assertException ::+     E.Exception exc+  => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected+  -> a -- ^ Value that should result in an exception, when evaluated to WHNF+  -> Property+assertException isExc value = assertExceptionIO isExc (return value)+++-- | Make sure that a specific exception is thrown during an IO action. The result is+-- evaluated to WHNF.+assertExceptionIO ::+     E.Exception exc+  => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected+  -> IO a -- ^ An action that should throw the expected exception+  -> Property+assertExceptionIO isExc action =+  monadicIO $ do+    hasFailed <-+      run+        (E.catch+           (do res <- action+               res `seq` return False)+           (return . isExc))+    assert hasFailed++#ifndef NO_DEEPSEQ++-- | Same as `assertException`, but evaluate the value to Normal Form (NF) and fail if it+-- does not result in an expected exception being thrown.+assertDeepException ::+     (NFData a, E.Exception exc)+  => (exc -> Bool) -- ^ Return True if that is the exception that was expected+  -> a -- ^ Value that should result in an exception, when fully evaluated to NF+  -> Property+assertDeepException isExc value = assertException isExc (rnf value)++-- | Make sure that a specific exception is thrown during an IO action. The result is+-- evaluated to NF.+assertDeepExceptionIO ::+     (NFData a, E.Exception exc)+  => (exc -> Bool) -- ^ Return True if that is the exception that was expected+  -> IO a -- ^ An action that should throw the expected exception+  -> Property+assertDeepExceptionIO isExc action = assertExceptionIO isExc (fmap rnf action)++#endif #endif  --------------------------------------------------------------------------

@@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-}@@ -33,7 +34,7 @@ import Control.DeepSeq #endif #ifndef NO_TYPEABLE-import Data.Typeable (Typeable)+import Data.Typeable (Typeable, cast) #endif import Data.Maybe @@ -85,11 +86,6 @@  -- | The class of properties, i.e., types which QuickCheck knows how to test. -- Typically a property will be a function returning 'Bool' or 'Property'.------ If a property does no quantification, i.e. has no--- parameters and doesn't use 'forAll', it will only be tested once.--- This may not be what you want if your property is an @IO Bool@.--- You can change this behaviour using the 'again' combinator. class Testable prop where   -- | Convert the thing to a property.   property :: prop -> Property@@ -142,7 +138,7 @@   property p = MkProperty . return . protectProp $ p  instance Testable prop => Testable (Gen prop) where-  property mp = MkProperty $ do p <- mp; unProperty (again p)+  property mp = MkProperty $ do p <- mp; unProperty (property p)  instance Testable Property where   property (MkProperty mp) = MkProperty (fmap protectProp mp)@@ -157,9 +153,6 @@ -- Warning: any random values generated inside of the argument to @ioProperty@ -- will not currently be shrunk. For best results, generate all random values -- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe.------ Note: if your property does no quantification, it will only be tested once.--- To test it repeatedly, use 'again'. ioProperty :: Testable prop => IO prop -> Property ioProperty prop = idempotentIOProperty (fmap noShrinking prop) @@ -262,35 +255,61 @@ data CallbackKind = Counterexample    -- ^ Affected by the 'verbose' combinator                   | NotCounterexample -- ^ Not affected by the 'verbose' combinator +#ifndef NO_TYPEABLE+data Witness = forall a. (Typeable a, Show a) => Wit a++instance Show Witness where+  show (Wit a) = show a++coerceWitness :: Typeable a => Witness -> a+coerceWitness (Wit a) = case cast a of+  Nothing -> error $ "Can't coerceWitness " ++ show a+  Just a -> a++castWitness :: Typeable a => Witness -> Maybe a+castWitness (Wit a) = cast a++#define WITNESSES(a) , theWitnesses a+#else+#define WITNESSES(a)+#endif+ -- | The result of a single test. data Result   = MkResult-  { ok                 :: Maybe Bool+  { ok                  :: Maybe Bool     -- ^ result of the test case; Nothing = discard-  , expect             :: Bool+  , expect              :: Bool     -- ^ indicates what the expected result of the property is-  , reason             :: String+  , reason              :: String     -- ^ a message indicating what went wrong-  , theException       :: Maybe AnException+  , theException        :: Maybe AnException     -- ^ the exception thrown, if any-  , abort              :: Bool+  , abort               :: Bool     -- ^ if True, the test should not be repeated-  , maybeNumTests      :: Maybe Int+  , maybeNumTests       :: Maybe Int     -- ^ stop after this many tests-  , maybeCheckCoverage :: Maybe Confidence+  , maybeCheckCoverage  :: Maybe Confidence     -- ^ required coverage confidence-  , labels             :: [String]+  , maybeDiscardedRatio :: Maybe Int+    -- ^ maximum number of discarded tests per successful test+  , maybeMaxShrinks     :: Maybe Int+    -- ^ maximum number of shrinks+  , maybeMaxTestSize    :: Maybe Int+    -- ^ maximum test size+  , labels              :: [String]     -- ^ test case labels-  , classes            :: [String]+  , classes             :: [(String, Bool)]     -- ^ test case classes-  , tables             :: [(String, String)]+  , tables              :: [(String, String)]     -- ^ test case tables-  , requiredCoverage   :: [(Maybe String, String, Double)]+  , requiredCoverage    :: [(Maybe String, String, Double)]     -- ^ required coverage-  , callbacks          :: [Callback]+  , callbacks           :: [Callback]     -- ^ the callbacks for this test case-  , testCase           :: [String]+  , testCase            :: [String]     -- ^ the generated test case+  WITNESSES(:: [Witness])   }  exception :: String -> AnException -> Result@@ -315,19 +334,23 @@   where     result =       MkResult-      { ok                 = undefined-      , expect             = True-      , reason             = ""-      , theException       = Nothing-      , abort              = True-      , maybeNumTests      = Nothing-      , maybeCheckCoverage = Nothing-      , labels             = []-      , classes            = []-      , tables             = []-      , requiredCoverage   = []-      , callbacks          = []-      , testCase           = []+      { ok                  = undefined+      , expect              = True+      , reason              = ""+      , theException        = Nothing+      , abort               = False+      , maybeNumTests       = Nothing+      , maybeCheckCoverage  = Nothing+      , maybeDiscardedRatio = Nothing+      , maybeMaxShrinks     = Nothing+      , maybeMaxTestSize    = Nothing+      , labels              = []+      , classes             = []+      , tables              = []+      , requiredCoverage    = []+      , callbacks           = []+      , testCase            = []+      WITNESSES(= [])       }  --------------------------------------------------------------------------@@ -477,6 +500,47 @@ withMaxSuccess :: Testable prop => Int -> prop -> Property withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) +-- | Configures how many times a property is allowed to be discarded before failing.+--+-- For example,+--+-- > quickCheck (withDiscardRatio 10 p)+--+-- will allow @p@ to fail up to 10 times per successful test.+withDiscardRatio :: Testable prop => Int -> prop -> Property+withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n })++-- | Configure the maximum number of times a property will be shrunk.+--+-- For example,+--+-- > quickCheck (withMaxShrinks 100 p)+--+-- will cause @p@ to only attempt 100 shrinks on failure.+withMaxShrinks :: Testable prop => Int -> prop -> Property+withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n })++-- | Configure the maximum size a property will be tested at.+withMaxSize :: Testable prop => Int -> prop -> Property+withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n })++#ifndef NO_TYPEABLE+-- | Return a value in the 'witnesses' field of the 'Result' returned by 'quickCheckResult'. Witnesses+-- are returned outer-most first.+--+-- In ghci, for example:+--+-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int)+-- *** Failed! Falsified (after 2 tests):+-- 1+-- >>> x+-- 1+-- >>> :t x+-- x :: Int+witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property+witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res })+#endif+ -- | Check that all coverage requirements defined by 'cover' and 'coverTable' -- are met, using a statistically sound test, and fail if they are not met. --@@ -591,13 +655,12 @@             Bool    -- ^ @True@ if the test case should be labelled.          -> String  -- ^ Label.          -> prop -> Property-classify False _ = property-classify True s =+classify b s = #ifndef NO_DEEPSEQ   s `deepseq` #endif   mapTotalResult $-    \res -> res { classes = s:classes res }+    \res -> res { classes = (s, b):classes res }  -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones@@ -705,7 +768,8 @@ -- | Checks that the values in a given 'table' appear a certain proportion of -- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts -- that of the values in @table@, @x1@ should appear at least @p1@ percent of--- the time, @x2@ at least @p2@ percent of the time, and so on.+-- the time that @table@ appears, @x2@ at least @p2@ percent of the time that+-- @table@ appears, and so on. -- -- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but -- the property does /not/ fail. To make the property fail, use 'checkCoverage'.@@ -839,7 +903,6 @@   :: Testable prop   => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrinkBlind gen shrinker pf =-  again $   MkProperty $   gen >>= \x ->     unProperty $@@ -850,7 +913,6 @@ -- makes 100 random choices. (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 =-  again $   MkProperty $   arbitrary >>= \b ->     unProperty $@@ -864,7 +926,6 @@ -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property conjoin ps =-  again $   MkProperty $   do roses <- mapM (fmap unProp . unProperty . property) ps      return (MkProp (conj id roses))@@ -903,7 +964,6 @@ -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property disjoin ps =-  again $   MkProperty $   do roses <- mapM (fmap unProp . unProperty . property) ps      return (MkProp (foldr disj (MkRose failed []) roses))@@ -930,6 +990,9 @@                    abort = False,                    maybeNumTests = Nothing,                    maybeCheckCoverage = Nothing,+                   maybeDiscardedRatio = Nothing,+                   maybeMaxShrinks = Nothing,+                   maybeMaxTestSize = Nothing,                    labels = [],                    classes = [],                    tables = [],@@ -940,7 +1003,9 @@                      callbacks result2,                    testCase =                      testCase result1 ++-                     testCase result2 }+                     testCase result2+                   WITNESSES(= theWitnesses result1 ++ theWitnesses result2)+                   }                Nothing -> result2          -- The "obvious" semantics of .||. has:          --   discard .||. true = true

@@ -25,12 +25,14 @@   , maxDiscardedRatio         :: Int     -- ^ maximum number of discarded tests per successful test   , coverageConfidence        :: Maybe Confidence-    -- ^ required coverage confidence-  , computeSize               :: Int -> Int -> Int     -- ^ how to compute the size of test cases from     --   #tests and #discarded tests   , numTotMaxShrinks          :: !Int     -- ^ How many shrinks to try before giving up+  , replayStartSize           :: Maybe Int+    -- ^ Size to start at when replaying+  , maxTestSize               :: !Int+    -- ^ Maximum size of test      -- dynamic   , numSuccessTests           :: !Int@@ -69,7 +71,7 @@     -- If the coverage requirement is met, and the certainty parameter is @n@,     -- then you should get a false positive at most one in @n@ runs of QuickCheck.     -- The default value is @10^9@.-    -- +    --     -- Lower values will speed up 'checkCoverage' at the cost of false     -- positives.     --

@@ -12,6 +12,7 @@ -------------------------------------------------------------------------- -- imports +import Control.Applicative import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P@@ -50,6 +51,7 @@ import Text.Printf(printf) import Control.Monad import Data.Bits+import Data.Maybe  #ifndef NO_TYPEABLE import Data.Typeable (Typeable)@@ -80,7 +82,7 @@   , chatty          :: Bool     -- ^ Whether to print anything   , maxShrinks      :: Int-    -- ^ Maximum number of shrinks to before giving up. Setting this to zero+    -- ^ Maximum number of shrinks to do before giving up. Setting this to zero     --   turns shrinking off.   }  deriving ( Show, Read@@ -142,6 +144,10 @@       -- ^ The test case's labels (see 'label')     , failingClasses  :: Set String       -- ^ The test case's classes (see 'classify')+#ifndef NO_TYPEABLE+    , witnesses :: [Witness]+      -- ^ The existentially quantified witnesses provided by 'witness'+#endif     }   -- | A property that should have failed did not   | NoExpectedFailure@@ -197,6 +203,11 @@ quickCheckWithResult a p =   withState a (\s -> test s (property p)) +-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'.+recheck :: Testable prop => Result -> prop -> IO ()+recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once+recheck _ = error "Can only recheck tests that failed with a counterexample."+ withState :: Args -> (State -> IO a) -> IO a withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do      rnd <- case replay a of@@ -206,9 +217,8 @@                  , maxSuccessTests           = maxSuccess a                  , coverageConfidence        = Nothing                  , maxDiscardedRatio         = maxDiscardRatio a-                 , computeSize               = case replay a of-                                                 Nothing    -> computeSize'-                                                 Just (_,s) -> computeSize' `at0` s+                 , replayStartSize           = snd <$> replay a+                 , maxTestSize               = maxSize a                  , numTotMaxShrinks          = maxShrinks a                  , numSuccessTests           = 0                  , numDiscardedTests         = 0@@ -223,18 +233,31 @@                  , numTryShrinks             = 0                  , numTotTryShrinks          = 0                  }-  where computeSize' n d-          -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:-          -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.-          | n `roundTo` maxSize a + maxSize a <= maxSuccess a ||-            n >= maxSuccess a ||-            maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a-          | otherwise =-            ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a-        n `roundTo` m = (n `div` m) * m-        at0 f s 0 0 = s-        at0 f s n d = f n d +computeSize :: State -> Int+computeSize MkState{replayStartSize = Just s,numSuccessTests = 0,numRecentlyDiscardedTests=0} = s+-- NOTE: Beware that changing this means you also have to change `prop_discardCoverage` as that currently relies+-- on the sequence produced by this function.+computeSize MkState{maxSuccessTests = ms, maxTestSize = mts, maxDiscardedRatio = md,numSuccessTests=n,numRecentlyDiscardedTests=d}+    -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:+    -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.+    | n `roundTo` mts + mts <= ms ||+      n >= ms ||+      ms `mod` mts == 0 = (n `mod` mts + d `div` dDenom) `min` mts+    | otherwise =+      ((n `mod` mts) * mts `div` (ms `mod` mts) + d `div` dDenom) `min` mts+  where+    -- The inverse of the rate at which we increase size as a function of discarded tests+    -- if the discard ratio is high we can afford this to be slow, but if the discard ratio+    -- is low we risk bowing out too early+    dDenom+      | md > 0 = (ms * md `div` 3) `clamp` (1, 10)+      | otherwise = 1 -- Doesn't matter because there will be no discards allowed+    n `roundTo` m = (n `div` m) * m++clamp :: Ord a => a -> (a, a) -> a+clamp x (l, h) = max l (min x h)+ -- | Tests a property and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. --@@ -275,14 +298,69 @@ -- main test loop  test :: State -> Property -> IO Result-test st f-  | numSuccessTests st   >= maxSuccessTests st && isNothing (coverageConfidence st) =-    doneTesting st f-  | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) =-    giveUp st f-  | otherwise =-    runATest st f+test st prop+  | finishedSuccessfully st         = doneTesting st prop+  | finishedInsufficientCoverage st = failCoverage st prop+  | tooManyDiscards st              = giveUp st prop+  | otherwise                       = runATest st prop +finishedSuccessfully :: State -> Bool+finishedSuccessfully st+  | checkingCoverage st =+      and [ timeToCheckCoverage st+          , coverageKnownSufficient st+          , numSuccessTests st >= maxSuccessTests st+          ]+  | otherwise = numSuccessTests st >= maxSuccessTests st++finishedInsufficientCoverage :: State -> Bool+finishedInsufficientCoverage st =+  and [ checkingCoverage st+      , timeToCheckCoverage st+      , coverageKnownInsufficient st+      ]++tooManyDiscards :: State -> Bool+tooManyDiscards st+  | maxDiscardedRatio st > 0 = numDiscardedTests st `div` maxDiscardedRatio st >= max (numSuccessTests st) (maxSuccessTests st)+  | otherwise = numDiscardedTests st > 0++checkingCoverage :: State -> Bool+checkingCoverage st = isJust (coverageConfidence st)++timeToCheckCoverage :: State -> Bool+timeToCheckCoverage st+ -- This is the time when we would normally finish testing, so lets check+ -- it now to see if we can finish testing already+ | numSuccessTests st == maxSuccessTests st && numRecentlyDiscardedTests st == 0 = True+ -- We are on test 100 * 2^k for k > 0+ | otherwise =+    and [ numSuccessTests st > 0+        , numSuccessTests st `mod` 100 == 0+        , powerOfTwo (numSuccessTests st `div` 100)+        ]+  where powerOfTwo n = n .&. (n - 1) == 0++coverageKnownSufficient :: State -> Bool+coverageKnownSufficient st@MkState{coverageConfidence=Just confidence} =+  and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ]+coverageKnownSufficient _ = True++coverageKnownInsufficient :: State -> Bool+coverageKnownInsufficient st@MkState{coverageConfidence=Just confidence} =+  or [ insufficientlyCovered (Just (certainty confidence)) tot n p+     | (_, _, tot, n, p) <- allCoverage st ]+coverageKnownInsufficient _ = False++failCoverage :: State -> Property -> IO Result+failCoverage st prop =+             -- The last test wasn't actually successful, as the coverage failed+             -- also this prevents an off-by-one error in the printing+    runATest st{numSuccessTests = numSuccessTests st - 1}+             $ foldr counterexample (property failed{P.reason = "Insufficient coverage"})+                                    (paragraphs [theLabels, theTables])+    where (theLabels, theTables) = labelsAndTables st+ doneTesting :: State -> Property -> IO Result doneTesting st _f   | expected st == False = do@@ -332,70 +410,77 @@             ]  runATest :: State -> Property -> IO Result-runATest st f =+runATest st prop =   do -- CALLBACK before_test      putTemp (terminal st)         ( "("        ++ showTestCount st        ++ ")"         )-     let powerOfTwo n = n .&. (n - 1) == 0-     let f_or_cov =-           case coverageConfidence st of-             Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) ->-               addCoverageCheck confidence st f-             _ -> f-     let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st)-     MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size)))++     let size = computeSize st++     MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size)))      res <- callbackPostTest st res -     let continue break st' | abort res = break st'-                            | otherwise = test st'+     let continue break st'+           | abort res = break $ updateState st'+           | otherwise = test $ updateState st' -     let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st-                 , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res)-                 , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st)-                 , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1)))-                 , S.tables =-                   foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1))-                     (S.tables st) (P.tables res)-                 , S.requiredCoverage =-                   foldr (\(key, value, p) -> Map.insertWith max (key, value) p)-                     (S.requiredCoverage st) (P.requiredCoverage res)-                 , expected = expect res }+         updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } +         addNewOptions st0 = st0{ maxSuccessTests   = fromMaybe (maxSuccessTests st0) (maybeNumTests res)+                                , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st0) (maybeDiscardedRatio res)+                                , numTotMaxShrinks  = fromMaybe (numTotMaxShrinks st0) (maybeMaxShrinks res)+                                , maxTestSize       = fromMaybe (maxTestSize st0) (maybeMaxTestSize res)+                                , expected          = expect res+                                }++         addCoverageInfo st0 =+           st0{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st0+              , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st0)+              , S.classes = Map.unionWith (+) (S.classes st0)+                                              (Map.fromList [ (s, if b then 1 else 0) | (s, b) <- P.classes res ])+              , S.tables =+                foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1))+                  (S.tables st0) (P.tables res)+              , S.requiredCoverage =+                foldr (\(key, value, p) -> Map.insertWith max (key, value) p)+                  (S.requiredCoverage st0) (P.requiredCoverage res)+              }++         stC = addCoverageInfo st+      case res of        MkResult{ok = Just True} -> -- successful test          do continue doneTesting-              st'{ numSuccessTests           = numSuccessTests st' + 1+              stC{ numSuccessTests           = numSuccessTests st + 1                  , numRecentlyDiscardedTests = 0-                 , randomSeed = rnd2-                 } f+                 } prop -       MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test+       MkResult{ok = Nothing} -> -- discarded test          do continue giveUp               -- Don't add coverage info from this test-              st{ numDiscardedTests         = numDiscardedTests st' + 1-                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1-                , randomSeed = rnd2-                } f+              st{ numDiscardedTests         = numDiscardedTests st + 1+                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1+                } prop         MkResult{ok = Just False} -> -- failed test-         do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts-            theOutput <- terminalOutput (terminal st')+         do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts+            theOutput <- terminalOutput (terminal stC)             if not (expect res) then-              return Success{ labels = S.labels st',-                              classes = S.classes st',-                              tables = S.tables st',-                              numTests = numSuccessTests st'+1,-                              numDiscarded = numDiscardedTests st',+              return Success{ labels = S.labels stC,+                              classes = S.classes stC,+                              tables = S.tables stC,+                              numTests = numSuccessTests stC+1,+                              numDiscarded = numDiscardedTests stC,                               output = theOutput }              else do               testCase <- mapM showCounterexample (P.testCase res)-              return Failure{ usedSeed        = randomSeed st' -- correct! (this will be split first)+              return Failure{ usedSeed        = randomSeed stC -- correct! (this will be split first)                             , usedSize        = size-                            , numTests        = numSuccessTests st'+1-                            , numDiscarded    = numDiscardedTests st'+                            , numTests        = numSuccessTests stC + 1+                            , numDiscarded    = numDiscardedTests stC                             , numShrinks      = numShrinks                             , numShrinkTries  = totFailed                             , numShrinkFinal  = lastFailed@@ -404,7 +489,10 @@                             , theException    = P.theException res                             , failingTestCase = testCase                             , failingLabels   = P.labels res-                            , failingClasses  = Set.fromList (P.classes res)+                            , failingClasses  = Set.fromList (map fst $ filter snd $ P.classes res)+#ifndef NO_TYPEABLE+                            , witnesses = theWitnesses res+#endif                             }  where   (rnd1,rnd2) = split (randomSeed st)@@ -524,7 +612,9 @@     Right () -> do       r <- tryEvaluate ts       case r of-        Left err ->+        Left err+          | isDiscard err -> localMinFound st res+          | otherwise ->           localMinFound st             (exception "Exception while generating shrink-list" err) { callbacks = callbacks res }         Right ts' -> localMin' st res ts'@@ -664,18 +754,6 @@     p_low  = 0.02425     p_high = 1 - p_low -addCoverageCheck :: Confidence -> State -> Property -> Property-addCoverageCheck confidence st prop-  | and [ sufficientlyCovered confidence tot n p-        | (_, _, tot, n, p) <- allCoverage st ] =-    -- Note: run prop once more so that we get labels for this test case run-    once prop-  | or [ insufficientlyCovered (Just (certainty confidence)) tot n p-       | (_, _, tot, n, p) <- allCoverage st ] =-    let (theLabels, theTables) = labelsAndTables st in-    foldr counterexample (property failed{P.reason = "Insufficient coverage"})-      (paragraphs [theLabels, theTables])-  | otherwise = prop  allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] allCoverage st =

@@ -19,8 +19,11 @@  dotest() {   echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output-  grep "$3" hugs.output || die+  grep -q "$3" hugs.output || die }  # Simple tests dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests."+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]"+echo+echo 'All tests passed!'

@@ -0,0 +1,51 @@+module Main where++import Control.Monad+import System.Exit+import Test.QuickCheck++assert :: String -> Bool -> IO  ()+assert s False = do+  putStrLn $ s ++ " failed!"+  exitFailure+assert _ _     = return ()++quickCheckYesWith, quickCheckNoWith :: Testable p => Args -> p -> IO ()+quickCheckYesWith args p = do+  res <- quickCheckWithResult args p+  unless (isSuccess res) exitFailure+quickCheckNoWith args p = do+  res <- quickCheckWithResult args p+  when (isSuccess res) exitFailure+quickCheckYes, quickCheckNo :: Testable p => p -> IO ()+quickCheckYes = quickCheckYesWith stdArgs+quickCheckNo = quickCheckNoWith stdArgs++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 "Expecting gave up after 200 tries: False ==> True"+  res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True+  check res 0 200+  res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ False ==> True+  check res 0 200++  putStrLn "\nExpecting success after 100 tests: x == x"+  res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x+  check res 100 0+  res <- quickCheckWithResult stdArgs{maxDiscardRatio = 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 "\nExpecting failure (discard ratio 1): x < 50 ==> True"+  quickCheckNo $ withDiscardRatio 1 p50+  quickCheckNoWith stdArgs{maxDiscardRatio = 1} p50+  putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True"+  quickCheckYes $ withDiscardRatio 40 p50+  quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50

@@ -3,6 +3,8 @@ {-# LANGUAGE TemplateHaskell #-} import Test.QuickCheck import Test.QuickCheck.Random+import Data.Map+import Control.Monad  prop_verbose :: Blind (Int -> Int -> Bool) -> Property prop_verbose (Blind p) =@@ -20,7 +22,29 @@   let [x, y, z] = failingTestCase res   return (not (p (read x) (read y) (read z))) +prop_maxSize :: Property+prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10)++prop_cover :: Property+prop_cover = withMaxSuccess 1000+           $ checkCoverage+           $ forAll (arbitrary :: Gen Int)+           $ \ x -> cover 5 (x > 0) "positive" True++-- Issue #382+prop_discardCoverage :: Property+prop_discardCoverage = checkCoverage $ forAll (sized $ \ n -> pure n) $ \ x -> cover 10 True "label" $ x /= 99 ==> True+ return [] main = do   True <- $quickCheckAll-  return ()+  Success{classes=cls} <- quickCheckResult $ classify False "A" $ classify True "B" True+  [("A",0),("B",100)] <- return $ toList cls+  Success{numTests=1000} <- quickCheckResult prop_cover+  forM_ [const discard, const [discard], \ x -> discard : shrink x] $ \ shr -> do+    Failure{reason="Falsified"} <- quickCheckResult $ forAllShrink arbitrary shr (odd :: Int -> Bool)+    return ()+  -- These shouldn't crash+  sample (discard :: Gen Int)+  sample (oneof [discard, return 1] :: Gen Int)+  sample (oneof [return (1, discard), return (1, 1)] :: Gen (Int, Int))

@@ -0,0 +1,42 @@+-- Strictness tests.++{-# LANGUAGE CPP, TemplateHaskell #-}+import Test.QuickCheck++import Control.Exception (Exception (..), throw)++#if MIN_VERSION_containers(0,5,0)+import Control.Exception (evaluate, try)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+#endif++data Thunk++instance Arbitrary Thunk where+  arbitrary = throw ThunkError++instance Show Thunk where+  show _ = "Thunk"++data ThunkError = ThunkError deriving Show++instance Exception ThunkError++prop_strictMap :: Property+#if MIN_VERSION_containers(0,5,0)+prop_strictMap = again . ioProperty $ do+  m <- generate arbitrary+  result <- try $ evaluate m :: IO (Either ThunkError (Map Int Thunk))+  pure $ case result of+    Right _ | not (Map.null m) -> counterexample ("Thunks in Map: " ++ show m) False+    _ -> property True+#else+prop_strictMap = once $ property True+#endif++return []+main :: IO ()+main = do+  True <- $quickCheckAll+  return ()