summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNickSmallbone <>2018-09-03 02:14:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-03 02:14:00 (GMT)
commitd89e2a5e3209563c2280f25caac0ba6bea597da7 (patch)
treecdd496f0b43b1876b7541fdeb1519762fd5af3fd
parent2c3f9fce021722b750ee1693973eb64ba3619084 (diff)
version 2.122.12
-rw-r--r--LICENSE4
-rw-r--r--QuickCheck.cabal61
-rw-r--r--README6
-rw-r--r--Test/QuickCheck.hs209
-rw-r--r--Test/QuickCheck/All.hs6
-rw-r--r--Test/QuickCheck/Arbitrary.hs84
-rw-r--r--Test/QuickCheck/Exception.hs10
-rw-r--r--Test/QuickCheck/Features.hs106
-rw-r--r--Test/QuickCheck/Function.hs43
-rw-r--r--Test/QuickCheck/Gen.hs22
-rw-r--r--Test/QuickCheck/Modifiers.hs3
-rw-r--r--Test/QuickCheck/Monadic.hs5
-rw-r--r--Test/QuickCheck/Property.hs419
-rw-r--r--Test/QuickCheck/Random.hs1
-rw-r--r--Test/QuickCheck/State.hs89
-rw-r--r--Test/QuickCheck/Test.hs420
-rw-r--r--Test/QuickCheck/Text.hs92
-rw-r--r--changelog52
-rw-r--r--examples/Heap.hs2
-rw-r--r--examples/Heap_Program.hs2
-rw-r--r--examples/Set.hs8
-rw-r--r--tests/GCoArbitraryExample.hs10
-rw-r--r--tests/GShrinkExample.hs11
-rw-r--r--tests/Generators.hs7
-rw-r--r--tests/MonadFix.hs26
-rw-r--r--tests/Terminal.hs94
26 files changed, 1381 insertions, 411 deletions
diff --git a/LICENSE b/LICENSE
index 9c61b87..2e2d4b5 100644
--- a/LICENSE
+++ b/LICENSE
@@ -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:
diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index 4d7dbed..d0c1039 100644
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -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.
+ .
+ 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".
.
- 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.
+ If you are new to QuickCheck, you can try looking at the following resources:
.
- 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.
+ * 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.
.
- 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://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 head
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 @@ library
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 @@ library
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 @@ Test-Suite test-quickcheck-gshrink
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
diff --git a/README b/README
index 3d64f26..832eebc 100644
--- a/README
+++ b/README
@@ -4,5 +4,7 @@ Install it in the usual way:
$ 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
diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs
index f297876..41955a2 100644
--- a/Test/QuickCheck.hs
+++ b/Test/QuickCheck.hs
@@ -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 @@ To use QuickCheck on your own data types you will need to write 'Arbitrary'
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 @@ module Test.QuickCheck
, 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 @@ module Test.QuickCheck
, 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 @@ module Test.QuickCheck
, 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 @@ module Test.QuickCheck
, 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 @@ module Test.QuickCheck
, 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 @@ module Test.QuickCheck
, 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.Property hiding ( Result(..) )
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
diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs
index ba517c3..8230495 100644
--- a/Test/QuickCheck/All.hs
+++ b/Test/QuickCheck/All.hs
@@ -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 @@ runQuickCheckAll ps qc =
Failure { } -> False
NoExpectedFailure { } -> False
GaveUp { } -> False
- InsufficientCoverage { } -> False
diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs
index 1137fe8..4239cf7 100644
--- a/Test/QuickCheck/Arbitrary.hs
+++ b/Test/QuickCheck/Arbitrary.hs
@@ -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 @@ instance Arbitrary Int64 where
shrink = shrinkIntegral
instance Arbitrary Word where
- arbitrary = arbitrarySizedBoundedIntegral
+ arbitrary = arbitrarySizedIntegral
shrink = shrinkIntegral
instance Arbitrary Word8 where
@@ -755,53 +758,26 @@ instance Arbitrary CUIntMax where
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 :: Fractional a => Gen a
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 @@ shrinkIntegral x =
(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
diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs
index 502b4a2..b9cdaad 100644
--- a/Test/QuickCheck/Exception.hs
+++ b/Test/QuickCheck/Exception.hs
@@ -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 _ = False
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
diff --git a/Test/QuickCheck/Features.hs b/Test/QuickCheck/Features.hs
new file mode 100644
index 0000000..b81d5b5
--- /dev/null
+++ b/Test/QuickCheck/Features.hs
@@ -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
diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs
index 2a36d6d..4b410b4 100644
--- a/Test/QuickCheck/Function.hs
+++ b/Test/QuickCheck/Function.hs
@@ -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 @@ module Test.QuickCheck.Function
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 qualified Data.Sequence as Sequence
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 @@ functionMapWith function g h f = Map g h (function (\b -> f (h b)))
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 Word32 where
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
@@ -454,6 +494,9 @@ shrinkFun shr (Map g h p) =
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.
--
diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs
index f32d538..a3f4a1f 100644
--- a/Test/QuickCheck/Gen.hs
+++ b/Test/QuickCheck/Gen.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
#ifndef NO_ST_MONAD
{-# LANGUAGE Rank2Types #-}
@@ -21,6 +22,9 @@ import Control.Monad
, filterM
)
+import Control.Monad.Fix
+ ( MonadFix(..) )
+
import Control.Applicative
( Applicative(..) )
@@ -62,6 +66,12 @@ instance Monad Gen where
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 @@ variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n)
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 @@ gen `suchThatMap` f =
-- | 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.
diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs
index e8ef647..90b736f 100644
--- a/Test/QuickCheck/Modifiers.hs
+++ b/Test/QuickCheck/Modifiers.hs
@@ -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:
--
-- @
diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs
index 9a3c470..a8f3043 100644
--- a/Test/QuickCheck/Monadic.hs
+++ b/Test/QuickCheck/Monadic.hs
@@ -185,6 +185,7 @@ run m = MkPropertyM (liftM (m >>=) . promote)
-- | 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 @@ pick gen = MkPropertyM $ \k ->
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
diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs
index 9a14fd7..f99d49a 100644
--- a/Test/QuickCheck/Property.hs
+++ b/Test/QuickCheck/Property.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_HADDOCK hide #-}
-- | Combinators for constructing properties.
{-# LANGUAGE CPP #-}
#ifndef NO_TYPEABLE
@@ -16,7 +17,7 @@ import Test.QuickCheck.Gen.Unsafe
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 @@ import Control.DeepSeq
#ifndef NO_TYPEABLE
import Data.Typeable (Typeable)
#endif
+import Data.Maybe
--------------------------------------------------------------------------
-- fixities
@@ -94,6 +96,12 @@ class Testable prop where
-- | 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 @@ morallyDubiousIOProperty = ioProperty
--
-- 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 @@ data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator
-- | 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 @@ succeeded, failed, rejected :: Result
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 @@ mapProp f = MkProperty . fmap f . unProperty . property
--------------------------------------------------------------------------
-- ** 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 @@ shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (p
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 @@ whenFail' m =
-- | 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 @@ again = mapTotalResult (\res -> res{ abort = False })
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 @@ withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }
-- 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 @@ label s = classify True s
-- 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 @@ classify :: Testable prop =>
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 { 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 {
- 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 { 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 @@ forAll :: (Show a, Testable prop)
=> 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 @@ conjoin ps =
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 @@ conjoin ps =
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 @@ disjoin ps =
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 @@ disjoin ps =
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
@@ -632,6 +905,16 @@ 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.
total :: NFData a => a -> Property
diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs
index 277ed0f..e81b26e 100644
--- a/Test/QuickCheck/Random.hs
+++ b/Test/QuickCheck/Random.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_HADDOCK hide #-}
-- | A wrapper around the system random number generator. Internal QuickCheck module.
{-# LANGUAGE CPP #-}
#ifndef NO_SAFE_HASKELL
diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs
index 6aa7e4c..ca8f179 100644
--- a/Test/QuickCheck/State.hs
+++ b/Test/QuickCheck/State.hs
@@ -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 @@ import Data.Set(Set)
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.
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
index 77ab445..c68a361 100644
--- a/Test/QuickCheck/Test.hs
+++ b/Test/QuickCheck/Test.hs
@@ -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 @@ module Test.QuickCheck.Test where
-- 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
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 @@ import Data.List
, 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 Args
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 @@ quickCheckResult p = quickCheckWithResult stdArgs p
-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.
quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
-quickCheckWithResult a p = (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 @@ quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerm
, 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 @@ verboseCheckWithResult a p = quickCheckWithResult a (verbose p)
--------------------------------------------------------------------------
-- 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 @@ failureSummaryAndReason st res = (summary, full)
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)
+
+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 ]
+
+ 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 ]
+
+ 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 ]]
+
+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
-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 ++ "%"
-
- -- 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
-
-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' ]
-
-percentage :: Integral a => State -> a -> Double
-percentage st n =
- fromIntegral n * 100 / fromIntegral (numSuccessTests st)
-
-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 @@ localMin' st res (t:ts) =
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 =
@@ -495,5 +538,72 @@ callbackPostFinalFailure st res = do
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.
diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs
index 569b906..32c8a36 100644
--- a/Test/QuickCheck/Text.hs
+++ b/Test/QuickCheck/Text.hs
@@ -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 @@ module Test.QuickCheck.Text
, oneLine
, isOneLine
, bold
+ , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage
+ , drawTable, Cell(..)
+ , paragraphs
, newTerminal
, withStdioTerminal
+ , withHandleTerminal
, withNullTerminal
, terminalOutput
, handle
@@ -38,6 +43,8 @@ import System.IO
)
import Data.IORef
+import Data.List
+import Text.Printf
import Test.QuickCheck.Exception
--------------------------------------------------------------------------
@@ -76,6 +83,74 @@ oneLine = unwords . words
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 @@ withBuffering action = do
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 =
diff --git a/changelog b/changelog
index 2a1deb8..1c77be8 100644
--- a/changelog
+++ b/changelog
@@ -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.
diff --git a/examples/Heap.hs b/examples/Heap.hs
index 3f701b7..c3900a9 100644
--- a/examples/Heap.hs
+++ b/examples/Heap.hs
@@ -107,7 +107,7 @@ prop_Insert x (h :: Heap Int) =
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])
diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs
index e5f406c..d9db2de 100644
--- a/examples/Heap_Program.hs
+++ b/examples/Heap_Program.hs
@@ -167,7 +167,7 @@ prop_Insert x (HeapPP _ h) =
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])
diff --git a/examples/Set.hs b/examples/Set.hs
index b380e28..6e0a966 100644
--- a/examples/Set.hs
+++ b/examples/Set.hs
@@ -70,7 +70,7 @@ s1@(Node x s11 s12) `union` s2@(Node y s21 s22) =
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 @@ split x (Node y s1 s2) =
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 @@ prop_Unit (x :: Int) =
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 @@ prop_ToSortedList (s :: Set Int) =
s ==? xs && xs == sort xs
where
xs = toSortedList s
-
+
-- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $
prop_FromList' (xs :: [Int]) =
diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs
index 34ac551..e5c0da8 100644
--- a/tests/GCoArbitraryExample.hs
+++ b/tests/GCoArbitraryExample.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}
module Main where
@@ -15,6 +15,10 @@ instance CoArbitrary a => CoArbitrary (D a)
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 ()
diff --git a/tests/GShrinkExample.hs b/tests/GShrinkExample.hs
index c88e559..4fa4dc7 100644
--- a/tests/GShrinkExample.hs
+++ b/tests/GShrinkExample.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}
module Main where
@@ -10,8 +10,11 @@ data Nat = Z | S Nat deriving (Eq, Show, Generic)
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 ()
diff --git a/tests/Generators.hs b/tests/Generators.hs
index 29469d4..35c1d75 100644
--- a/tests/Generators.hs
+++ b/tests/Generators.hs
@@ -26,7 +26,7 @@ path :: (a -> Bool) -> Path a -> Bool
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 @@ prop_nonnegative_bound = somePathInt getNonNegative (== 0)
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 -> Property
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 ()
diff --git a/tests/MonadFix.hs b/tests/MonadFix.hs
new file mode 100644
index 0000000..7c80621
--- /dev/null
+++ b/tests/MonadFix.hs
@@ -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 ()
diff --git a/tests/Terminal.hs b/tests/Terminal.hs
new file mode 100644
index 0000000..026f473
--- /dev/null
+++ b/tests/Terminal.hs
@@ -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 ()