diff --git a/LICENSE b/LICENSE --- 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 --- 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 -Maintainer: Nick Smallbone ; see also QuickCheck mailing list (https://groups.google.com/forum/#!forum/haskell-quickcheck) +Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC >= 7.4 +Tested-with: GHC >= 7.0 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs Description: QuickCheck is a library for random testing of program properties. - . The programmer provides a specification of the program, in the form of properties which functions should satisfy, and QuickCheck then tests that the properties hold in a large number of randomly generated cases. + Specifications are expressed in Haskell, using combinators provided by + QuickCheck. QuickCheck provides combinators to define properties, observe the + distribution of test data, and define test data generators. . - Specifications are expressed in Haskell, using combinators defined in the - QuickCheck library. QuickCheck provides combinators to define properties, - observe the distribution of test data, and define test data generators. + Most of QuickCheck's functionality is exported by the main "Test.QuickCheck" + module. The main exception is the monadic property testing library in + "Test.QuickCheck.Monadic". . - The - explains how to write generators and properties; - it is out-of-date in some details but still full of useful advice. + If you are new to QuickCheck, you can try looking at the following resources: . - A user of QuickCheck has written an unofficial, but detailed, tutorial which - you can find at - . + * The . + It's a bit out-of-date in some details and doesn't cover newer QuickCheck features, + but is still full of good advice. + * , + a detailed tutorial written by a user of QuickCheck. + . + The + companion package provides instances for types in Haskell Platform packages + at the cost of additional dependencies. extra-source-files: README @@ -49,14 +55,14 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.11.3 + tag: 2.12 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True library - Build-depends: base >=4.3 && <5, random, containers + Build-depends: base >=4.3 && <5, random, containers, erf >= 2 -- Modules that are always built. Exposed-Modules: @@ -72,7 +78,8 @@ Test.QuickCheck.Poly, Test.QuickCheck.State, Test.QuickCheck.Random, - Test.QuickCheck.Exception + Test.QuickCheck.Exception, + Test.QuickCheck.Features -- GHC-specific modules. if impl(ghc) @@ -88,8 +95,8 @@ else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 7.2) - cpp-options: -DNO_FOREIGN_C_USECONDS + if !impl(ghc >= 7.4) + cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -- The new generics appeared in GHC 7.2... if impl(ghc < 7.2) @@ -169,3 +176,19 @@ buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim + +Test-Suite test-quickcheck-terminal + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Terminal.hs + build-depends: base, process, deepseq, QuickCheck + if !impl(ghc >= 7.10) + buildable: False + +Test-Suite test-quickcheck-monadfix + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: MonadFix.hs + build-depends: base, QuickCheck + if !impl(ghc >= 7.10) + buildable: False diff --git a/README b/README --- a/README +++ b/README @@ -4,5 +4,7 @@ $ cabal install -There is a Google group for user discussion and questions at -https://groups.google.com/forum/#!forum/haskell-quickcheck. +The quickcheck-instances [1] companion package provides instances for types in +Haskell Platform packages at the cost of additional dependencies. + +[1]: http://hackage.haskell.org/package/quickcheck-instances diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -1,6 +1,8 @@ {-| The gives detailed information about using QuickCheck effectively. +You can also try , +a tutorial written by a user of QuickCheck. To start using QuickCheck, write down your property as a function returning @Bool@. For example, to check that reversing a list twice gives back the same list you can write: @@ -26,9 +28,6 @@ instances for those types. See the for details about how to do that. - -This module exports most of QuickCheck's functionality, but see also -"Test.QuickCheck.Monadic" which helps with testing impure or monadic code. -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL @@ -53,6 +52,10 @@ , verboseCheckResult #ifndef NO_TEMPLATE_HASKELL -- ** Testing all properties in a module + + -- | These functions test all properties in the current module, using + -- Template Haskell. You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ + -- pragma in your module for any of these to work. , quickCheckAll , verboseCheckAll , forAllProperties @@ -63,7 +66,30 @@ , monomorphic #endif - -- * Random generation + -- * The 'Arbitrary' typeclass: generation of random values + , Arbitrary(..) + -- ** Helper functions for implementing 'shrink' +#ifndef NO_GENERICS + , genericShrink + , subterms + , recursivelyShrink +#endif + , shrinkNothing + , shrinkList + , shrinkMap + , shrinkMapBy + , shrinkIntegral + , shrinkRealFrac + + -- ** Lifting of 'Arbitrary' to unary and binary type constructors + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + + -- * The 'Gen' monad: combinators for building random generators , Gen -- ** Generator combinators , choose @@ -78,38 +104,20 @@ , suchThat , suchThatMap , suchThatMaybe + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 + -- ** Generators for lists , listOf , listOf1 , vectorOf + , vector , infiniteListOf + , infiniteList , shuffle , sublistOf - -- ** Generators which use Arbitrary - , vector , orderedList - , infiniteList - -- ** Running a generator - , generate - -- ** Generator debugging - , sample - , sample' - - -- * Arbitrary and CoArbitrary classes - , Arbitrary(..) - , CoArbitrary(..) - - -- ** Unary and Binary classes - , Arbitrary1(..) - , arbitrary1 - , shrink1 - , Arbitrary2(..) - , arbitrary2 - , shrink2 - - -- ** Helper functions for implementing arbitrary - , applyArbitrary2 - , applyArbitrary3 - , applyArbitrary4 + -- ** Generators for particular types , arbitrarySizedIntegral , arbitrarySizedNatural , arbitrarySizedFractional @@ -120,20 +128,52 @@ , arbitraryUnicodeChar , arbitraryASCIIChar , arbitraryPrintableChar - -- ** Helper functions for implementing shrink + -- ** Running generators + , generate + -- ** Debugging generators + , sample + , sample' + + -- * The 'Function' typeclass: generation of random shrinkable, showable functions + + -- | Example of use: + -- + -- >>> :{ + -- >>> let prop :: Fun String Integer -> Bool + -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" + -- >>> :} + -- >>> quickCheck prop + -- *** Failed! Falsifiable (after 3 tests and 134 shrinks): + -- {"elephant"->1, "monkey"->1, _->0} + -- + -- To generate random values of type @'Fun' a b@, + -- you must have an instance @'Function' a@. + -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, + -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. + -- See the @'Function' [a]@ instance for an example of the latter. + -- + -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. + , Fun (..) + , applyFun + , applyFun2 + , applyFun3 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + , Function (..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum + + -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way #ifndef NO_GENERICS + , CoArbitrary(..) , genericCoarbitrary - , genericShrink - , subterms - , recursivelyShrink #endif - , shrinkNothing - , shrinkList - , shrinkMap - , shrinkMapBy - , shrinkIntegral - , shrinkRealFrac - -- ** Helper functions for implementing coarbitrary , variant , coarbitraryIntegral , coarbitraryReal @@ -141,7 +181,36 @@ , coarbitraryEnum , (><) - -- ** Type-level modifiers for changing generator behavior + -- * Type-level modifiers for changing generator behavior + + -- | These types do things such as restricting the kind of test data that can be generated. + -- They can be pattern-matched on in properties as a stylistic + -- alternative to using explicit quantification. + -- + -- Examples: + -- + -- @ + -- -- Functions cannot be shown (but see 'Function') + -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = + -- takeWhile p xs ++ dropWhile p xs == xs + -- @ + -- + -- @ + -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = + -- take n xs ++ drop n xs == xs + -- @ + -- + -- @ + -- -- cycle does not work for empty lists + -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = + -- take n (cycle xs) == take n (xs ++ cycle xs) + -- @ + -- + -- @ + -- -- Instead of 'forAll' 'orderedList' + -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = + -- sort xs == xs + -- @ , Blind(..) , Fixed(..) , OrderedList(..) @@ -162,59 +231,63 @@ , UnicodeString(..) , PrintableString(..) - -- ** Functions - , Fun (..) - , applyFun - , applyFun2 - , applyFun3 -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , pattern Fn - , pattern Fn2 - , pattern Fn3 -#endif - , Function (..) - , functionMap - - -- * Properties + -- * Property combinators , Property, Testable(..) - -- ** Property combinators , forAll , forAllShrink + , forAllShow + , forAllShrinkShow + , forAllBlind + , forAllShrinkBlind , shrinking , (==>) + , Discard(..) + , discard , (===) + , (=/=) #ifndef NO_DEEPSEQ , total #endif , ioProperty - -- *** Controlling property execution + , idempotentIOProperty + -- ** Controlling property execution , verbose - , once - , again + , verboseShrinking + , noShrinking , withMaxSuccess , within - , noShrinking - -- *** Conjunction and disjunction + , once + , again + , mapSize + -- ** Conjunction and disjunction , (.&.) , (.&&.) , conjoin , (.||.) , disjoin - -- *** What to do on failure + -- ** What to do on failure , counterexample , printTestCase , whenFail , whenFail' , expectFailure - -- *** Analysing test distribution + -- * Analysing test case distribution , label , collect , classify + , tabulate + -- ** Checking test case distribution , cover - -- *** Miscellaneous - , Discard(..) - , discard - , mapSize + , coverTable + , checkCoverage + , checkCoverageWith + , Confidence(..) + , stdConfidence + -- ** Generating example test cases + , labelledExamples + , labelledExamplesWith + , labelledExamplesWithResult + , labelledExamplesResult ) where @@ -228,6 +301,8 @@ import Test.QuickCheck.Test import Test.QuickCheck.Exception import Test.QuickCheck.Function +import Test.QuickCheck.Features +import Test.QuickCheck.State #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs --- 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 @@ Failure { } -> False NoExpectedFailure { } -> False GaveUp { } -> False - InsufficientCoverage { } -> False diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- 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 @@ shrink = shrinkIntegral instance Arbitrary Word where - arbitrary = arbitrarySizedBoundedIntegral + arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral instance Arbitrary Word8 where @@ -755,53 +758,26 @@ arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral -#ifndef NO_NEWTYPE_DERIVING +#ifndef NO_CTYPES_CONSTRUCTORS -- The following four types have no Bounded instance, -- so we fake it by discovering the bounds at runtime. instance Arbitrary CClock where - arbitrary = fmap unBounds arbitrary - shrink = shrinkMap unBounds Bounds + arbitrary = fmap CClock arbitrary + shrink (CClock x) = map CClock (shrink x) instance Arbitrary CTime where - arbitrary = fmap unBounds arbitrary - shrink = shrinkMap unBounds Bounds + arbitrary = fmap CTime arbitrary + shrink (CTime x) = map CTime (shrink x) #ifndef NO_FOREIGN_C_USECONDS instance Arbitrary CUSeconds where - arbitrary = fmap unBounds arbitrary - shrink = shrinkMap unBounds Bounds + arbitrary = fmap CUSeconds arbitrary + shrink (CUSeconds x) = map CUSeconds (shrink x) instance Arbitrary CSUSeconds where - arbitrary = fmap unBounds arbitrary - shrink = shrinkMap unBounds Bounds + arbitrary = fmap CSUSeconds arbitrary + shrink (CSUSeconds x) = map CSUSeconds (shrink x) #endif - -newtype Bounds a = Bounds { unBounds :: a } - deriving (Eq, Ord, Num, Enum, Real, Show) - -instance (Ord a, Num a) => Bounded (Bounds a) where - -- assume max has all 1s in binary expansion - maxBound = maximum (nubIterate (\x -> 2*x+1) 1) - -- assume min has a leading 1 and rest 0s in binary expansion (or is 0) - minBound = minimum (0:nubIterate (*2) 1) - -instance (Num a, Real a, Enum a) => Integral (Bounds a) where - toInteger = fromIntegral . fromEnum - x `quotRem` y = - let (z, w) = toInteger x `quotRem` toInteger y in - (fromInteger z, fromInteger w) - -instance (Ord a, Num a, Real a, Enum a) => Arbitrary (Bounds a) where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - --- Like iterate, but stop when you reach an existing value. -nubIterate :: Eq a => (a -> a) -> a -> [a] -nubIterate f x = iter [] x - where - iter xs x - | x `elem` xs = [] - | otherwise = x:iter (x:xs) (f x) #endif instance Arbitrary CFloat where @@ -1016,8 +992,8 @@ arbitrarySizedFractional = sized $ \n -> let n' = toInteger n in - do a <- choose ((-n') * precision, n' * precision) - b <- choose (1, precision) + do b <- choose (1, precision) + a <- choose ((-n') * b, n' * b) return (fromRational (a % b)) where precision = 9999999999999 :: Integer @@ -1120,20 +1096,36 @@ (True, False) -> a + b < 0 (False, True) -> a + b > 0 --- | Shrink a fraction. +-- | Shrink a fraction, via continued-fraction approximations. shrinkRealFrac :: RealFrac a => a -> [a] -shrinkRealFrac x = - nub $ - [ -x - | x < 0 - ] ++ - map fromInteger (shrinkIntegral (truncate x)) +shrinkRealFrac a = shrinkRealFracToPrecision (abs a*1e-6) a +shrinkRealFracToPrecision :: RealFrac a + => a -- ^ "Epsilon" – the minimum deviation we consider + -> a -- ^ Value to shrink + -> [a] +shrinkRealFracToPrecision ε x + | x < 0 = 0 : ([id, negate] <*> filter (>0) (shrinkRealFracToPrecision ε $ -x)) + | x < ε = [0] + | not (x==x) = [] + | not (2*x>x) = 0 : takeWhile ([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 --- 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 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 --- /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 +-- [] +-- [] +-- +-- *** Found example of count x xs == 1 +-- 0 +-- [0] +-- [] +-- +-- *** Found example of count x xs >= 2 +-- 5 +-- [5,5] +-- [5] +-- +-- +++ 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 --- 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 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly +import Control.Applicative import Data.Char import Data.Word import Data.List( intersperse ) @@ -71,6 +75,8 @@ import Data.Int import Data.Complex import Data.Foldable(toList) +import Data.Functor.Identity +import qualified Data.Monoid as Monoid #ifndef NO_FIXED import Data.Fixed @@ -180,6 +186,12 @@ instance Function () where function f = Unit (f ()) +instance Function a => Function (Const a b) where + function = functionMap getConst Const + +instance Function a => Function (Identity a) where + function = functionMap runIdentity Identity + instance (Function a, Function b) => Function (a,b) where function = functionPairWith function function @@ -337,6 +349,34 @@ instance Function Word64 where function = functionIntegral +-- instances for Data.Monoid newtypes + +instance Function a => Function (Monoid.Dual a) where + function = functionMap Monoid.getDual Monoid.Dual + +instance Function Monoid.All where + function = functionMap Monoid.getAll Monoid.All + +instance Function Monoid.Any where + function = functionMap Monoid.getAny Monoid.Any + +instance Function a => Function (Monoid.Sum a) where + function = functionMap Monoid.getSum Monoid.Sum + +instance Function a => Function (Monoid.Product a) where + function = functionMap Monoid.getProduct Monoid.Product + +instance Function a => Function (Monoid.First a) where + function = functionMap Monoid.getFirst Monoid.First + +instance Function a => Function (Monoid.Last a) where + function = functionMap Monoid.getLast Monoid.Last + +#if MIN_VERSION_base(4,8,0) +instance Function (f a) => Function (Monoid.Alt f a) where + function = functionMap Monoid.getAlt Monoid.Alt +#endif + -- poly instances instance Function A where @@ -453,6 +493,9 @@ -- See also 'applyFun', and 'Fn' with GHC >= 7.8. data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) data Shrunk = Shrunk | NotShrunk deriving Eq + +instance Functor (Fun a) where + fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -- | A modifier for testing functions. diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs --- 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 @@ , filterM ) +import Control.Monad.Fix + ( MonadFix(..) ) + import Control.Applicative ( Applicative(..) ) @@ -62,6 +66,12 @@ in m' r2 n ) +instance MonadFix Gen where + mfix f = + MkGen $ \r n -> + let a = unGen (f a) r n + in a + -------------------------------------------------------------------------- -- ** Primitive generator combinators @@ -83,7 +93,7 @@ sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) --- | Generates the size parameter. Used to construct generators that depend on +-- | Returns the size parameter. Used to construct generators that depend on -- the size parameter. -- -- For example, 'listOf', which uses the size parameter as an upper bound on @@ -156,11 +166,13 @@ -- | Tries to generate a value that satisfies a predicate. -- If it fails to do so after enough attempts, returns @Nothing@. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) -gen `suchThatMaybe` p = sized (try 0 . max 1) +gen `suchThatMaybe` p = sized (\n -> try n (2*n)) where - try _ 0 = return Nothing - try k n = do x <- resize (2*k+n) gen - if p x then return (Just x) else try (k+1) (n-1) + try m n + | m > n = return Nothing + | otherwise = do + x <- resize m gen + if p x then return (Just x) else try (m+1) n -- | Randomly uses one of the given generators. The input list -- must be non-empty. diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs --- 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 --- a/Test/QuickCheck/Monadic.hs +++ b/Test/QuickCheck/Monadic.hs @@ -185,6 +185,7 @@ -- | Quantification in a monadic property, fits better with -- /do-notation/ than 'forAllM'. +-- __Note__: values generated by 'pick' do not shrink. pick :: (Monad m, Show a) => Gen a -> PropertyM m a pick gen = MkPropertyM $ \k -> do a <- gen @@ -200,8 +201,8 @@ wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b wp m k = run m >>= k --- | An alternative to quantification a monadic properties to 'pick', --- with a notation similar to 'forAll'. +-- | Quantification in monadic properties to 'pick', with a notation similar to +-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- 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.Arbitrary import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception -import Test.QuickCheck.State hiding (labels) +import Test.QuickCheck.State( State(terminal), Confidence(..) ) #ifndef NO_TIMEOUT import System.Timeout(timeout) @@ -34,6 +35,7 @@ #ifndef NO_TYPEABLE import Data.Typeable (Typeable) #endif +import Data.Maybe -------------------------------------------------------------------------- -- fixities @@ -94,6 +96,12 @@ -- | If a property returns 'Discard', the current test case is discarded, -- the same as if a precondition was false. +-- +-- An example is the definition of '==>': +-- +-- > (==>) :: Testable prop => Bool -> prop -> Property +-- > False ==> _ = property Discard +-- > True ==> p = property p data Discard = Discard instance Testable Discard where @@ -131,11 +139,22 @@ -- -- Warning: any random values generated inside of the argument to @ioProperty@ -- will not currently be shrunk. For best results, generate all random values --- before calling @ioProperty@. +-- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. +-- +-- Note: if your property does no quantification, it will only be tested once. +-- To test it repeatedly, use 'again'. ioProperty :: Testable prop => IO prop -> Property -ioProperty = +ioProperty prop = idempotentIOProperty (fmap noShrinking prop) + +-- | Do I/O inside a property. +-- +-- Warning: during shrinking, the I/O may not always be re-executed. +-- Instead, the I/O may be executed once and then its result retained. +-- If this is not acceptable, use 'ioProperty' instead. +idempotentIOProperty :: Testable prop => IO prop -> Property +idempotentIOProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . - promote . fmap (unProperty . noShrinking) + promote . fmap (unProperty . property) instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where property f = forAllShrink arbitrary shrink f @@ -216,16 +235,32 @@ -- | The result of a single test. data Result = MkResult - { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard - , expect :: Bool -- ^ indicates what the expected result of the property is - , reason :: String -- ^ a message indicating what went wrong - , theException :: Maybe AnException -- ^ the exception thrown, if any - , abort :: Bool -- ^ if True, the test should not be repeated - , maybeNumTests :: Maybe Int -- ^ stop after this many tests - , labels :: Map String Int -- ^ all labels used by this property - , stamp :: Set String -- ^ the collected labels for this test case - , callbacks :: [Callback] -- ^ the callbacks for this test case - , testCase :: [String] -- ^ the generated test case + { ok :: Maybe Bool + -- ^ result of the test case; Nothing = discard + , expect :: Bool + -- ^ indicates what the expected result of the property is + , reason :: String + -- ^ a message indicating what went wrong + , theException :: Maybe AnException + -- ^ the exception thrown, if any + , abort :: Bool + -- ^ if True, the test should not be repeated + , maybeNumTests :: Maybe Int + -- ^ stop after this many tests + , maybeCheckCoverage :: Maybe Confidence + -- ^ required coverage confidence + , labels :: [String] + -- ^ test case labels + , classes :: [String] + -- ^ test case classes + , tables :: [(String, String)] + -- ^ test case tables + , requiredCoverage :: [(Maybe String, String, Double)] + -- ^ required coverage + , callbacks :: [Callback] + -- ^ the callbacks for this test case + , testCase :: [String] + -- ^ the generated test case } exception :: String -> AnException -> Result @@ -250,16 +285,19 @@ where result = MkResult - { ok = undefined - , expect = True - , reason = "" - , theException = Nothing - , abort = True - , maybeNumTests = Nothing - , labels = Map.empty - , stamp = Set.empty - , callbacks = [] - , testCase = [] + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = True + , maybeNumTests = Nothing + , maybeCheckCoverage = Nothing + , labels = [] + , classes = [] + , tables = [] + , requiredCoverage = [] + , callbacks = [] + , testCase = [] } -------------------------------------------------------------------------- @@ -285,9 +323,10 @@ -------------------------------------------------------------------------- -- ** Property combinators --- | Changes the maximum test case size for a property. +-- | Adjust the test case size for a property, by transforming it with the given +-- function. mapSize :: Testable prop => (Int -> Int) -> prop -> Property -mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f)) +mapSize f = property . scale f . unProperty . property -- | Shrinks the argument to a property if it fails. Shrinking is done -- automatically for most types. This function is only needed when you want to @@ -302,6 +341,7 @@ MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] -- | Disables shrinking for a property altogether. +-- Only quantification /inside/ the call to 'noShrinking' is affected. noShrinking :: Testable prop => prop -> Property noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) @@ -353,15 +393,27 @@ -- | Prints out the generated testcase every time the property is tested. -- Only variables quantified over /inside/ the 'verbose' are printed. verbose :: Testable prop => prop -> Property -verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res }) - where newCallbacks cbs = - PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")): - [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] ++ - [ PostTest Counterexample (\st res -> putLine (terminal st) "") ] +verbose = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) + where newCallback cbs = + PostTest Counterexample $ \st res -> do + putLine (terminal st) (status res ++ ":") + sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] + putLine (terminal st) "" status MkResult{ok = Just True} = "Passed" status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" +-- | Prints out the generated testcase every time the property fails, including during shrinking. +-- Only variables quantified over /inside/ the 'verboseShrinking' are printed. +verboseShrinking :: Testable prop => prop -> Property +verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) + where newCallback cbs = + PostTest Counterexample $ \st res -> + when (ok res == Just False) $ do + putLine (terminal st) "Failed:" + sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] + putLine (terminal st) "" + -- | Indicates that a property is supposed to fail. -- QuickCheck will report an error if it does not fail. expectFailure :: Testable prop => prop -> Property @@ -387,7 +439,50 @@ withMaxSuccess :: Testable prop => Int -> prop -> Property withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) --- | Attaches a label to a property. This is used for reporting +-- | Check that all coverage requirements defined by 'cover' and 'coverTable' +-- are met, using a statistically sound test, and fail if they are not met. +-- +-- Ordinarily, a failed coverage check does not cause the property to fail. +-- This is because the coverage requirement is not tested in a statistically +-- sound way. If you use 'cover' to express that a certain value must appear 20% +-- of the time, QuickCheck will warn you if the value only appears in 19 out of +-- 100 test cases - but since the coverage varies randomly, you may have just +-- been unlucky, and there may not be any real problem with your test +-- generation. +-- +-- When you use 'checkCoverage', QuickCheck uses a statistical test to account +-- for the role of luck in coverage failures. It will run as many tests as +-- needed until it is sure about whether the coverage requirements are met. If a +-- coverage requirement is not met, the property fails. +-- +-- Example: +-- +-- > quickCheck (checkCoverage prop_foo) +checkCoverage :: Testable prop => prop -> Property +checkCoverage = checkCoverageWith stdConfidence + +-- | Check coverage requirements using a custom confidence level. +-- See 'stdConfidence'. +-- +-- An example of making the statistical test less stringent in order to improve +-- performance: +-- +-- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo) +checkCoverageWith :: Testable prop => Confidence -> prop -> Property +checkCoverageWith confidence = + certainty confidence `seq` + tolerance confidence `seq` + mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence }) + +-- | The standard parameters used by 'checkCoverage': @certainty = 10^9@, +-- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters. +stdConfidence :: Confidence +stdConfidence = + Confidence { + certainty = 10^9, + tolerance = 0.9 } + +-- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- For example: @@ -404,10 +499,17 @@ -- 5% length of input is 4 -- 4% length of input is 6 -- ... +-- +-- Each use of 'label' in your property results in a separate +-- table of test case distribution in the output. If this is +-- not what you want, use 'tabulate'. label :: Testable prop => String -> prop -> Property -label s = classify True s +label s = + s `deepseq` + mapTotalResult $ + \res -> res { labels = s:labels res } --- | Attaches a label to a property. This is used for reporting +-- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- > collect x = label (show x) @@ -426,10 +528,14 @@ -- 5% 4 -- 4% 6 -- ... +-- +-- Each use of 'collect' in your property results in a separate +-- table of test case distribution in the output. If this is +-- not what you want, use 'tabulate'. collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) --- | Records how many test cases satisfy a given condition. +-- | Reports how many test cases satisfy a given condition. -- -- For example: -- @@ -445,39 +551,170 @@ Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property -classify b s = cover b 0 s +classify False _ = property +classify True s = + s `deepseq` + mapTotalResult $ + \res -> res { classes = s:classes res } -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage. -- +-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but +-- the property does /not/ fail. To make the property fail, use 'checkCoverage'. +-- -- For example: -- -- > prop_sorted_sort :: [Int] -> Property -- > prop_sorted_sort xs = -- > sorted xs ==> --- > cover (length xs > 1) 50 "non-trivial" $ +-- > cover 50 (length xs > 1) "non-trivial" $ -- > sort xs === xs -- -- >>> quickCheck prop_sorted_sort --- *** Insufficient coverage after 100 tests (only 24% non-trivial, not 50%). +-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). +-- +-- 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. +-- +-- 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 +-- +-- Commands (68 in total): +-- 62% LogIn +-- 22% SendMessage +-- 16% LogOut +tabulate :: Testable prop => String -> [String] -> prop -> Property +tabulate key values = + key `deepseq` values `deepseq` mapTotalResult $ - \res -> res { - labels = Map.insertWith max s n (labels res), - stamp = if x then Set.insert s (stamp res) else stamp res } - where [] `listSeq` z = z - (x:xs) `listSeq` z = x `seq` xs `listSeq` z + \res -> res { tables = [(key, value) | value <- values] ++ tables res } +-- | Checks that the values in a given 'table' appear a certain proportion of +-- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts +-- that of the values in @table@, @x1@ should appear at least @p1@ percent of +-- the time, @x2@ at least @p2@ percent of the time, and so on. +-- +-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but +-- the property does /not/ fail. To make the property fail, use 'checkCoverage'. +-- +-- Continuing the example from the 'tabular' combinator... +-- +-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... +-- +-- ...we can add a coverage requirement as follows, which checks that @LogIn@, +-- @LogOut@ and @SendMessage@ each occur at least 25% of the time: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... property goes here ... +-- +-- >>> quickCheck prop_chatroom +-- +++ OK, passed 100 tests; 2909 discarded: +-- 56% 0 +-- 17% 1 +-- 10% 2 +-- 6% 3 +-- 5% 4 +-- 3% 5 +-- 3% 7 +-- +-- Commands (111 in total): +-- 51.4% LogIn +-- 30.6% SendMessage +-- 18.0% LogOut +-- +-- Table 'Commands' had only 18.0% LogOut, but expected 25.0% +coverTable :: Testable prop => + String -> [(String, Double)] -> prop -> Property +coverTable table xs = + tables `deepseq` xs `deepseq` + mapTotalResult $ + \res -> res { requiredCoverage = ys ++ requiredCoverage res } + where + ys = [(Just table, x, p/100) | (x, p) <- xs] + -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded), --- or if the given property holds. +-- or if the given property holds. Note that using implication carelessly can +-- severely skew test case distribution: consider using 'cover' to make sure +-- that your test data is still good quality. (==>) :: Testable prop => Bool -> prop -> Property False ==> _ = property Discard True ==> p = property p @@ -506,16 +743,38 @@ => Gen a -> (a -> prop) -> Property forAll gen pf = forAllShrink gen (\_ -> []) pf +-- | Like 'forAll', but with an explicitly given show function. +forAllShow :: Testable prop + => Gen a -> (a -> String) -> (a -> prop) -> Property +forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf + +-- | Like 'forAll', but without printing the generated value. +forAllBlind :: Testable prop + => Gen a -> (a -> prop) -> Property +forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf + -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop) => Gen a -> (a -> [a]) -> (a -> prop) -> Property -forAllShrink gen shrinker pf = +forAllShrink gen shrinker = forAllShrinkShow gen shrinker show + +-- | Like 'forAllShrink', but with an explicitly given show function. +forAllShrinkShow + :: Testable prop + => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property +forAllShrinkShow gen shrinker shower pf = + forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x)) + +-- | Like 'forAllShrink', but without printing the generated value. +forAllShrinkBlind + :: Testable prop + => Gen a -> (a -> [a]) -> (a -> prop) -> Property +forAllShrinkBlind gen shrinker pf = again $ MkProperty $ gen >>= \x -> unProperty $ - shrinking shrinker x $ \x' -> - counterexample (show x') (pf x') + shrinking shrinker x pf -- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of -- 'p1' and 'p2' to test. If you test the property 100 times it @@ -549,10 +808,10 @@ case ok result of _ | not (expect result) -> return (return failed { reason = "expectFailure may not occur inside a conjunction" }) - Just True -> return (conj (addLabels result . addCallbacks result . k) ps) + Just True -> return (conj (addLabels result . addCallbacksAndCoverage result . k) ps) Just False -> return rose Nothing -> do - rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps) + rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage result . k) ps) return $ -- Nasty work to make sure we use the right callbacks case ok result2 of @@ -560,11 +819,13 @@ Just False -> rose2 Nothing -> rose2 - addCallbacks result r = - r { callbacks = callbacks result ++ callbacks r } + addCallbacksAndCoverage result r = + r { callbacks = callbacks result ++ callbacks r, + requiredCoverage = requiredCoverage result ++ requiredCoverage r } addLabels result r = - r { labels = Map.unionWith max (labels result) (labels r), - stamp = Set.union (stamp result) (stamp r) } + r { labels = labels result ++ labels r, + classes = classes result ++ classes r, + tables = tables result ++ tables r } -- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property @@ -583,25 +844,27 @@ do result1 <- p case ok result1 of _ | not (expect result1) -> return expectFailureError - Just True -> return result1 Just False -> do result2 <- q return $ case ok result2 of _ | not (expect result2) -> expectFailureError - Just True -> result2 + Just True -> addCoverage result1 result2 Just False -> MkResult { ok = Just False, expect = True, reason = sep (reason result1) (reason result2), theException = theException result1 `mplus` theException result2, - -- The following three fields are not important because the + -- The following few fields are not important because the -- test case has failed anyway abort = False, maybeNumTests = Nothing, - labels = Map.empty, - stamp = Set.empty, + maybeCheckCoverage = Nothing, + labels = [], + classes = [], + tables = [], + requiredCoverage = [], callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ @@ -610,18 +873,28 @@ testCase result1 ++ testCase result2 } Nothing -> result2 - Nothing -> do - result2 <- q - return (case ok result2 of - _ | not (expect result2) -> expectFailureError - Just True -> result2 - _ -> result1) + -- The "obvious" semantics of .||. has: + -- discard .||. true = true + -- discard .||. discard = discard + -- but this implementation gives discard .||. true = discard. + -- This is reasonable because evaluating result2 in the case + -- that result1 discards is just busy-work - it won't ever + -- cause the property to fail. On the other hand, discarding + -- instead of returning true causes us to execute one more + -- test case - but assuming that preconditions are cheap to + -- evaluate, this is no more work than evaluating result2 + -- would be, while (unlike evaluating result2) it might catch + -- a bug. + _ -> return result1 expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } sep [] s = s sep s [] = s sep s s' = s ++ ", " ++ s' + addCoverage result r = + r { requiredCoverage = requiredCoverage result ++ requiredCoverage r } + -- | Like '==', but prints a counterexample when it fails. infix 4 === (===) :: (Eq a, Show a) => a -> a -> Property @@ -631,6 +904,16 @@ res = x == y interpret True = " == " interpret False = " /= " + +-- | Like '/=', but prints a counterexample when it fails. +infix 4 =/= +(=/=) :: (Eq a, Show a) => a -> a -> Property +x =/= y = + counterexample (show x ++ interpret res ++ show y) res + where + res = x /= y + interpret True = " /= " + interpret False = " == " #ifndef NO_DEEPSEQ -- | Checks that a value is total, i.e., doesn't crash when evaluated. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs --- 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 --- 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 @@ 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 --- 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 @@ -- imports import Test.QuickCheck.Gen -import Test.QuickCheck.Property hiding ( Result( reason, theException, labels ) ) +import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text -import Test.QuickCheck.State hiding (labels) +import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random +import Data.Number.Erf(invnormcdf) import System.Random(split) #if defined(MIN_VERSION_containers) #if MIN_VERSION_containers(0,5,0) @@ -27,6 +29,8 @@ import qualified Data.Map as Map #endif import qualified Data.Set as Set +import Data.Set(Set) +import Data.Map(Map) import Data.Char ( isSpace @@ -37,11 +41,15 @@ , sortBy , group , intersperse + , intercalate ) -import Data.Maybe(fromMaybe) +import Data.Maybe(fromMaybe, isNothing, catMaybes) import Data.Ord(comparing) import Text.Printf(printf) +import Data.Either(lefts, rights) +import Control.Monad +import Data.Bits -------------------------------------------------------------------------- -- quickCheck @@ -77,41 +85,65 @@ data Result -- | A successful test run = Success - { numTests :: Int -- ^ Number of tests performed - , labels :: [(String,Double)] -- ^ Labels and frequencies found during all successful tests - , output :: String -- ^ Printed output + { numTests :: Int + -- ^ Number of tests performed + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + -- ^ The number of test cases having each combination of labels (see 'label') + , classes :: !(Map String Int) + -- ^ The number of test cases having each class (see 'classify') + , tables :: !(Map String (Map String Int)) + -- ^ Data collected by 'tabulate' + , output :: String + -- ^ Printed output } -- | Given up | GaveUp - { numTests :: Int -- Number of tests performed - , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests - , output :: String -- Printed output + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + , classes :: !(Map String Int) + , tables :: !(Map String (Map String Int)) + , output :: String } -- | A failed test run | Failure - { numTests :: Int -- Number of tests performed - , numShrinks :: Int -- ^ Number of successful shrinking steps performed - , numShrinkTries :: Int -- ^ Number of unsuccessful shrinking steps performed - , numShrinkFinal :: Int -- ^ Number of unsuccessful shrinking steps performed since last successful shrink - , usedSeed :: QCGen -- ^ What seed was used - , usedSize :: Int -- ^ What was the test size - , reason :: String -- ^ Why did the property fail - , theException :: Maybe AnException -- ^ The exception the property threw, if any - , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests - , output :: String -- Printed output - , failingTestCase :: [String] -- ^ The test case which provoked the failure + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , numShrinks :: Int + -- ^ Number of successful shrinking steps performed + , numShrinkTries :: Int + -- ^ Number of unsuccessful shrinking steps performed + , numShrinkFinal :: Int + -- ^ Number of unsuccessful shrinking steps performed since last successful shrink + , usedSeed :: QCGen + -- ^ What seed was used + , usedSize :: Int + -- ^ What was the test size + , reason :: String + -- ^ Why did the property fail + , theException :: Maybe AnException + -- ^ The exception the property threw, if any + , output :: String + , failingTestCase :: [String] + -- ^ The test case which provoked the failure + , failingLabels :: [String] + -- ^ The test case's labels (see 'label') + , failingClasses :: Set String + -- ^ The test case's classes (see 'classify') } -- | A property that should have failed did not | NoExpectedFailure - { numTests :: Int -- Number of tests performed - , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests - , output :: String -- Printed output - } - -- | The tests passed but a use of 'cover' had insufficient coverage - | InsufficientCoverage - { numTests :: Int -- Number of tests performed - , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests - , output :: String -- Printed output + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + , classes :: !(Map String Int) + , tables :: !(Map String (Map String Int)) + , output :: String } deriving ( Show ) @@ -148,12 +180,17 @@ -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. quickCheckWithResult :: Testable prop => Args -> prop -> IO Result -quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do +quickCheckWithResult a p = + withState a (\s -> test s (property p)) + +withState :: Args -> (State -> IO a) -> IO a +withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of Nothing -> newQCGen Just (rnd,_) -> return rnd test MkState{ terminal = tm , maxSuccessTests = maxSuccess a + , coverageConfidence = Nothing , maxDiscardedRatio = maxDiscardRatio a , computeSize = case replay a of Nothing -> computeSize' @@ -163,13 +200,15 @@ , numDiscardedTests = 0 , numRecentlyDiscardedTests = 0 , S.labels = Map.empty - , collected = [] - , expectedFailure = False + , S.classes = Map.empty + , S.tables = Map.empty + , S.requiredCoverage = Map.empty + , expected = True , randomSeed = rnd , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 - } (unGen (unProperty (property p))) + } where computeSize' n d -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. @@ -205,124 +244,138 @@ -------------------------------------------------------------------------- -- main test loop -test :: State -> (QCGen -> Int -> Prop) -> IO Result +test :: State -> Property -> IO Result test st f - | numSuccessTests st >= maxSuccessTests st = + | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = doneTesting st f - | numDiscardedTests st >= maxDiscardedRatio st * maxSuccessTests st = + | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = giveUp st f | otherwise = runATest st f -doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result +doneTesting :: State -> Property -> IO Result doneTesting st _f - | not (expectedFailure st) = do + | expected st == False = do putPart (terminal st) ( bold ("*** Failed!") ++ " Passed " - ++ show (numSuccessTests st) - ++ " tests (expected failure)" + ++ showTestCount st + ++ " (expected failure)" ) finished NoExpectedFailure - | not (null (insufficientlyCovered st)) = do - putPart (terminal st) - ( bold ("*** Insufficient coverage after ") - ++ show (numSuccessTests st) - ++ " tests" - ) - finished InsufficientCoverage | otherwise = do putPart (terminal st) ( "+++ OK, passed " - ++ show (numSuccessTests st) - ++ " tests" + ++ showTestCount st ) finished Success where finished k = do success st theOutput <- terminalOutput (terminal st) - return (k (numSuccessTests st) (summary st) theOutput) + return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) -giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result +giveUp :: State -> Property -> IO Result giveUp st _f = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") ++ " Passed only " - ++ show (numSuccessTests st) + ++ showTestCount st ++ " tests" ) success st theOutput <- terminalOutput (terminal st) - return GaveUp{ numTests = numSuccessTests st - , labels = summary st - , output = theOutput + return GaveUp{ numTests = numSuccessTests st + , numDiscarded = numDiscardedTests st + , labels = S.labels st + , classes = S.classes st + , tables = S.tables st + , output = theOutput } -runATest :: State -> (QCGen -> Int -> Prop) -> IO Result +showTestCount :: State -> String +showTestCount st = + number (numSuccessTests st) "test" + ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" + | numDiscardedTests st > 0 + ] + +runATest :: State -> Property -> IO Result runATest st f = do -- CALLBACK before_test putTemp (terminal st) ( "(" - ++ number (numSuccessTests st) "test" - ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" - | numDiscardedTests st > 0 - ] + ++ showTestCount st ++ ")" ) + let powerOfTwo n = n .&. (n - 1) == 0 + let f_or_cov = + case coverageConfidence st of + Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> + addCoverageCheck confidence st f + _ -> f let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) - MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size))) + MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) res <- callbackPostTest st res let continue break st' | abort res = break st' | otherwise = test st' - cons x xs - | Set.null x = xs - | otherwise = x:xs + let inc x = Map.insertWith (+) x 1 + let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st + , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) + , S.labels = inc (P.labels res) (S.labels st) + , S.classes = foldr inc (S.classes st) (P.classes res) + , S.tables = + foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) + (S.tables st) (P.tables res) + , S.requiredCoverage = + foldr (\(key, value, p) -> Map.insertWith max (key, value) p) + (S.requiredCoverage st) (P.requiredCoverage res) + , expected = expect res } + case res of - MkResult{ok = Just True, stamp = stamp, expect = expect, maybeNumTests = mnt} -> -- successful test + MkResult{ok = Just True} -> -- successful test do continue doneTesting - st{ numSuccessTests = numSuccessTests st + 1 - , numRecentlyDiscardedTests = 0 - , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt - , randomSeed = rnd2 - , S.labels = Map.unionWith max (S.labels st) (P.labels res) - , collected = stamp `cons` collected st - , expectedFailure = expect - } f + st'{ numSuccessTests = numSuccessTests st' + 1 + , numRecentlyDiscardedTests = 0 + , randomSeed = rnd2 + } f - MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt} -> -- discarded test + MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test do continue giveUp - st{ numDiscardedTests = numDiscardedTests st + 1 - , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 - , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt - , randomSeed = rnd2 - , S.labels = Map.unionWith max (S.labels st) (P.labels res) - , expectedFailure = expect + -- Don't add coverage info from this test + st{ numDiscardedTests = numDiscardedTests st' + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 + , randomSeed = rnd2 } f MkResult{ok = Just False} -> -- failed test - do (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts - theOutput <- terminalOutput (terminal st) + do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts + theOutput <- terminalOutput (terminal st') if not (expect res) then - return Success{ labels = summary st, - numTests = numSuccessTests st+1, + return Success{ labels = S.labels st', + classes = S.classes st', + tables = S.tables st', + numTests = numSuccessTests st'+1, + numDiscarded = numDiscardedTests st', output = theOutput } else do testCase <- mapM showCounterexample (P.testCase res) - return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) , usedSize = size - , numTests = numSuccessTests st+1 + , numTests = numSuccessTests st'+1 + , numDiscarded = numDiscardedTests st' , numShrinks = numShrinks , numShrinkTries = totFailed , numShrinkFinal = lastFailed , output = theOutput , reason = P.reason res , theException = P.theException res - , labels = summary st , failingTestCase = testCase + , failingLabels = P.labels res + , failingClasses = Set.fromList (P.classes res) } where (rnd1,rnd2) = split (randomSeed st) @@ -367,83 +420,73 @@ where showNumTryShrinks = full && numTryShrinks st > 0 -summary :: State -> [(String, Double)] -summary st = reverse - . sortBy (comparing snd) - . map (\ss -> (head ss, fromIntegral (length ss) * 100 / fromIntegral (numSuccessTests st))) - . group - . sort - $ [ concat (intersperse ", " s') - | s <- collected st - -- HACK: don't print out labels that were created by 'cover'. - , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ] - , not (null s') - ] - success :: State -> IO () -success st = - case allLabels ++ covers of - [] -> do putLine (terminal st) "." - [pt] -> do putLine (terminal st) - ( " (" - ++ dropWhile isSpace pt - ++ ")." - ) - cases -> do putLine (terminal st) ":" - mapM_ (putLine $ terminal st) cases - where - allLabels :: [String] - allLabels = map (formatLabel (numSuccessTests st) True) (summary st) - - covers :: [String] - covers = [ ("only " ++ formatLabel (numSuccessTests st) False (l, p) ++ ", not " ++ show reqP ++ "%") - | (l, reqP, p) <- insufficientlyCovered st ] +success st = do + mapM_ (putLine $ terminal st) (paragraphs [short, long]) + where + (short, long) = + case labelsAndTables st of + ([msg], long) -> + ([" (" ++ dropWhile isSpace msg ++ ")."], long) + ([], long) -> + (["."], long) + (short, long) -> + (":":short, long) -formatLabel :: Int -> Bool -> (String, Double) -> String -formatLabel n pad (x, p) = showP pad p ++ " " ++ x - where - showP :: Bool -> Double -> String - showP pad p = - (if pad && p < 10 then " " else "") ++ - printf "%.*f" places p ++ "%" +labelsAndTables :: State -> ([String], [String]) +labelsAndTables st = (labels, tables) + where + labels :: [String] + labels = + paragraphs $ + [ showTable (numSuccessTests st) Nothing m + | m <- S.classes st:Map.elems numberedLabels ] - -- Show no decimal places if <= 100 successful tests, - -- one decimal place if <= 1000 successful tests, - -- two decimal places if <= 10000 successful tests, and so on. - places :: Integer - places = - ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 + numberedLabels :: Map Int (Map String Int) + numberedLabels = + Map.fromListWith (Map.unionWith (+)) $ + [ (i, Map.singleton l n) + | (labels, n) <- Map.toList (S.labels st), + (i, l) <- zip [0..] labels ] -labelCount :: String -> State -> Int -labelCount l st = - -- XXX in case of a disjunction, a label can occur several times, - -- need to think what to do there - length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] + tables :: [String] + tables = + paragraphs $ + [ showTable (sum (Map.elems m)) (Just table) m + | (table, m) <- Map.toList (S.tables st) ] ++ + [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ") + ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot + | (mtable, label, tot, n, p) <- allCoverage st, + insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] -percentage :: Integral a => State -> a -> Double -percentage st n = - fromIntegral n * 100 / fromIntegral (numSuccessTests st) +showTable :: Int -> Maybe String -> Map String Int -> [String] +showTable k mtable m = + [table ++ " " ++ total ++ ":" | Just table <- [mtable]] ++ + (map format . + -- Descending order of occurrences + reverse . sortBy (comparing snd) . + -- If #occurences the same, sort in increasing order of key + -- (note: works because sortBy is stable) + reverse . sortBy (comparing fst) $ Map.toList m) + where + format (key, v) = + rpercent v k ++ " " ++ key -insufficientlyCovered :: State -> [(String, Int, Double)] -insufficientlyCovered st = - [ (l, reqP, p) - | (l, reqP) <- Map.toList (S.labels st), - let p = percentage st (labelCount l st), - p < fromIntegral reqP ] + total = printf "(%d in total)" k -------------------------------------------------------------------------- -- main shrinking loop foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) foundFailure st res ts = - do localMin st{ numTryShrinks = 0 } res res ts + do localMin st{ numTryShrinks = 0 } res ts -localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) -- Don't try to shrink for too long -localMin st res _ ts +localMin st res ts | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = localMinFound st res -localMin st res _ ts = do +localMin st res ts = do r <- tryEvaluateIO $ putTemp (terminal st) (failureSummary st res) case r of @@ -465,9 +508,9 @@ res' <- callbackPostTest st res' if ok res' == Just False then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, - numTryShrinks = 0 } res' res ts' + numTryShrinks = 0 } res' ts' else localMin st{ numTryShrinks = numTryShrinks st + 1, - numTotTryShrinks = numTotTryShrinks st + 1 } res res ts + numTotTryShrinks = numTotTryShrinks st + 1 } res ts localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res = @@ -494,6 +537,73 @@ tryEvaluateIO $ putLine (terminal st) (show err) return () Right () -> return () + +---------------------------------------------------------------------- +-- computing coverage + +sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool +sufficientlyCovered confidence n k p = + -- Accept the coverage if, with high confidence, the actual probability is + -- at least 0.9 times the required one. + wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p + where + err = certainty confidence + tol = tolerance confidence + +insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool +insufficientlyCovered Nothing n k p = + fromIntegral k < p * fromIntegral n +insufficientlyCovered (Just err) n k p = + wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p + +-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval +-- Note: +-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf +-- suggests we should use a instead of a/2 for a one-sided test. Look +-- into this. +wilson :: Integer -> Integer -> Double -> Double +wilson k n z = + (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf) + where + nf = fromIntegral n + p = fromIntegral k / fromIntegral n + +wilsonLow :: Integer -> Integer -> Double -> Double +wilsonLow k n a = wilson k n (invnormcdf (a/2)) + +wilsonHigh :: Integer -> Integer -> Double -> Double +wilsonHigh k n a = wilson k n (invnormcdf (1-a/2)) + +addCoverageCheck :: Confidence -> State -> Property -> Property +addCoverageCheck confidence st prop + | and [ sufficientlyCovered confidence tot n p + | (_, _, tot, n, p) <- allCoverage st ] = + -- Note: run prop once more so that we get labels for this test case run + once prop + | or [ insufficientlyCovered (Just (certainty confidence)) tot n p + | (_, _, tot, n, p) <- allCoverage st ] = + let (labels, tables) = labelsAndTables st in + foldr counterexample (property failed{P.reason = "Insufficient coverage"}) + (paragraphs [labels, tables]) + | otherwise = prop + +allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] +allCoverage st = + [ (key, value, tot, n, p) + | ((key, value), p) <- Map.toList (S.requiredCoverage st), + let tot = + case key of + Just key -> Map.findWithDefault 0 key totals + Nothing -> numSuccessTests st, + let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ] + where + combinedCounts :: Map (Maybe String) (Map String Int) + combinedCounts = + Map.insert Nothing (S.classes st) + (Map.mapKeys Just (S.tables st)) + + totals :: Map String Int + totals = fmap (sum . Map.elems) (S.tables st) -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs --- 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 @@ , oneLine , isOneLine , bold + , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage + , drawTable, Cell(..) + , paragraphs , newTerminal , withStdioTerminal + , withHandleTerminal , withNullTerminal , terminalOutput , handle @@ -38,6 +43,8 @@ ) import Data.IORef +import Data.List +import Text.Printf import Test.QuickCheck.Exception -------------------------------------------------------------------------- @@ -76,6 +83,74 @@ isOneLine :: String -> Bool isOneLine xs = '\n' `notElem` xs +ljust n xs = xs ++ replicate (n - length xs) ' ' +rjust n xs = replicate (n - length xs) ' ' ++ xs +centre n xs = + ljust n $ + replicate ((n - length xs) `div` 2) ' ' ++ xs + +lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String +lpercent n k = + lpercentage (fromIntegral n / fromIntegral k) k + +rpercent n k = + rpercentage (fromIntegral n / fromIntegral k) k + +lpercentage, rpercentage :: Integral a => Double -> a -> String +lpercentage p n = + printf "%.*f" places (100*p) ++ "%" + where + -- Show no decimal places if k <= 100, + -- one decimal place if k <= 1000, + -- two decimal places if k <= 10000, and so on. + places :: Integer + places = + ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 + +rpercentage p n = padding ++ lpercentage p n + where + padding = if p < 0.1 then " " else "" + +data Cell = LJust String | RJust String | Centred String deriving Show + +text :: Cell -> String +text (LJust xs) = xs +text (RJust xs) = xs +text (Centred xs) = xs + +-- Flatten a table into a list of rows +flattenRows :: [[Cell]] -> [String] +flattenRows rows = map row rows + where + cols = transpose rows + widths = map (maximum . map (length . text)) cols + + row cells = intercalate " " (zipWith cell widths cells) + cell n (LJust xs) = ljust n xs + cell n (RJust xs) = rjust n xs + cell n (Centred xs) = centre n xs + +-- Draw a table given a header and contents +drawTable :: [String] -> [[Cell]] -> [String] +drawTable headers table = + [line] ++ + [border '|' ' ' header | header <- headers] ++ + [line | not (null headers) && not (null rows)] ++ + [border '|' ' ' row | row <- rows] ++ + [line] + where + rows = flattenRows table + + headerwidth = maximum (0:map length headers) + bodywidth = maximum (0:map length rows) + width = max headerwidth bodywidth + + line = border '+' '-' $ replicate width '-' + border x y xs = [x, y] ++ centre width xs ++ [y, x] + +paragraphs :: [[String]] -> [String] +paragraphs = intercalate [""] . filter (not . null) + bold :: String -> String -- not portable: --bold s = "\ESC[1m" ++ s ++ "\ESC[0m" @@ -101,11 +176,22 @@ hSetBuffering stderr LineBuffering action `finally` hSetBuffering stderr mode +withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a +withHandleTerminal outh merrh action = do + let + err = + case merrh of + Nothing -> const (return ()) + Just errh -> handle errh + newTerminal (handle outh) err >>= action + withStdioTerminal :: (Terminal -> IO a) -> IO a withStdioTerminal action = do isatty <- hIsTerminalDevice stderr - let err = if isatty then handle stderr else const (return ()) - withBuffering (newTerminal (handle stdout) err >>= action) + if isatty then + withBuffering (withHandleTerminal stdout (Just stderr) action) + else + withBuffering (withHandleTerminal stdout Nothing action) withNullTerminal :: (Terminal -> IO a) -> IO a withNullTerminal action = diff --git a/changelog b/changelog --- 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 --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -107,7 +107,7 @@ insert x h ==? (x : toList h) prop_RemoveMin (h :: Heap Int) = - cover (size h > 1) 80 "non-trivial" $ + cover 80 (size h > 1) "non-trivial" $ case removeMin h of Nothing -> h ==? [] Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs --- a/examples/Heap_Program.hs +++ b/examples/Heap_Program.hs @@ -167,7 +167,7 @@ insert x h ==? (x : toList h) prop_RemoveMin (HeapPP _ h) = - cover (size h > 1) 80 "non-trivial" $ + cover 80 (size h > 1) "non-trivial" $ case removeMin h of Nothing -> h ==? [] Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) diff --git a/examples/Set.hs b/examples/Set.hs --- a/examples/Set.hs +++ b/examples/Set.hs @@ -70,7 +70,7 @@ LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 EQ -> Node x (s11 `union` s21) (s12 `union` s22) --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) - GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 + GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 -} s1 `union` Empty = s1 Empty `union` s2 = s2 @@ -88,7 +88,7 @@ where (s11,s12) = split x s1 (s21,s22) = split x s2 - + mapp :: (a -> b) -> Set a -> Set b mapp f Empty = Empty mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) @@ -172,7 +172,7 @@ unit x ==? [x] prop_Size (s :: Set Int) = - cover (size s >= 15) 60 "large" $ + cover 60 (size s >= 15) "large" $ size s == length (toList s) prop_Insert x (s :: Set Int) = @@ -196,7 +196,7 @@ s ==? xs && xs == sort xs where xs = toSortedList s - + -- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ prop_FromList' (xs :: [Int]) = diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs --- 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 (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 --- 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 @@ 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 --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -26,7 +26,7 @@ path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property -somePath p = expectFailure . path (not . p) +somePath p = expectFailure . withMaxSuccess 1000 . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) @@ -130,13 +130,12 @@ reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property -reachesBound x = expectFailure (x < 3 * (maxBound `div` 4)) +reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property prop_reachesBound_Int32 = reachesBound :: Int32 -> Property prop_reachesBound_Int64 = reachesBound :: Int64 -> Property -prop_reachesBound_Word = reachesBound :: Word -> Property prop_reachesBound_Word8 = reachesBound :: Word8 -> Property prop_reachesBound_Word16 = reachesBound :: Word16 -> Property prop_reachesBound_Word32 = reachesBound :: Word32 -> Property @@ -155,4 +154,4 @@ prop_B1 (B1 n) = expectFailure $ n === n + 1 return [] -main = $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print +main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return () diff --git a/tests/MonadFix.hs b/tests/MonadFix.hs new file mode 100644 --- /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 --- /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 ()