QuickCheck 2.11.3 → 2.12

raw patch · 26 files changed

+1377/−407 lines, 26 filesdep +erfdep +processdep ~basedep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: erf, process

Dependency ranges changed: base, deepseq

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• QuickCheck.cabal +42/−19
• README +4/−2
• Test/QuickCheck.hs +142/−67
• Test/QuickCheck/All.hs +4/−2
• Test/QuickCheck/Arbitrary.hs +38/−46
• Test/QuickCheck/Exception.hs +6/−4
• Test/QuickCheck/Features.hs +106/−0
• Test/QuickCheck/Function.hs +43/−0
• Test/QuickCheck/Gen.hs +17/−5
• Test/QuickCheck/Modifiers.hs +3/−0
• Test/QuickCheck/Monadic.hs +3/−2
• Test/QuickCheck/Property.hs +351/−68
• Test/QuickCheck/Random.hs +1/−0
• Test/QuickCheck/State.hs +70/−19
• Test/QuickCheck/Test.hs +261/−151
• Test/QuickCheck/Text.hs +89/−3
• changelog +52/−0
• examples/Heap.hs +1/−1
• examples/Heap_Program.hs +1/−1
• examples/Set.hs +4/−4
• tests/GCoArbitraryExample.hs +7/−3
• tests/GShrinkExample.hs +7/−4
• tests/Generators.hs +3/−4
• tests/MonadFix.hs +26/−0
• tests/Terminal.hs +94/−0

@@ -1,8 +1,8 @@ (The following is the 3-clause BSD license.) -Copyright (c) 2000-2017, Koen Claessen+Copyright (c) 2000-2018, Koen Claessen Copyright (c) 2006-2008, Björn Bringert-Copyright (c) 2009-2017, Nick Smallbone+Copyright (c) 2009-2018, Nick Smallbone  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -1,35 +1,41 @@ Name: QuickCheck-Version: 2.11.3+Version: 2.12 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE-Copyright: 2000-2017 Koen Claessen, 2006-2008 Björn Bringert, 2009-2017 Nick Smallbone+Copyright: 2000-2018 Koen Claessen, 2006-2008 Björn Bringert, 2009-2018 Nick Smallbone Author: Koen Claessen <koen@chalmers.se>-Maintainer: Nick Smallbone <nick@smallbone.se>; see also QuickCheck mailing list (https://groups.google.com/forum/#!forum/haskell-quickcheck)+Maintainer: Nick Smallbone <nick@smallbone.se> Bug-reports: https://github.com/nick8325/quickcheck/issues-Tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC >= 7.4+Tested-with: GHC >= 7.0 Homepage: https://github.com/nick8325/quickcheck Category:       Testing Synopsis:       Automatic testing of Haskell programs Description:   QuickCheck is a library for random testing of program properties.-  .   The programmer provides a specification of the program, in the form of   properties which functions should satisfy, and QuickCheck then tests that the   properties hold in a large number of randomly generated cases.+  Specifications are expressed in Haskell, using combinators provided by+  QuickCheck. QuickCheck provides combinators to define properties, observe the+  distribution of test data, and define test data generators.   .-  Specifications are expressed in Haskell, using combinators defined in the-  QuickCheck library. QuickCheck provides combinators to define properties,-  observe the distribution of test data, and define test data generators.+  Most of QuickCheck's functionality is exported by the main "Test.QuickCheck"+  module. The main exception is the monadic property testing library in+  "Test.QuickCheck.Monadic".   .-  The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html official QuickCheck manual>-  explains how to write generators and properties;-  it is out-of-date in some details but still full of useful advice.+  If you are new to QuickCheck, you can try looking at the following resources:   .-  A user of QuickCheck has written an unofficial, but detailed, tutorial which-  you can find at-  <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>.+  * The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html official QuickCheck manual>.+    It's a bit out-of-date in some details and doesn't cover newer QuickCheck features,+    but is still full of good advice.+  * <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,+    a detailed tutorial written by a user of QuickCheck.+  .+  The <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>+  companion package provides instances for types in Haskell Platform packages+  at the cost of additional dependencies.  extra-source-files:   README@@ -49,14 +55,14 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.11.3+  tag:      2.12  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.   Default: True  library-  Build-depends: base >=4.3 && <5, random, containers+  Build-depends: base >=4.3 && <5, random, containers, erf >= 2    -- Modules that are always built.   Exposed-Modules:@@ -72,7 +78,8 @@     Test.QuickCheck.Poly,     Test.QuickCheck.State,     Test.QuickCheck.Random,-    Test.QuickCheck.Exception+    Test.QuickCheck.Exception,+    Test.QuickCheck.Features    -- GHC-specific modules.   if impl(ghc)@@ -88,8 +95,8 @@   else     cpp-options: -DNO_TEMPLATE_HASKELL -  if !impl(ghc >= 7.2)-    cpp-options: -DNO_FOREIGN_C_USECONDS+  if !impl(ghc >= 7.4)+    cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS    -- The new generics appeared in GHC 7.2...   if impl(ghc < 7.2)@@ -169,3 +176,19 @@         buildable: False     if impl(ghc >= 7.2) && impl(ghc < 7.6)         build-depends: ghc-prim++Test-Suite test-quickcheck-terminal+    type: exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is: Terminal.hs+    build-depends: base, process, deepseq, QuickCheck+    if !impl(ghc >= 7.10)+        buildable: False++Test-Suite test-quickcheck-monadfix+    type: exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is: MonadFix.hs+    build-depends: base, QuickCheck+    if !impl(ghc >= 7.10)+        buildable: False

@@ -4,5 +4,7 @@  $ cabal install -There is a Google group for user discussion and questions at-https://groups.google.com/forum/#!forum/haskell-quickcheck.+The quickcheck-instances [1] companion package provides instances for types in+Haskell Platform packages at the cost of additional dependencies.++[1]: http://hackage.haskell.org/package/quickcheck-instances

@@ -1,6 +1,8 @@ {-| The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> gives detailed information about using QuickCheck effectively.+You can also try <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,+a tutorial written by a user of QuickCheck.  To start using QuickCheck, write down your property as a function returning @Bool@. For example, to check that reversing a list twice gives back the same list you can write:@@ -26,9 +28,6 @@ instances for those types. See the <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> for details about how to do that.--This module exports most of QuickCheck's functionality, but see also-"Test.QuickCheck.Monadic" which helps with testing impure or monadic code. -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL@@ -53,6 +52,10 @@   , verboseCheckResult #ifndef NO_TEMPLATE_HASKELL     -- ** Testing all properties in a module++    -- | These functions test all properties in the current module, using+    -- Template Haskell. You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@+    -- pragma in your module for any of these to work.   , quickCheckAll   , verboseCheckAll   , forAllProperties@@ -63,7 +66,30 @@   , monomorphic #endif -    -- * Random generation+    -- * The 'Arbitrary' typeclass: generation of random values+  , Arbitrary(..)+    -- ** Helper functions for implementing 'shrink'+#ifndef NO_GENERICS+  , genericShrink+  , subterms+  , recursivelyShrink+#endif+  , shrinkNothing+  , shrinkList+  , shrinkMap+  , shrinkMapBy+  , shrinkIntegral+  , shrinkRealFrac++    -- ** Lifting of 'Arbitrary' to unary and binary type constructors+  , Arbitrary1(..)+  , arbitrary1+  , shrink1+  , Arbitrary2(..)+  , arbitrary2+  , shrink2++    -- * The 'Gen' monad: combinators for building random generators   , Gen     -- ** Generator combinators   , choose@@ -78,38 +104,20 @@   , suchThat   , suchThatMap   , suchThatMaybe+  , applyArbitrary2+  , applyArbitrary3+  , applyArbitrary4+    -- ** Generators for lists   , listOf   , listOf1   , vectorOf+  , vector   , infiniteListOf+  , infiniteList   , shuffle   , sublistOf-    -- ** Generators which use Arbitrary-  , vector   , orderedList-  , infiniteList-    -- ** Running a generator-  , generate-    -- ** Generator debugging-  , sample-  , sample'--    -- * Arbitrary and CoArbitrary classes-  , Arbitrary(..)-  , CoArbitrary(..)--  -- ** Unary and Binary classes-  , Arbitrary1(..)-  , arbitrary1-  , shrink1-  , Arbitrary2(..)-  , arbitrary2-  , shrink2--    -- ** Helper functions for implementing arbitrary-  , applyArbitrary2-  , applyArbitrary3-  , applyArbitrary4+    -- ** Generators for particular types   , arbitrarySizedIntegral   , arbitrarySizedNatural   , arbitrarySizedFractional@@ -120,20 +128,52 @@   , arbitraryUnicodeChar   , arbitraryASCIIChar   , arbitraryPrintableChar-    -- ** Helper functions for implementing shrink+    -- ** Running generators+  , generate+    -- ** Debugging generators+  , sample+  , sample'++    -- * The 'Function' typeclass: generation of random shrinkable, showable functions++    -- | Example of use:+    --+    -- >>> :{+    -- >>> let prop :: Fun String Integer -> Bool+    -- >>>     prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"+    -- >>> :}+    -- >>> quickCheck prop+    -- *** Failed! Falsifiable (after 3 tests and 134 shrinks):+    -- {"elephant"->1, "monkey"->1, _->0}+    --+    -- To generate random values of type @'Fun' a b@,+    -- you must have an instance @'Function' a@.+    -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise,+    -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'.+    -- See the @'Function' [a]@ instance for an example of the latter.+    --+    -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen.+  , Fun (..)+  , applyFun+  , applyFun2+  , applyFun3+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  , pattern Fn+  , pattern Fn2+  , pattern Fn3+#endif+  , Function (..)+  , functionMap+  , functionShow+  , functionIntegral+  , functionRealFrac+  , functionBoundedEnum++    -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way #ifndef NO_GENERICS+  , CoArbitrary(..)   , genericCoarbitrary-  , genericShrink-  , subterms-  , recursivelyShrink #endif-  , shrinkNothing-  , shrinkList-  , shrinkMap-  , shrinkMapBy-  , shrinkIntegral-  , shrinkRealFrac-    -- ** Helper functions for implementing coarbitrary   , variant   , coarbitraryIntegral   , coarbitraryReal@@ -141,7 +181,36 @@   , coarbitraryEnum   , (><) -    -- ** Type-level modifiers for changing generator behavior+    -- * Type-level modifiers for changing generator behavior++    -- | These types do things such as restricting the kind of test data that can be generated.+    -- They can be pattern-matched on in properties as a stylistic+    -- alternative to using explicit quantification.+    --+    -- Examples:+    --+    -- @+    -- -- Functions cannot be shown (but see 'Function')+    -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) =+    --   takeWhile p xs ++ dropWhile p xs == xs+    -- @+    --+    -- @+    -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) =+    --   take n xs ++ drop n xs == xs+    -- @+    --+    -- @+    -- -- cycle does not work for empty lists+    -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) =+    --   take n (cycle xs) == take n (xs ++ cycle xs)+    -- @+    --+    -- @+    -- -- Instead of 'forAll' 'orderedList'+    -- prop_Sort ('Ordered' (xs :: ['OrdA'])) =+    --   sort xs == xs+    -- @   , Blind(..)   , Fixed(..)   , OrderedList(..)@@ -162,59 +231,63 @@   , UnicodeString(..)   , PrintableString(..) -    -- ** Functions-  , Fun (..)-  , applyFun-  , applyFun2-  , applyFun3-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  , pattern Fn-  , pattern Fn2-  , pattern Fn3-#endif-  , Function (..)-  , functionMap--    -- * Properties+    -- * Property combinators   , Property, Testable(..)-    -- ** Property combinators   , forAll   , forAllShrink+  , forAllShow+  , forAllShrinkShow+  , forAllBlind+  , forAllShrinkBlind   , shrinking   , (==>)+  , Discard(..)+  , discard   , (===)+  , (=/=) #ifndef NO_DEEPSEQ   , total #endif   , ioProperty-    -- *** Controlling property execution+  , idempotentIOProperty+    -- ** Controlling property execution   , verbose-  , once-  , again+  , verboseShrinking+  , noShrinking   , withMaxSuccess   , within-  , noShrinking-    -- *** Conjunction and disjunction+  , once+  , again+  , mapSize+    -- ** Conjunction and disjunction   , (.&.)   , (.&&.)   , conjoin   , (.||.)   , disjoin-    -- *** What to do on failure+    -- ** What to do on failure   , counterexample   , printTestCase   , whenFail   , whenFail'   , expectFailure-    -- *** Analysing test distribution+    -- * Analysing test case distribution   , label   , collect   , classify+  , tabulate+    -- ** Checking test case distribution   , cover-    -- *** Miscellaneous-  , Discard(..)-  , discard-  , mapSize+  , coverTable+  , checkCoverage+  , checkCoverageWith+  , Confidence(..)+  , stdConfidence+    -- ** Generating example test cases+  , labelledExamples+  , labelledExamplesWith+  , labelledExamplesWithResult+  , labelledExamplesResult   )  where @@ -228,6 +301,8 @@ import Test.QuickCheck.Test import Test.QuickCheck.Exception import Test.QuickCheck.Function+import Test.QuickCheck.Features+import Test.QuickCheck.State #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif

@@ -3,7 +3,10 @@ {-# LANGUAGE Trustworthy #-} #endif --- | Test all properties in the current module, using Template Haskell.+-- | __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly.+--+-- Test all properties in the current module, using Template Haskell. -- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in -- your module for any of these to work. module Test.QuickCheck.All(@@ -208,4 +211,3 @@       Failure { } -> False       NoExpectedFailure { } -> False       GaveUp { } -> False-      InsufficientCoverage { } -> False

@@ -1,4 +1,7 @@ -- | Type classes for random generation of values.+-- +-- __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} #ifndef NO_GENERICS@@ -630,7 +633,7 @@   shrink    = shrinkIntegral  instance Arbitrary Word where-  arbitrary = arbitrarySizedBoundedIntegral+  arbitrary = arbitrarySizedIntegral   shrink    = shrinkIntegral  instance Arbitrary Word8 where@@ -755,53 +758,26 @@   arbitrary = arbitrarySizedBoundedIntegral   shrink = shrinkIntegral -#ifndef NO_NEWTYPE_DERIVING+#ifndef NO_CTYPES_CONSTRUCTORS -- The following four types have no Bounded instance, -- so we fake it by discovering the bounds at runtime. instance Arbitrary CClock where-  arbitrary = fmap unBounds arbitrary-  shrink = shrinkMap unBounds Bounds+  arbitrary = fmap CClock arbitrary+  shrink (CClock x) = map CClock (shrink x)  instance Arbitrary CTime where-  arbitrary = fmap unBounds arbitrary-  shrink = shrinkMap unBounds Bounds+  arbitrary = fmap CTime arbitrary+  shrink (CTime x) = map CTime (shrink x)  #ifndef NO_FOREIGN_C_USECONDS instance Arbitrary CUSeconds where-  arbitrary = fmap unBounds arbitrary-  shrink = shrinkMap unBounds Bounds+  arbitrary = fmap CUSeconds arbitrary+  shrink (CUSeconds x) = map CUSeconds (shrink x)  instance Arbitrary CSUSeconds where-  arbitrary = fmap unBounds arbitrary-  shrink = shrinkMap unBounds Bounds+  arbitrary = fmap CSUSeconds arbitrary+  shrink (CSUSeconds x) = map CSUSeconds (shrink x) #endif--newtype Bounds a = Bounds { unBounds :: a }-  deriving (Eq, Ord, Num, Enum, Real, Show)--instance (Ord a, Num a) => Bounded (Bounds a) where-  -- assume max has all 1s in binary expansion-  maxBound = maximum (nubIterate (\x -> 2*x+1) 1)-  -- assume min has a leading 1 and rest 0s in binary expansion (or is 0)-  minBound = minimum (0:nubIterate (*2) 1)--instance (Num a, Real a, Enum a) => Integral (Bounds a) where-  toInteger = fromIntegral . fromEnum-  x `quotRem` y =-    let (z, w) = toInteger x `quotRem` toInteger y in-    (fromInteger z, fromInteger w)--instance (Ord a, Num a, Real a, Enum a) => Arbitrary (Bounds a) where-  arbitrary = arbitrarySizedBoundedIntegral-  shrink = shrinkIntegral---- Like iterate, but stop when you reach an existing value.-nubIterate :: Eq a => (a -> a) -> a -> [a]-nubIterate f x = iter [] x-  where-    iter xs x-      | x `elem` xs = []-      | otherwise = x:iter (x:xs) (f x) #endif  instance Arbitrary CFloat where@@ -1016,8 +992,8 @@ arbitrarySizedFractional =   sized $ \n ->     let n' = toInteger n in-      do a <- choose ((-n') * precision, n' * precision)-         b <- choose (1, precision)+      do b <- choose (1, precision)+         a <- choose ((-n') * b, n' * b)          return (fromRational (a % b))  where   precision = 9999999999999 :: Integer@@ -1120,20 +1096,36 @@             (True,  False) -> a + b < 0             (False, True)  -> a + b > 0 --- | Shrink a fraction.+-- | Shrink a fraction, via continued-fraction approximations. shrinkRealFrac :: RealFrac a => a -> [a]-shrinkRealFrac x =-  nub $-  [ -x-  | x < 0-  ] ++-  map fromInteger (shrinkIntegral (truncate x))+shrinkRealFrac a = shrinkRealFracToPrecision (abs a*1e-6) a +shrinkRealFracToPrecision :: RealFrac a+                   => a   -- ^ "Epsilon" – the minimum deviation we consider+                   -> a   -- ^ Value to shrink+                   -> [a]+shrinkRealFracToPrecision ε x+  | x < 0       = 0 : ([id, negate] <*> filter (>0) (shrinkRealFracToPrecision ε $ -x))+  | x < ε       = [0]+  | not (x==x)  = []+  | not (2*x>x) = 0 : takeWhile (<x) ((2^).(^2)<$>[0..])+  | (x-intgPart>ε)+                = intgShrinks ++ [intgPart]+                   ++ map ((intgPart+) . recip)+                          (filter (>0)+                            . shrinkRealFracToPrecision (ε/(x-intgPart))+                                  $ 1/(x-intgPart))+  | otherwise   = intgShrinks+ where intgPart = fromInteger $ truncate x+       intgShrinks = map fromInteger . shrinkIntegral $ truncate x+ -------------------------------------------------------------------------- -- ** CoArbitrary  #ifndef NO_GENERICS -- | Used for random generation of functions.+-- You should consider using 'Test.QuickCheck.Fun' instead, which+-- can show the generated functions as strings. -- -- If you are using a recent GHC, there is a default definition of -- 'coarbitrary' using 'genericCoarbitrary', so if your type has a

@@ -3,6 +3,7 @@ -- Hide away the nasty implementation-specific ways of catching -- exceptions behind a nice API. The main trouble is catching ctrl-C. +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} module Test.QuickCheck.Exception where @@ -84,10 +85,11 @@ isInterrupt e = E.fromException e == Just E.UserInterrupt #endif --- | A special exception that makes QuickCheck discard the test case.--- Normally you should use '==>', but if for some reason this isn't--- possible (e.g. you are deep inside a generator), use 'discard'--- instead.+-- | A special error value. If a property evaluates 'discard', it+-- causes QuickCheck to discard the current test case.+-- This can be useful if you want to discard the current test case,+-- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a+-- generator. discard :: a  isDiscard :: AnException -> Bool

@@ -0,0 +1,106 @@+{-# OPTIONS_HADDOCK hide #-}+module Test.QuickCheck.Features where++import Test.QuickCheck.Property hiding (Result, reason)+import qualified Test.QuickCheck.Property as P+import Test.QuickCheck.Test+import Test.QuickCheck.Gen+import Test.QuickCheck.State+import Test.QuickCheck.Text+import qualified Data.Set as Set+import Data.Set(Set)+import Data.List+import Data.IORef+import Data.Maybe++features :: [String] -> Set String -> Set String+features labels classes =+  Set.fromList labels `Set.union` classes++prop_noNewFeatures :: Testable prop => Set String -> prop -> Property+prop_noNewFeatures feats prop =+  mapResult f prop+  where+    f res =+      case ok res of+        Just True+          | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) ->+            res{ok = Just False, P.reason = "New feature found"}+        _ -> res++-- | Given a property, which must use 'label', 'collect', 'classify' or 'cover'+-- to associate labels with test cases, find an example test case for each possible label.+-- The example test cases are minimised using shrinking.+--+-- For example, suppose we test @'Data.List.delete' x xs@ and record the number+-- of times that @x@ occurs in @xs@:+--+-- > prop_delete :: Int -> [Int] -> Property+-- > prop_delete x xs =+-- >   classify (count x xs == 0) "count x xs == 0" $+-- >   classify (count x xs == 1) "count x xs == 1" $+-- >   classify (count x xs >= 2) "count x xs >= 2" $+-- >   counterexample (show (delete x xs)) $+-- >   count x (delete x xs) == max 0 (count x xs-1)+-- >   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+-- []+-- []+-- <BLANKLINE>+-- *** Found example of count x xs == 1+-- 0+-- [0]+-- []+-- <BLANKLINE>+-- *** Found example of count x xs >= 2+-- 5+-- [5,5]+-- [5]+-- <BLANKLINE>+-- +++ OK, passed 100 tests:+-- 78% count x xs == 0+-- 21% count x xs == 1+--  1% count x xs >= 2+++labelledExamples :: Testable prop => prop -> IO ()+labelledExamples prop = labelledExamplesWith stdArgs prop++-- | A variant of 'labelledExamples' that takes test arguments.+labelledExamplesWith :: Testable prop => Args -> prop -> IO ()+labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return ()++-- | A variant of 'labelledExamples' that returns a result.+labelledExamplesResult :: Testable prop => prop -> IO Result+labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop++-- | A variant of 'labelledExamples' that takes test arguments and returns a result.+labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result+labelledExamplesWithResult args prop =+  withState args $ \state -> do+    let+      loop :: Set String -> State -> IO Result+      loop feats state = withNullTerminal $ \nullterm -> do+        res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop))+        let feats' = features (failingLabels res) (failingClasses res)+        case res of+          Failure{reason = "New feature found"} -> do+            putLine (terminal state) $+              "*** Found example of " +++              intercalate ", " (Set.toList (feats' Set.\\ feats))+            mapM_ (putLine (terminal state)) (failingTestCase res)+            putStrLn ""+            loop (Set.union feats feats')+              state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res}+          _ -> do+            out <- terminalOutput nullterm+            putStr out+            return res+      at0 f s 0 0 = s+      at0 f s n d = f n d+    loop Set.empty state

@@ -17,6 +17,9 @@ -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. --+-- __Note__: most of the contents of this module are re-exported by+-- "Test.QuickCheck". You probably do not need to import it directly.+-- -- Example of use: -- -- >>> :{@@ -59,6 +62,7 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly +import Control.Applicative import Data.Char import Data.Word import Data.List( intersperse )@@ -71,6 +75,8 @@ import Data.Int import Data.Complex import Data.Foldable(toList)+import Data.Functor.Identity+import qualified Data.Monoid as Monoid  #ifndef NO_FIXED import Data.Fixed@@ -180,6 +186,12 @@ instance Function () where   function f = Unit (f ()) +instance Function a => Function (Const a b) where+  function = functionMap getConst Const++instance Function a => Function (Identity a) where+  function = functionMap runIdentity Identity+ instance (Function a, Function b) => Function (a,b) where   function = functionPairWith function function @@ -337,6 +349,34 @@ instance Function Word64 where   function = functionIntegral +-- instances for Data.Monoid newtypes++instance Function a => Function (Monoid.Dual a) where+  function = functionMap Monoid.getDual Monoid.Dual++instance Function Monoid.All where+  function = functionMap Monoid.getAll Monoid.All++instance Function Monoid.Any where+  function = functionMap Monoid.getAny Monoid.Any++instance Function a => Function (Monoid.Sum a) where+  function = functionMap Monoid.getSum Monoid.Sum++instance Function a => Function (Monoid.Product a) where+  function = functionMap Monoid.getProduct Monoid.Product++instance Function a => Function (Monoid.First a) where+  function = functionMap Monoid.getFirst Monoid.First++instance Function a => Function (Monoid.Last a) where+  function = functionMap Monoid.getLast Monoid.Last++#if MIN_VERSION_base(4,8,0)+instance Function (f a) => Function (Monoid.Alt f a) where+  function = functionMap Monoid.getAlt Monoid.Alt+#endif+ -- poly instances  instance Function A where@@ -453,6 +493,9 @@ -- See also 'applyFun', and 'Fn' with GHC >= 7.8. data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) data Shrunk = Shrunk | NotShrunk deriving Eq++instance Functor (Fun a) where+  fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g)  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -- | A modifier for testing functions.

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-}@@ -21,6 +22,9 @@   , filterM   ) +import Control.Monad.Fix+  ( MonadFix(..) )+ import Control.Applicative   ( Applicative(..) ) @@ -62,6 +66,12 @@           in m' r2 n     ) +instance MonadFix Gen where+  mfix f =+    MkGen $ \r n ->+      let a = unGen (f a) r n+      in a+ -------------------------------------------------------------------------- -- ** Primitive generator combinators @@ -83,7 +93,7 @@ sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) --- | Generates the size parameter. Used to construct generators that depend on+-- | Returns the size parameter. Used to construct generators that depend on -- the size parameter. -- -- For example, 'listOf', which uses the size parameter as an upper bound on@@ -156,11 +166,13 @@ -- | Tries to generate a value that satisfies a predicate. -- If it fails to do so after enough attempts, returns @Nothing@. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)-gen `suchThatMaybe` p = sized (try 0 . max 1)+gen `suchThatMaybe` p = sized (\n -> try n (2*n))  where-  try _ 0 = return Nothing-  try k n = do x <- resize (2*k+n) gen-               if p x then return (Just x) else try (k+1) (n-1)+  try m n+    | m > n = return Nothing+    | otherwise = do+        x <- resize m gen+        if p x then return (Just x) else try (m+1) n  -- | Randomly uses one of the given generators. The input list -- must be non-empty.

@@ -17,6 +17,9 @@ -- They can be pattern-matched on in properties as a stylistic -- alternative to using explicit quantification. --+-- __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly.+-- -- Examples: -- -- @

@@ -185,6 +185,7 @@  -- | Quantification in a monadic property, fits better with -- /do-notation/ than 'forAllM'.+-- __Note__: values generated by 'pick' do not shrink. pick :: (Monad m, Show a) => Gen a -> PropertyM m a pick gen = MkPropertyM $ \k ->   do a <- gen@@ -200,8 +201,8 @@ wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b wp m k = run m >>= k --- | An alternative to quantification a monadic properties to 'pick',--- with a notation similar to 'forAll'.+-- | Quantification in monadic properties to 'pick', with a notation similar to+-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink.  forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | Combinators for constructing properties. {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE@@ -16,7 +17,7 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception-import Test.QuickCheck.State hiding (labels)+import Test.QuickCheck.State( State(terminal), Confidence(..) )  #ifndef NO_TIMEOUT import System.Timeout(timeout)@@ -34,6 +35,7 @@ #ifndef NO_TYPEABLE import Data.Typeable (Typeable) #endif+import Data.Maybe  -------------------------------------------------------------------------- -- fixities@@ -94,6 +96,12 @@  -- | If a property returns 'Discard', the current test case is discarded, -- the same as if a precondition was false.+--+-- An example is the definition of '==>':+--+-- > (==>) :: Testable prop => Bool -> prop -> Property+-- > False ==> _ = property Discard+-- > True  ==> p = property p data Discard = Discard  instance Testable Discard where@@ -131,11 +139,22 @@ -- -- 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@.+-- 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 =+ioProperty prop = idempotentIOProperty (fmap noShrinking prop)++-- | Do I/O inside a property.+--+-- Warning: during shrinking, the I/O may not always be re-executed.+-- Instead, the I/O may be executed once and then its result retained.+-- If this is not acceptable, use 'ioProperty' instead.+idempotentIOProperty :: Testable prop => IO prop -> Property+idempotentIOProperty =   MkProperty . fmap (MkProp . ioRose . fmap unProp) .-  promote . fmap (unProperty . noShrinking)+  promote . fmap (unProperty . property)  instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where   property f = forAllShrink arbitrary shrink f@@ -216,16 +235,32 @@ -- | The result of a single test. data Result   = MkResult-  { ok            :: Maybe Bool        -- ^ result of the test case; Nothing = discard-  , expect        :: Bool              -- ^ indicates what the expected result of the property is-  , reason        :: String            -- ^ a message indicating what went wrong-  , theException  :: Maybe AnException -- ^ the exception thrown, if any-  , abort         :: Bool              -- ^ if True, the test should not be repeated-  , maybeNumTests :: Maybe Int         -- ^ stop after this many tests-  , labels        :: Map String Int    -- ^ all labels used by this property-  , stamp         :: Set String        -- ^ the collected labels for this test case-  , callbacks     :: [Callback]        -- ^ the callbacks for this test case-  , testCase      :: [String]          -- ^ the generated test case+  { ok                 :: Maybe Bool+    -- ^ result of the test case; Nothing = discard+  , expect             :: Bool+    -- ^ indicates what the expected result of the property is+  , reason             :: String+    -- ^ a message indicating what went wrong+  , theException       :: Maybe AnException+    -- ^ the exception thrown, if any+  , abort              :: Bool+    -- ^ if True, the test should not be repeated+  , maybeNumTests      :: Maybe Int+    -- ^ stop after this many tests+  , maybeCheckCoverage :: Maybe Confidence+    -- ^ required coverage confidence+  , labels             :: [String]+    -- ^ test case labels+  , classes            :: [String]+    -- ^ test case classes+  , tables             :: [(String, String)]+    -- ^ test case tables+  , requiredCoverage   :: [(Maybe String, String, Double)]+    -- ^ required coverage+  , callbacks          :: [Callback]+    -- ^ the callbacks for this test case+  , testCase           :: [String]+    -- ^ the generated test case   }  exception :: String -> AnException -> Result@@ -250,16 +285,19 @@   where     result =       MkResult-      { ok            = undefined-      , expect        = True-      , reason        = ""-      , theException  = Nothing-      , abort         = True-      , maybeNumTests = Nothing-      , labels        = Map.empty-      , stamp         = Set.empty-      , callbacks     = []-      , testCase      = []+      { ok                 = undefined+      , expect             = True+      , reason             = ""+      , theException       = Nothing+      , abort              = True+      , maybeNumTests      = Nothing+      , maybeCheckCoverage = Nothing+      , labels             = []+      , classes            = []+      , tables             = []+      , requiredCoverage   = []+      , callbacks          = []+      , testCase           = []       }  --------------------------------------------------------------------------@@ -285,9 +323,10 @@ -------------------------------------------------------------------------- -- ** Property combinators --- | Changes the maximum test case size for a property.+-- | Adjust the test case size for a property, by transforming it with the given+-- function. mapSize :: Testable prop => (Int -> Int) -> prop -> Property-mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f))+mapSize f = property . scale f . unProperty . property  -- | Shrinks the argument to a property if it fails. Shrinking is done -- automatically for most types. This function is only needed when you want to@@ -302,6 +341,7 @@     MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ]  -- | Disables shrinking for a property altogether.+-- Only quantification /inside/ the call to 'noShrinking' is affected. noShrinking :: Testable prop => prop -> Property noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) @@ -353,15 +393,27 @@ -- | Prints out the generated testcase every time the property is tested. -- Only variables quantified over /inside/ the 'verbose' are printed. verbose :: Testable prop => prop -> Property-verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res })-  where newCallbacks cbs =-          PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")):-          [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] ++-          [ PostTest Counterexample (\st res -> putLine (terminal st) "") ]+verbose = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res })+  where newCallback cbs =+          PostTest Counterexample $ \st res -> do+            putLine (terminal st) (status res ++ ":")+            sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ]+            putLine (terminal st) ""         status MkResult{ok = Just True} = "Passed"         status MkResult{ok = Just False} = "Failed"         status MkResult{ok = Nothing} = "Skipped (precondition false)" +-- | Prints out the generated testcase every time the property fails, including during shrinking.+-- Only variables quantified over /inside/ the 'verboseShrinking' are printed.+verboseShrinking :: Testable prop => prop -> Property+verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res })+  where newCallback cbs =+          PostTest Counterexample $ \st res ->+            when (ok res == Just False) $ do+              putLine (terminal st) "Failed:"+              sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ]+              putLine (terminal st) ""+ -- | Indicates that a property is supposed to fail. -- QuickCheck will report an error if it does not fail. expectFailure :: Testable prop => prop -> Property@@ -387,7 +439,50 @@ withMaxSuccess :: Testable prop => Int -> prop -> Property withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) --- | Attaches a label to a property. This is used for reporting+-- | Check that all coverage requirements defined by 'cover' and 'coverTable'+-- are met, using a statistically sound test, and fail if they are not met.+--+-- Ordinarily, a failed coverage check does not cause the property to fail.+-- This is because the coverage requirement is not tested in a statistically+-- sound way. If you use 'cover' to express that a certain value must appear 20%+-- of the time, QuickCheck will warn you if the value only appears in 19 out of+-- 100 test cases - but since the coverage varies randomly, you may have just+-- been unlucky, and there may not be any real problem with your test+-- generation.+--+-- When you use 'checkCoverage', QuickCheck uses a statistical test to account+-- for the role of luck in coverage failures. It will run as many tests as+-- needed until it is sure about whether the coverage requirements are met. If a+-- coverage requirement is not met, the property fails.+--+-- Example:+--+-- > quickCheck (checkCoverage prop_foo)+checkCoverage :: Testable prop => prop -> Property+checkCoverage = checkCoverageWith stdConfidence++-- | Check coverage requirements using a custom confidence level.+-- See 'stdConfidence'.+--+-- An example of making the statistical test less stringent in order to improve+-- performance:+--+-- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo)+checkCoverageWith :: Testable prop => Confidence -> prop -> Property+checkCoverageWith confidence =+  certainty confidence `seq`+  tolerance confidence `seq`+  mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence })++-- | The standard parameters used by 'checkCoverage': @certainty = 10^9@,+-- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters.+stdConfidence :: Confidence+stdConfidence =+  Confidence {+    certainty = 10^9,+    tolerance = 0.9 }++-- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- For example:@@ -404,10 +499,17 @@ -- 5% length of input is 4 -- 4% length of input is 6 -- ...+--+-- Each use of 'label' in your property results in a separate+-- table of test case distribution in the output. If this is+-- not what you want, use 'tabulate'. label :: Testable prop => String -> prop -> Property-label s = classify True s+label s =+  s `deepseq`+  mapTotalResult $+    \res -> res { labels = s:labels res } --- | Attaches a label to a property. This is used for reporting+-- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- > collect x = label (show x)@@ -426,10 +528,14 @@ -- 5% 4 -- 4% 6 -- ...+--+-- Each use of 'collect' in your property results in a separate+-- table of test case distribution in the output. If this is+-- not what you want, use 'tabulate'. collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) --- | Records how many test cases satisfy a given condition.+-- | Reports how many test cases satisfy a given condition. -- -- For example: --@@ -445,39 +551,170 @@             Bool    -- ^ @True@ if the test case should be labelled.          -> String  -- ^ Label.          -> prop -> Property-classify b s = cover b 0 s+classify False _ = property+classify True s =+  s `deepseq`+  mapTotalResult $+    \res -> res { classes = s:classes res }  -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage. --+-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but+-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.+-- -- For example: -- -- > prop_sorted_sort :: [Int] -> Property -- > prop_sorted_sort xs = -- >   sorted xs ==>--- >   cover (length xs > 1) 50 "non-trivial" $+-- >   cover 50 (length xs > 1) "non-trivial" $ -- >   sort xs === xs -- -- >>> quickCheck prop_sorted_sort--- *** Insufficient coverage after 100 tests (only 24% non-trivial, not 50%).+-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial).+-- <BLANKLINE>+-- Only 26% non-trivial, but expected 50% cover :: Testable prop =>-         Bool   -- ^ @True@ if the test case belongs to the class.-      -> Int    -- ^ The required percentage (0-100) of test cases.+         Double -- ^ The required percentage (0-100) of test cases.+      -> Bool   -- ^ @True@ if the test case belongs to the class.       -> String -- ^ Label for the test case class.       -> prop -> Property-cover x n s =-  x `seq` n `seq` s `listSeq`+cover p x s = mapTotalResult f . classify x s+  where+    f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res }++-- | Collects information about test case distribution into a table.+-- The arguments to 'tabulate' are the table's name and a list of values+-- associated with the current test case. After testing, QuickCheck prints the+-- frequency of all collected values. The frequencies are expressed as a+-- percentage of the total number of values collected.+--+-- You should prefer 'tabulate' to 'label' when each test case is associated+-- with a varying number of values. Here is a (not terribly useful) example,+-- where the test data is a list of integers and we record all values that+-- occur in the list:+--+-- > prop_sorted_sort :: [Int] -> Property+-- > prop_sorted_sort xs =+-- >   sorted xs ==>+-- >   tabulate "List elements" (map show xs) $+-- >   sort xs === xs+--+-- >>> quickCheck prop_sorted_sort+-- +++ OK, passed 100 tests; 1684 discarded.+-- <BLANKLINE>+-- List elements (109 in total):+--  3.7% 0+--  3.7% 17+--  3.7% 2+--  3.7% 6+--  2.8% -6+--  2.8% -7+--+-- Here is a more useful example. We are testing a chatroom, where the user can+-- log in, log out, or send a message:+--+-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)+-- > instance Arbitrary Command where ...+--+-- There are some restrictions on command sequences; for example, the user must+-- log in before doing anything else. The function @valid :: [Command] -> Bool@+-- checks that a command sequence is allowed. Our property then has the form:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   valid cmds ==>+-- >     ...+--+-- The use of '==>' may skew test case distribution. We use 'collect' to see the+-- length of the command sequences, and 'tabulate' to get the frequencies of the+-- individual commands:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   'collect' (length cmds) $+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ...+--+-- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom+-- +++ OK, passed 100 tests; 2775 discarded:+-- 60% 0+-- 20% 1+-- 15% 2+--  3% 3+--  1% 4+--  1% 5+-- <BLANKLINE>+-- Commands (68 in total):+-- 62% LogIn+-- 22% SendMessage+-- 16% LogOut+tabulate :: Testable prop => String -> [String] -> prop -> Property+tabulate key values =+  key `deepseq` values `deepseq`   mapTotalResult $-    \res -> res {-      labels = Map.insertWith max s n (labels res),-      stamp = if x then Set.insert s (stamp res) else stamp res }-  where [] `listSeq` z = z-        (x:xs) `listSeq` z = x `seq` xs `listSeq` z+    \res -> res { tables = [(key, value) | value <- values] ++ tables res } +-- | 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.+--+-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but+-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.+--+-- Continuing the example from the 'tabular' combinator...+--+-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ...+--+-- ...we can add a coverage requirement as follows, which checks that @LogIn@,+-- @LogOut@ and @SendMessage@ each occur at least 25% of the time:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ... property goes here ...+--+-- >>> quickCheck prop_chatroom+-- +++ OK, passed 100 tests; 2909 discarded:+-- 56% 0+-- 17% 1+-- 10% 2+--  6% 3+--  5% 4+--  3% 5+--  3% 7+-- <BLANKLINE>+-- Commands (111 in total):+-- 51.4% LogIn+-- 30.6% SendMessage+-- 18.0% LogOut+-- <BLANKLINE>+-- Table 'Commands' had only 18.0% LogOut, but expected 25.0%+coverTable :: Testable prop =>+  String -> [(String, Double)] -> prop -> Property+coverTable table xs =+  tables `deepseq` xs `deepseq`+  mapTotalResult $+    \res -> res { requiredCoverage = ys ++ requiredCoverage res }+  where+    ys = [(Just table, x, p/100) | (x, p) <- xs]+ -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded),--- or if the given property holds.+-- or if the given property holds. Note that using implication carelessly can+-- severely skew test case distribution: consider using 'cover' to make sure+-- that your test data is still good quality. (==>) :: Testable prop => Bool -> prop -> Property False ==> _ = property Discard True  ==> p = property p@@ -506,16 +743,38 @@        => Gen a -> (a -> prop) -> Property forAll gen pf = forAllShrink gen (\_ -> []) pf +-- | Like 'forAll', but with an explicitly given show function.+forAllShow :: Testable prop+           => Gen a -> (a -> String) -> (a -> prop) -> Property+forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf++-- | Like 'forAll', but without printing the generated value.+forAllBlind :: Testable prop+           => Gen a -> (a -> prop) -> Property+forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf+ -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop)              => Gen a -> (a -> [a]) -> (a -> prop) -> Property-forAllShrink gen shrinker pf =+forAllShrink gen shrinker = forAllShrinkShow gen shrinker show++-- | Like 'forAllShrink', but with an explicitly given show function.+forAllShrinkShow+  :: Testable prop+  => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property+forAllShrinkShow gen shrinker shower pf =+  forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x))++-- | Like 'forAllShrink', but without printing the generated value.+forAllShrinkBlind+  :: Testable prop+  => Gen a -> (a -> [a]) -> (a -> prop) -> Property+forAllShrinkBlind gen shrinker pf =   again $   MkProperty $   gen >>= \x ->     unProperty $-    shrinking shrinker x $ \x' ->-      counterexample (show x') (pf x')+    shrinking shrinker x pf  -- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of -- 'p1' and 'p2' to test. If you test the property 100 times it@@ -549,10 +808,10 @@     case ok result of       _ | not (expect result) ->         return (return failed { reason = "expectFailure may not occur inside a conjunction" })-      Just True -> return (conj (addLabels result . addCallbacks result . k) ps)+      Just True -> return (conj (addLabels result . addCallbacksAndCoverage result . k) ps)       Just False -> return rose       Nothing -> do-        rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps)+        rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage result . k) ps)         return $           -- Nasty work to make sure we use the right callbacks           case ok result2 of@@ -560,11 +819,13 @@             Just False -> rose2             Nothing -> rose2 -  addCallbacks result r =-    r { callbacks = callbacks result ++ callbacks r }+  addCallbacksAndCoverage result r =+    r { callbacks = callbacks result ++ callbacks r,+        requiredCoverage = requiredCoverage result ++ requiredCoverage r }   addLabels result r =-    r { labels = Map.unionWith max (labels result) (labels r),-        stamp = Set.union (stamp result) (stamp r) }+    r { labels = labels result ++ labels r,+        classes = classes result ++ classes r,+        tables = tables result ++ tables r }  -- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property@@ -583,25 +844,27 @@     do result1 <- p        case ok result1 of          _ | not (expect result1) -> return expectFailureError-         Just True -> return result1          Just False -> do            result2 <- q            return $              case ok result2 of                _ | not (expect result2) -> expectFailureError-               Just True -> result2+               Just True -> addCoverage result1 result2                Just False ->                  MkResult {                    ok = Just False,                    expect = True,                    reason = sep (reason result1) (reason result2),                    theException = theException result1 `mplus` theException result2,-                   -- The following three fields are not important because the+                   -- The following few fields are not important because the                    -- test case has failed anyway                    abort = False,                    maybeNumTests = Nothing,-                   labels = Map.empty,-                   stamp = Set.empty,+                   maybeCheckCoverage = Nothing,+                   labels = [],+                   classes = [],+                   tables = [],+                   requiredCoverage = [],                    callbacks =                      callbacks result1 ++                      [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++@@ -610,18 +873,28 @@                      testCase result1 ++                      testCase result2 }                Nothing -> result2-         Nothing -> do-           result2 <- q-           return (case ok result2 of-                     _ | not (expect result2) -> expectFailureError-                     Just True -> result2-                     _ -> result1)+         -- The "obvious" semantics of .||. has:+         --   discard .||. true = true+         --   discard .||. discard = discard+         -- but this implementation gives discard .||. true = discard.+         -- This is reasonable because evaluating result2 in the case+         -- that result1 discards is just busy-work - it won't ever+         -- cause the property to fail. On the other hand, discarding+         -- instead of returning true causes us to execute one more+         -- test case - but assuming that preconditions are cheap to+         -- evaluate, this is no more work than evaluating result2+         -- would be, while (unlike evaluating result2) it might catch+         -- a bug.+         _ -> return result1    expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" }   sep [] s = s   sep s [] = s   sep s s' = s ++ ", " ++ s' +  addCoverage result r =+    r { requiredCoverage = requiredCoverage result ++ requiredCoverage r }+ -- | Like '==', but prints a counterexample when it fails. infix 4 === (===) :: (Eq a, Show a) => a -> a -> Property@@ -631,6 +904,16 @@     res = x == y     interpret True  = " == "     interpret False = " /= "++-- | Like '/=', but prints a counterexample when it fails.+infix 4 =/=+(=/=) :: (Eq a, Show a) => a -> a -> Property+x =/= y =+  counterexample (show x ++ interpret res ++ show y) res+  where+    res = x /= y+    interpret True  = " /= "+    interpret False = " == "  #ifndef NO_DEEPSEQ -- | Checks that a value is total, i.e., doesn't crash when evaluated.

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | A wrapper around the system random number generator. Internal QuickCheck module. {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL

@@ -1,10 +1,10 @@+{-# OPTIONS_HADDOCK hide #-} -- | QuickCheck's internal state. Internal QuickCheck module. module Test.QuickCheck.State where  import Test.QuickCheck.Text import Test.QuickCheck.Random import Data.Map(Map)-import Data.Set(Set)  -------------------------------------------------------------------------- -- State@@ -14,27 +14,78 @@ data State   = MkState   -- static-  { terminal                  :: Terminal          -- ^ the current terminal-  , maxSuccessTests           :: Int               -- ^ maximum number of successful tests needed-  , maxDiscardedRatio         :: Int               -- ^ maximum number of discarded tests per successful test-  , 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+  { terminal                  :: Terminal+    -- ^ the current terminal+  , maxSuccessTests           :: Int+    -- ^ maximum number of successful tests needed+  , 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 -  -- dynamic-  , numSuccessTests           :: !Int              -- ^ the current number of tests that have succeeded-  , numDiscardedTests         :: !Int              -- ^ the current number of discarded tests-  , numRecentlyDiscardedTests :: !Int              -- ^ the number of discarded tests since the last successful test-  , labels                    :: !(Map String Int) -- ^ all labels that have been defined so far-  , collected                 :: ![Set String]     -- ^ all labels that have been collected so far-  , expectedFailure           :: !Bool             -- ^ indicates if the property is expected to fail-  , randomSeed                :: !QCGen            -- ^ the current random seed+    -- dynamic+  , numSuccessTests           :: !Int+    -- ^ the current number of tests that have succeeded+  , numDiscardedTests         :: !Int+    -- ^ the current number of discarded tests+  , numRecentlyDiscardedTests :: !Int+    -- ^ the number of discarded tests since the last successful test+  , labels                    :: !(Map [String] Int)+    -- ^ counts for each combination of labels (label/collect)+  , classes                   :: !(Map String Int)+    -- ^ counts for each class of test case (classify/cover)+  , tables                    :: !(Map String (Map String Int))+    -- ^ tables collected using tabulate+  , requiredCoverage          :: !(Map (Maybe String, String) Double)+    -- ^ coverage requirements+  , expected                  :: !Bool+    -- ^ indicates the expected result of the property+  , randomSeed                :: !QCGen+    -- ^ the current random seed -                                                   -- shrinking-  , numSuccessShrinks         :: !Int              -- ^ number of successful shrinking steps so far-  , numTryShrinks             :: !Int              -- ^ number of failed shrinking steps since the last successful shrink-  , numTotTryShrinks          :: !Int              -- ^ total number of failed shrinking steps+    -- shrinking+  , numSuccessShrinks         :: !Int+    -- ^ number of successful shrinking steps so far+  , numTryShrinks             :: !Int+    -- ^ number of failed shrinking steps since the last successful shrink+  , numTotTryShrinks          :: !Int+    -- ^ total number of failed shrinking steps   }++-- | The statistical parameters used by 'checkCoverage'.+data Confidence =+  Confidence {+    certainty :: Integer,+    -- ^ How certain 'checkCoverage' must be before the property fails.+    -- 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.+    --+    -- If you are using 'checkCoverage' as part of a test suite, you should+    -- be careful not to set @certainty@ too low. If you want, say, a 1% chance+    -- of a false positive during a project's lifetime, then @certainty@ should+    -- be set to at least @100 * m * n@, where @m@ is the number of uses of+    -- 'cover' in the test suite, and @n@ is the number of times you expect the+    -- test suite to be run during the project's lifetime. The default value+    -- is chosen to be big enough for most projects.+    tolerance :: Double+    -- ^ For statistical reasons, 'checkCoverage' will not reject coverage+    -- levels that are only slightly below the required levels.+    -- If the required level is @p@ then an actual level of @tolerance * p@+    -- will be accepted. The default value is @0.9@.+    --+    -- Lower values will speed up 'checkCoverage' at the cost of not detecting+    -- minor coverage violations.+    }+  deriving Show  -------------------------------------------------------------------------- -- the end.

@@ -1,7 +1,8 @@+{-# OPTIONS_HADDOCK hide #-} -- | The main test loop. {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif module Test.QuickCheck.Test where @@ -9,13 +10,14 @@ -- imports  import Test.QuickCheck.Gen-import Test.QuickCheck.Property hiding ( Result( reason, theException, labels ) )+import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text-import Test.QuickCheck.State hiding (labels)+import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random+import Data.Number.Erf(invnormcdf) import System.Random(split) #if defined(MIN_VERSION_containers) #if MIN_VERSION_containers(0,5,0)@@ -27,6 +29,8 @@ import qualified Data.Map as Map #endif import qualified Data.Set as Set+import Data.Set(Set)+import Data.Map(Map)  import Data.Char   ( isSpace@@ -37,11 +41,15 @@   , sortBy   , group   , intersperse+  , intercalate   ) -import Data.Maybe(fromMaybe)+import Data.Maybe(fromMaybe, isNothing, catMaybes) import Data.Ord(comparing) import Text.Printf(printf)+import Data.Either(lefts, rights)+import Control.Monad+import Data.Bits  -------------------------------------------------------------------------- -- quickCheck@@ -77,41 +85,65 @@ data Result   -- | A successful test run   = Success-    { numTests       :: Int               -- ^ Number of tests performed-    , labels         :: [(String,Double)] -- ^ Labels and frequencies found during all successful tests-    , output         :: String            -- ^ Printed output+    { numTests     :: Int+      -- ^ Number of tests performed+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+      -- ^ The number of test cases having each combination of labels (see 'label')+    , classes      :: !(Map String Int)+      -- ^ The number of test cases having each class (see 'classify')+    , tables       :: !(Map String (Map String Int))+      -- ^ Data collected by 'tabulate'+    , output       :: String+      -- ^ Printed output     }   -- | Given up   | GaveUp-    { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests-    , output         :: String            --   Printed output+    { numTests     :: Int+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+    , classes      :: !(Map String Int)+    , tables       :: !(Map String (Map String Int))+    , output       :: String     }   -- | A failed test run   | Failure-    { numTests        :: Int               --   Number of tests performed-    , numShrinks      :: Int               -- ^ Number of successful shrinking steps performed-    , numShrinkTries  :: Int               -- ^ Number of unsuccessful shrinking steps performed-    , numShrinkFinal  :: Int               -- ^ Number of unsuccessful shrinking steps performed since last successful shrink-    , usedSeed        :: QCGen             -- ^ What seed was used-    , usedSize        :: Int               -- ^ What was the test size-    , reason          :: String            -- ^ Why did the property fail-    , theException    :: Maybe AnException -- ^ The exception the property threw, if any-    , labels          :: [(String,Double)] --   Labels and frequencies found during all successful tests-    , output          :: String            --   Printed output-    , failingTestCase :: [String]          -- ^ The test case which provoked the failure+    { numTests        :: Int+    , numDiscarded    :: Int+      -- ^ Number of tests skipped+    , numShrinks      :: Int+      -- ^ Number of successful shrinking steps performed+    , numShrinkTries  :: Int+      -- ^ Number of unsuccessful shrinking steps performed+    , numShrinkFinal  :: Int+      -- ^ Number of unsuccessful shrinking steps performed since last successful shrink+    , usedSeed        :: QCGen+      -- ^ What seed was used+    , usedSize        :: Int+      -- ^ What was the test size+    , reason          :: String+      -- ^ Why did the property fail+    , theException    :: Maybe AnException+      -- ^ The exception the property threw, if any+    , output          :: String+    , failingTestCase :: [String]+      -- ^ The test case which provoked the failure+    , failingLabels   :: [String]+      -- ^ The test case's labels (see 'label')+    , failingClasses  :: Set String+      -- ^ The test case's classes (see 'classify')     }   -- | A property that should have failed did not   | NoExpectedFailure-    { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests-    , output         :: String            --   Printed output-    }- -- | The tests passed but a use of 'cover' had insufficient coverage- | InsufficientCoverage-    { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests-    , output         :: String            --   Printed output+    { numTests     :: Int+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+    , classes      :: !(Map String Int)+    , tables       :: !(Map String (Map String Int))+    , output       :: String     }  deriving ( Show ) @@ -148,12 +180,17 @@  -- | 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 = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do+quickCheckWithResult a p =+  withState a (\s -> test s (property p))++withState :: Args -> (State -> IO a) -> IO a+withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do      rnd <- case replay a of               Nothing      -> newQCGen               Just (rnd,_) -> return rnd      test MkState{ terminal                  = tm                  , maxSuccessTests           = maxSuccess a+                 , coverageConfidence        = Nothing                  , maxDiscardedRatio         = maxDiscardRatio a                  , computeSize               = case replay a of                                                  Nothing    -> computeSize'@@ -163,13 +200,15 @@                  , numDiscardedTests         = 0                  , numRecentlyDiscardedTests = 0                  , S.labels                  = Map.empty-                 , collected                 = []-                 , expectedFailure           = False+                 , S.classes                 = Map.empty+                 , S.tables                  = Map.empty+                 , S.requiredCoverage        = Map.empty+                 , expected                  = True                  , randomSeed                = rnd                  , numSuccessShrinks         = 0                  , numTryShrinks             = 0                  , numTotTryShrinks          = 0-                 } (unGen (unProperty (property p)))+                 }   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.@@ -205,124 +244,138 @@ -------------------------------------------------------------------------- -- main test loop -test :: State -> (QCGen -> Int -> Prop) -> IO Result+test :: State -> Property -> IO Result test st f-  | numSuccessTests st   >= maxSuccessTests st =+  | numSuccessTests st   >= maxSuccessTests st && isNothing (coverageConfidence st) =     doneTesting st f-  | numDiscardedTests st >= maxDiscardedRatio st * maxSuccessTests st =+  | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) =     giveUp st f   | otherwise =     runATest st f -doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result+doneTesting :: State -> Property -> IO Result doneTesting st _f-  | not (expectedFailure st) = do+  | expected st == False = do       putPart (terminal st)         ( bold ("*** Failed!")        ++ " Passed "-       ++ show (numSuccessTests st)-       ++ " tests (expected failure)"+       ++ showTestCount st+       ++ " (expected failure)"         )       finished NoExpectedFailure-  | not (null (insufficientlyCovered st)) = do-      putPart (terminal st)-        ( bold ("*** Insufficient coverage after ")-       ++ show (numSuccessTests st)-       ++ " tests"-        )-      finished InsufficientCoverage   | otherwise = do       putPart (terminal st)         ( "+++ OK, passed "-       ++ show (numSuccessTests st)-       ++ " tests"+       ++ showTestCount st         )       finished Success   where     finished k = do       success st       theOutput <- terminalOutput (terminal st)-      return (k (numSuccessTests st) (summary st) theOutput)+      return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) -giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result+giveUp :: State -> Property -> IO Result giveUp st _f =   do -- CALLBACK gave_up?      putPart (terminal st)        ( bold ("*** Gave up!")       ++ " Passed only "-      ++ show (numSuccessTests st)+      ++ showTestCount st       ++ " tests"        )      success st      theOutput <- terminalOutput (terminal st)-     return GaveUp{ numTests = numSuccessTests st-                  , labels   = summary st-                  , output   = theOutput+     return GaveUp{ numTests     = numSuccessTests st+                  , numDiscarded = numDiscardedTests st+                  , labels       = S.labels st+                  , classes      = S.classes st+                  , tables       = S.tables st+                  , output       = theOutput                   } -runATest :: State -> (QCGen -> Int -> Prop) -> IO Result+showTestCount :: State -> String+showTestCount st =+     number (numSuccessTests st) "test"+  ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded"+            | numDiscardedTests st > 0+            ]++runATest :: State -> Property -> IO Result runATest st f =   do -- CALLBACK before_test      putTemp (terminal st)         ( "("-       ++ number (numSuccessTests st) "test"-       ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded"-                 | numDiscardedTests st > 0-                 ]+       ++ 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 (f rnd1 size)))+     MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size)))      res <- callbackPostTest st res       let continue break st' | abort res = break st'                             | otherwise = test st'-         cons x xs-           | Set.null x = xs-           | otherwise = x:xs +     let inc x = Map.insertWith (+) x 1+     let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st+                 , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res)+                 , S.labels = inc (P.labels res) (S.labels st)+                 , S.classes = foldr inc (S.classes st) (P.classes res)+                 , 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 }+      case res of-       MkResult{ok = Just True, stamp = stamp, expect = expect, maybeNumTests = mnt} -> -- successful test+       MkResult{ok = Just True} -> -- successful test          do continue doneTesting-              st{ numSuccessTests           = numSuccessTests st + 1-                , numRecentlyDiscardedTests = 0-                , maxSuccessTests           = fromMaybe (maxSuccessTests st) mnt-                , randomSeed                = rnd2-                , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)-                , collected                 = stamp `cons` collected st-                , expectedFailure           = expect-                } f+              st'{ numSuccessTests           = numSuccessTests st' + 1+                 , numRecentlyDiscardedTests = 0+                 , randomSeed = rnd2+                 } f -       MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt} -> -- discarded test+       MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test          do continue giveUp-              st{ numDiscardedTests         = numDiscardedTests st + 1-                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1-                , maxSuccessTests           = fromMaybe (maxSuccessTests st) mnt-                , randomSeed                = rnd2-                , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)-                , expectedFailure           = expect+              -- Don't add coverage info from this test+              st{ numDiscardedTests         = numDiscardedTests st' + 1+                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1+                , randomSeed = rnd2                 } f         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 st' res ts+            theOutput <- terminalOutput (terminal st')             if not (expect res) then-              return Success{ labels = summary st,-                              numTests = numSuccessTests st+1,+              return Success{ labels = S.labels st',+                              classes = S.classes st',+                              tables = S.tables st',+                              numTests = numSuccessTests st'+1,+                              numDiscarded = numDiscardedTests st',                               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 st' -- correct! (this will be split first)                             , usedSize        = size-                            , numTests        = numSuccessTests st+1+                            , numTests        = numSuccessTests st'+1+                            , numDiscarded    = numDiscardedTests st'                             , numShrinks      = numShrinks                             , numShrinkTries  = totFailed                             , numShrinkFinal  = lastFailed                             , output          = theOutput                             , reason          = P.reason res                             , theException    = P.theException res-                            , labels          = summary st                             , failingTestCase = testCase+                            , failingLabels   = P.labels res+                            , failingClasses  = Set.fromList (P.classes res)                             }  where   (rnd1,rnd2) = split (randomSeed st)@@ -367,83 +420,73 @@       where         showNumTryShrinks = full && numTryShrinks st > 0 -summary :: State -> [(String, Double)]-summary st = reverse-           . sortBy (comparing snd)-           . map (\ss -> (head ss, fromIntegral (length ss) * 100 / fromIntegral (numSuccessTests st)))-           . group-           . sort-           $ [ concat (intersperse ", " s')-             | s <- collected st-               -- HACK: don't print out labels that were created by 'cover'.-             , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ]-             , not (null s')-             ]- success :: State -> IO ()-success st =-  case allLabels ++ covers of-    []    -> do putLine (terminal st) "."-    [pt]  -> do putLine (terminal st)-                  ( " ("-                 ++ dropWhile isSpace pt-                 ++ ")."-                  )-    cases -> do putLine (terminal st) ":"-                mapM_ (putLine $ terminal st) cases- where-  allLabels :: [String]-  allLabels = map (formatLabel (numSuccessTests st) True) (summary st)--  covers :: [String]-  covers = [ ("only " ++ formatLabel (numSuccessTests st) False (l, p) ++ ", not " ++ show reqP ++ "%")-           | (l, reqP, p) <- insufficientlyCovered st ]+success st = do+  mapM_ (putLine $ terminal st) (paragraphs [short, long])+  where+    (short, long) =+      case labelsAndTables st of+        ([msg], long) ->+          ([" (" ++ dropWhile isSpace msg ++ ")."], long)+        ([], long) ->+          (["."], long)+        (short, long) ->+          (":":short, long) -formatLabel :: Int -> Bool -> (String, Double) -> String-formatLabel n pad (x, p) = showP pad p ++ " " ++ x- where-  showP :: Bool -> Double -> String-  showP pad p =-    (if pad && p < 10 then " " else "") ++-    printf "%.*f" places p ++ "%"+labelsAndTables :: State -> ([String], [String])+labelsAndTables st = (labels, tables)+  where+    labels :: [String]+    labels =+      paragraphs $+        [ showTable (numSuccessTests st) Nothing m+        | m <- S.classes st:Map.elems numberedLabels ] -  -- Show no decimal places if <= 100 successful tests,-  -- one decimal place if <= 1000 successful tests,-  -- two decimal places if <= 10000 successful tests, and so on.-  places :: Integer-  places =-    ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0+    numberedLabels :: Map Int (Map String Int)+    numberedLabels =+      Map.fromListWith (Map.unionWith (+)) $+        [ (i, Map.singleton l n)+        | (labels, n) <- Map.toList (S.labels st),+          (i, l) <- zip [0..] labels ] -labelCount :: String -> State -> Int-labelCount l st =-  -- XXX in case of a disjunction, a label can occur several times,-  -- need to think what to do there-  length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ]+    tables :: [String]+    tables =+      paragraphs $+        [ showTable (sum (Map.elems m)) (Just table) m+        | (table, m) <- Map.toList (S.tables st) ] +++        [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ")+         ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot+         | (mtable, label, tot, n, p) <- allCoverage st,+           insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] -percentage :: Integral a => State -> a -> Double-percentage st n =-  fromIntegral n * 100 / fromIntegral (numSuccessTests st)+showTable :: Int -> Maybe String -> Map String Int -> [String]+showTable k mtable m =+  [table ++ " " ++ total ++ ":" | Just table <- [mtable]] +++  (map format .+   -- Descending order of occurrences+   reverse . sortBy (comparing snd) .+   -- If #occurences the same, sort in increasing order of key+   -- (note: works because sortBy is stable)+   reverse . sortBy (comparing fst) $ Map.toList m)+  where+    format (key, v) =+      rpercent v k ++ " " ++ key -insufficientlyCovered :: State -> [(String, Int, Double)]-insufficientlyCovered st =-  [ (l, reqP, p)-  | (l, reqP) <- Map.toList (S.labels st),-    let p = percentage st (labelCount l st),-    p < fromIntegral reqP ]+    total = printf "(%d in total)" k  -------------------------------------------------------------------------- -- main shrinking loop  foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) foundFailure st res ts =-  do localMin st{ numTryShrinks = 0 } res res ts+  do localMin st{ numTryShrinks = 0 } res ts -localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result)+localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) -- Don't try to shrink for too long-localMin st res _ ts+localMin st res ts   | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st =     localMinFound st res-localMin st res _ ts = do+localMin st res ts = do   r <- tryEvaluateIO $     putTemp (terminal st) (failureSummary st res)   case r of@@ -465,9 +508,9 @@     res' <- callbackPostTest st res'     if ok res' == Just False       then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1,-                        numTryShrinks     = 0 } res' res ts'+                        numTryShrinks     = 0 } res' ts'       else localMin st{ numTryShrinks    = numTryShrinks st + 1,-                        numTotTryShrinks = numTotTryShrinks st + 1 } res res ts+                        numTotTryShrinks = numTotTryShrinks st + 1 } res ts  localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res =@@ -494,6 +537,73 @@       tryEvaluateIO $ putLine (terminal st) (show err)       return ()     Right () -> return ()++----------------------------------------------------------------------+-- computing coverage++sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool+sufficientlyCovered confidence n k p =+  -- Accept the coverage if, with high confidence, the actual probability is+  -- at least 0.9 times the required one.+  wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p+  where+    err = certainty confidence+    tol = tolerance confidence++insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool+insufficientlyCovered Nothing n k p =+  fromIntegral k < p * fromIntegral n+insufficientlyCovered (Just err) n k p =+  wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p++-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval+-- Note:+-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf+-- suggests we should use a instead of a/2 for a one-sided test. Look+-- into this.+wilson :: Integer -> Integer -> Double -> Double+wilson k n z =+  (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf)+  where+    nf = fromIntegral n+    p = fromIntegral k / fromIntegral n++wilsonLow :: Integer -> Integer -> Double -> Double+wilsonLow k n a = wilson k n (invnormcdf (a/2))++wilsonHigh :: Integer -> Integer -> Double -> Double+wilsonHigh k n a = wilson k n (invnormcdf (1-a/2))++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 (labels, tables) = labelsAndTables st in+    foldr counterexample (property failed{P.reason = "Insufficient coverage"})+      (paragraphs [labels, tables])+  | otherwise = prop++allCoverage :: State -> [(Maybe String, String, Int, Int, Double)]+allCoverage st =+  [ (key, value, tot, n, p)+  | ((key, value), p) <- Map.toList (S.requiredCoverage st),+    let tot =+          case key of+            Just key -> Map.findWithDefault 0 key totals+            Nothing -> numSuccessTests st,+    let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ]+  where+    combinedCounts :: Map (Maybe String) (Map String Int)+    combinedCounts =+      Map.insert Nothing (S.classes st)+        (Map.mapKeys Just (S.tables st))++    totals :: Map String Int+    totals = fmap (sum . Map.elems) (S.tables st)  -------------------------------------------------------------------------- -- the end.

@@ -1,4 +1,5 @@--- | Terminal control. Internal QuickCheck module.+{-# OPTIONS_HADDOCK hide #-}+-- | Terminal control and text helper functions. Internal QuickCheck module. module Test.QuickCheck.Text   ( Str(..)   , ranges@@ -9,9 +10,13 @@   , oneLine   , isOneLine   , bold+  , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage+  , drawTable, Cell(..)+  , paragraphs    , newTerminal   , withStdioTerminal+  , withHandleTerminal   , withNullTerminal   , terminalOutput   , handle@@ -38,6 +43,8 @@   )  import Data.IORef+import Data.List+import Text.Printf import Test.QuickCheck.Exception  --------------------------------------------------------------------------@@ -76,6 +83,74 @@ isOneLine :: String -> Bool isOneLine xs = '\n' `notElem` xs +ljust n xs = xs ++ replicate (n - length xs) ' '+rjust n xs = replicate (n - length xs) ' ' ++ xs+centre n xs =+  ljust n $+  replicate ((n - length xs) `div` 2) ' ' ++ xs++lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String+lpercent n k =+  lpercentage (fromIntegral n / fromIntegral k) k++rpercent n k =+  rpercentage (fromIntegral n / fromIntegral k) k++lpercentage, rpercentage :: Integral a => Double -> a -> String+lpercentage p n =+  printf "%.*f" places (100*p) ++ "%"+  where+    -- Show no decimal places if k <= 100,+    -- one decimal place if k <= 1000,+    -- two decimal places if k <= 10000, and so on.+    places :: Integer+    places =+      ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0++rpercentage p n = padding ++ lpercentage p n+  where+    padding = if p < 0.1 then " " else ""++data Cell = LJust String | RJust String | Centred String deriving Show++text :: Cell -> String+text (LJust xs) = xs+text (RJust xs) = xs+text (Centred xs) = xs++-- Flatten a table into a list of rows+flattenRows :: [[Cell]] -> [String]+flattenRows rows = map row rows+  where+    cols = transpose rows+    widths = map (maximum . map (length . text)) cols++    row cells = intercalate " " (zipWith cell widths cells)+    cell n (LJust xs) = ljust n xs+    cell n (RJust xs) = rjust n xs+    cell n (Centred xs) = centre n xs++-- Draw a table given a header and contents+drawTable :: [String] -> [[Cell]] -> [String]+drawTable headers table =+  [line] +++  [border '|' ' ' header | header <- headers] +++  [line | not (null headers) && not (null rows)] +++  [border '|' ' ' row | row <- rows] +++  [line]+  where+    rows = flattenRows table++    headerwidth = maximum (0:map length headers)+    bodywidth = maximum (0:map length rows)+    width = max headerwidth bodywidth++    line = border '+' '-' $ replicate width '-'+    border x y xs = [x, y] ++ centre width xs ++ [y, x]++paragraphs :: [[String]] -> [String]+paragraphs = intercalate [""] . filter (not . null)+ bold :: String -> String -- not portable: --bold s = "\ESC[1m" ++ s ++ "\ESC[0m"@@ -101,11 +176,22 @@   hSetBuffering stderr LineBuffering   action `finally` hSetBuffering stderr mode +withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a+withHandleTerminal outh merrh action = do+  let+    err =+      case merrh of+        Nothing -> const (return ())+        Just errh -> handle errh+  newTerminal (handle outh) err >>= action+ withStdioTerminal :: (Terminal -> IO a) -> IO a withStdioTerminal action = do   isatty <- hIsTerminalDevice stderr-  let err = if isatty then handle stderr else const (return ())-  withBuffering (newTerminal (handle stdout) err >>= action)+  if isatty then+    withBuffering (withHandleTerminal stdout (Just stderr) action)+   else+    withBuffering (withHandleTerminal stdout Nothing action)  withNullTerminal :: (Terminal -> IO a) -> IO a withNullTerminal action =

@@ -1,3 +1,55 @@+QuickCheck 2.12 (release 2018-09-03)+	* Silently breaking changes!+		- The Arbitrary instance for Word now generates only small+		  values, the same as Int+		- cover no longer causes a property failure if coverage is+		  insufficient. It just prints a warning. (But see next item!)++	* Overhaul of label/cover family of combinators:+		- New property combinator checkCoverage, which checks coverage+		  requirements in a statistically sound way, and *does* fail if+		  they are not met.+		- Order of arguments to cover swapped, to make it easier to+		  switch between classify and cover+		- New combinators tabulate and coverTable, for reporting test+		  case distribution more flexibly than label.+		- When label is called multiple times in a property, each call+		  produces a separate table of frequencies.+	+	* New functions:+		- (=/=): like (/=), but prints a counterexample+		  (thanks to tom-bop)+		- forAllShow/forAllShrinkShow: quantification using an+		  explicit show function (thanks to Stevan Andjelkovic)+		- forAllBlind/forAllShrinkBlind: quantification without+		  printing anything+		- verboseShrinking: see how a counterexample is shrunk+		- labelledExamples: given a property which uses label,+		  generate an example test case for each label+		- idempotentIOProperty: a variant of ioProperty which shrinks+		  better but only works for idempotent I/O actions++	* Other improvements:+		- MonadFix Gen instance (thanks to Jon Fowler)+		- Rational numbers shrink using continued fractions+		  (thanks to Justus Sagemüller)+		- Function instances for Const, Identity, and the types in+		  Data.Monoid; instance Functor Fun (thanks to Erik Schnetter+		  and Xia Li-yao)+		- More of Test.QuickCheck.Function is exported from+		  Test.QuickCheck+		- Semantics of .||. changed to improve short-circuiting:+		  if the left argument's precondition is false, the right+		  argument is not evaluated and the whole disjunction is+		  considered to have a false precondition+		- Bug fix: suchThatMaybe always increased size to at least 1+	+	* Miscellaneous API changes:+		- Result type has changed a bit:+			- InsufficientCovered constructor is gone+			- Type of labels has changed+			- New fields classes, tables+ QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) 	* Cosmetic fixes. 

@@ -107,7 +107,7 @@   insert x h ==? (x : toList h)  prop_RemoveMin (h :: Heap Int) =-  cover (size h > 1) 80 "non-trivial" $+  cover 80 (size h > 1) "non-trivial" $   case removeMin h of     Nothing     -> h ==? []     Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x])

@@ -167,7 +167,7 @@   insert x h ==? (x : toList h)  prop_RemoveMin (HeapPP _ h) =-  cover (size h > 1) 80 "non-trivial" $+  cover 80 (size h > 1) "non-trivial" $   case removeMin h of     Nothing     -> h ==? []     Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x])

@@ -70,7 +70,7 @@     LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21     EQ -> Node x (s11 `union` s21) (s12 `union` s22)     --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22)-    GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 +    GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 -} s1             `union` Empty = s1 Empty          `union` s2    = s2@@ -88,7 +88,7 @@  where   (s11,s12) = split x s1   (s21,s22) = split x s2-  + mapp :: (a -> b) -> Set a -> Set b mapp f Empty          = Empty mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2)@@ -172,7 +172,7 @@   unit x ==? [x]  prop_Size (s :: Set Int) =-  cover (size s >= 15) 60 "large" $+  cover 60 (size s >= 15) "large" $     size s == length (toList s)  prop_Insert x (s :: Set Int) =@@ -196,7 +196,7 @@   s ==? xs && xs == sort xs  where   xs = toSortedList s-  + --  whenFail (putStrLn ("Result: " ++ show (fromList xs))) $  prop_FromList' (xs :: [Int]) =

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}  module Main where @@ -15,6 +15,10 @@ instance (Show a, Read a) => Function (D a) where   function = functionShow -main :: IO ()-main = quickCheck $ \(Fun _ f) ->+prop_coarbitrary (Fun _ f) =+  expectFailure $+  withMaxSuccess 1000 $   f (C1 (2::Int)) `elem` [0, 1 :: Int]++return []+main = do True <- $quickCheckAll; return ()

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}  module Main where @@ -10,8 +10,11 @@  instance Arbitrary Nat +prop_shrink =+  genericShrink (S (S Z)) === [S Z] .&&.+  genericShrink [0::Int] === [[]] +return []+ main :: IO ()-main = do-  print $ genericShrink (S (S Z)) == [S Z]-  print $ genericShrink [0::Int] == [[]]+main = do True <- $quickCheckAll; return ()

@@ -26,7 +26,7 @@ path p (Path xs) = all p xs  somePath :: (a -> Bool) -> Path a -> Property-somePath p = expectFailure . path (not . p)+somePath p = expectFailure . withMaxSuccess 1000 . path (not . p)  newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) @@ -130,13 +130,12 @@  reachesBound :: (Bounded a, Integral a, Arbitrary a) =>   a -> Property-reachesBound x = expectFailure (x < 3 * (maxBound `div` 4))+reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4)))  prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property prop_reachesBound_Int32 = reachesBound :: Int32 -> Property prop_reachesBound_Int64 = reachesBound :: Int64 -> Property-prop_reachesBound_Word = reachesBound :: Word -> Property prop_reachesBound_Word8 = reachesBound :: Word8 -> Property prop_reachesBound_Word16 = reachesBound :: Word16 -> Property prop_reachesBound_Word32 = reachesBound :: Word32 -> Property@@ -155,4 +154,4 @@ prop_B1 (B1 n) = expectFailure $ n === n + 1  return []-main = $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print+main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return ()

@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell, RecursiveDo #-}+import Test.QuickCheck+import Control.Monad.Fix++-- A simple (not complete) test for the MonadFix instance.+cyclicList :: Gen [Int]+cyclicList = do+  rec xs <- fmap (:ys) arbitrary+      ys <- fmap (:xs) arbitrary+  return xs++prop_cyclic :: Property+prop_cyclic =+  forAll (Blind <$> cyclicList) $ \(Blind xs) ->+    -- repeats with period 2+    and $ take 100 $ zipWith (==) xs (drop 2 xs)++prop_period2 :: Property+prop_period2 =+  expectFailure $+  forAll (Blind <$> cyclicList) $ \(Blind xs) ->+    -- does not always repeat with period 1+    and $ take 100 $ zipWith (==) xs (drop 1 xs)++return []+main = do True <- $quickCheckAll; return ()

@@ -0,0 +1,94 @@+-- Check that the terminal output works correctly.+{-# LANGUAGE TemplateHaskell, DeriveGeneric #-}+import Test.QuickCheck+import Test.QuickCheck.Text+import System.Process+import System.IO+import Control.Exception+import GHC.Generics+import Control.DeepSeq++data Command =+    PutPart String+  | PutLine String+  | PutTemp String+  deriving (Eq, Ord, Show, Generic)++instance Arbitrary Command where+  arbitrary =+    oneof [+      PutPart <$> line,+      PutLine <$> line,+      PutTemp <$> line]+    where+      line = filter (/= '\n') <$> arbitrary+  shrink = genericShrink++exec :: Terminal -> Command -> IO ()+exec tm (PutPart xs) = putPart tm xs+exec tm (PutLine xs) = putLine tm xs+exec tm (PutTemp xs) = putTemp tm xs++eval :: [Command] -> String+eval = concatMap eval1+  where+    eval1 (PutPart xs) = xs+    eval1 (PutLine xs) = xs ++ "\n"+    -- PutTemp only has an effect on stderr+    eval1 (PutTemp xs) = ""++-- Evaluate the result of printing a given string, taking backspace+-- characters into account.+format :: String -> String+format xs = format1 [] [] xs+  where+    -- Arguments: text before the cursor (in reverse order),+    -- text after the cursor, text to print+    format1 xs ys [] = line xs ys+    -- \n emits a new line+    format1 xs ys ('\n':zs) = line xs ys ++ "\n" ++ format1 [] [] zs+    -- \b moves the cursor to the left+    format1 (x:xs) ys ('\b':zs) = format1 xs (x:xs) zs+    -- beginning of line: \b ignored+    format1 [] ys ('\b':zs) = format1 [] ys zs+    -- Normal printing puts the character before the cursor,+    -- and overwrites the next character after the cursor+    format1 xs ys (z:zs) = format1 (z:xs) (drop 1 ys) zs++    line xs ys = reverse xs ++ ys++-- Check that the terminal satisfies the following properties:+-- * The text written to stdout matches what's returned by terminalOutput+-- * The output agrees with the model implementation 'eval'+-- * Anything written to stderr (presumably by putTemp) is erased+prop_terminal :: [Command] -> Property+prop_terminal cmds =+  withMaxSuccess 1000 $ ioProperty $+  withPipe $ \stdout_read stdout_write ->+  withPipe $ \stderr_read stderr_write -> do+    out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do+      mapM_ (exec tm) (cmds ++ [PutPart ""])+      terminalOutput tm+    stdout <- stdout_read+    stderr <- stderr_read+    return $ conjoin [+        counterexample "output == terminalOutput" $ stdout === out,+        counterexample "output == model" $ out === eval cmds,+        counterexample "putTemp erased" $ all (== ' ') (format stderr) ]+  where+    withPipe :: (IO String -> Handle -> IO a) -> IO a+    withPipe action = do+      (readh, writeh) <- createPipe+      hSetEncoding readh utf8+      hSetEncoding writeh utf8+      let+        read = do+          hClose writeh+          contents <- hGetContents readh+          return $!! contents+      action read writeh `finally` do+        hClose readh+        hClose writeh++return []+main = do True <- $quickCheckAll; return ()