diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ -Copyright (c) 2000-2012, Koen Claessen +Copyright (c) 2000-2014, Koen Claessen Copyright (c) 2006-2008, Björn Bringert -Copyright (c) 2009-2012, Nick Smallbone +Copyright (c) 2009-2014, Nick Smallbone All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,15 +1,15 @@ Name: QuickCheck -Version: 2.6 -Cabal-Version: >= 1.6 +Version: 2.7 +Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE -Extra-source-files: README -Copyright: 2000-2012 Koen Claessen, 2006-2008 Björn Bringert, 2009-2012 Nick Smallbone +Extra-source-files: README changelog +Copyright: 2000-2014 Koen Claessen, 2006-2008 Björn Bringert, 2009-2014 Nick Smallbone Author: Koen Claessen Maintainer: QuickCheck developers Bug-reports: mailto:quickcheck@projects.haskell.org -Tested-with: GHC >=6.8, Hugs +Tested-with: GHC >=6.8, Hugs, UHC Homepage: http://code.haskell.org/QuickCheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -34,7 +34,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.5.1.1 + tag: 2.7 flag base3 Description: Choose the new smaller, split-up base package. @@ -55,46 +55,84 @@ else Build-depends: base < 3 - -- On old versions of GHC use the ghc package to catch ctrl-C. - if impl(ghc >= 6.7) && impl(ghc < 6.13) - Build-depends: ghc - - -- We want to use extensible-exceptions even if linking against base-3. - if impl(ghc >= 6.9) && impl (ghc < 7.0) - Build-depends: extensible-exceptions - -- Modules that are always built. Exposed-Modules: Test.QuickCheck, Test.QuickCheck.Arbitrary, Test.QuickCheck.Gen, + Test.QuickCheck.Gen.Unsafe, Test.QuickCheck.Monadic, Test.QuickCheck.Modifiers, Test.QuickCheck.Property, Test.QuickCheck.Test, Test.QuickCheck.Text, Test.QuickCheck.Poly, - Test.QuickCheck.State - - Extensions: CPP + Test.QuickCheck.State, + Test.QuickCheck.Random, + Test.QuickCheck.Exception - -- Choose which optional features to build based on which compiler - -- we're using. It would be nice to use flags for this but Cabal's - -- dependency resolution isn't good enough. + -- GHC-specific modules. if impl(ghc) Exposed-Modules: Test.QuickCheck.Function - if flag(templateHaskell) && impl(ghc >= 6.12) - Build-depends: template-haskell >= 2.4 - Exposed-Modules: Test.QuickCheck.All - -- GHC < 7.0 doesn't cope with multiple LANGUAGE pragmas in the same - -- file, I think... - if impl(ghc < 7) - Extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, TypeOperators + if impl(ghc >= 6.12) && flag(templateHaskell) + Build-depends: template-haskell >= 2.4 + Exposed-Modules: Test.QuickCheck.All else + cpp-options: -DNO_TEMPLATE_HASKELL + + -- Compiler-specific tweaks, lots of 'em! + + -- On old versions of GHC use the ghc package to catch ctrl-C. + if impl(ghc >= 6.7) && impl(ghc < 6.13) + Build-depends: ghc + + -- We want to use extensible-exceptions even if linking against base-3. + if impl(ghc >= 6.9) && impl (ghc < 7.0) + Build-depends: extensible-exceptions + + -- GHC < 7.0 can't cope with multiple LANGUAGE pragmas in the same file. + if impl(ghc < 7) + Extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, TypeOperators + + -- The new generics appeared in GHC 7.2... + if impl(ghc < 7.2) + cpp-options: -DNO_GENERICS + -- ...but in 7.2-7.4 it lives in the ghc-prim package. + if impl(ghc >= 7.2) && impl(ghc < 7.6) + Build-depends: ghc-prim + + -- Use tf-random on newer GHCs. + if impl(ghc >= 7) && flag(base4) + Build-depends: tf-random >= 0.4 + else + cpp-options: -DNO_TF_RANDOM + + -- Switch off most optional features on non-GHC systems. + if !impl(ghc) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! - cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING - if !impl(hugs) + cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL + if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES - Other-Modules: - Test.QuickCheck.Exception + + -- LANGUAGE pragmas don't have any effect in Hugs. + if impl(hugs) + Extensions: CPP + + if impl(uhc) + -- Cabal under UHC needs pointing out all the dependencies of the + -- random package. + Build-depends: old-time, old-locale + -- Plus some bits of the standard library are missing. + cpp-options: -DNO_FIXED -DNO_EXCEPTIONS + +Test-Suite test-quickcheck + type: exitcode-stdio-1.0 + hs-source-dirs: + examples + main-is: Heap.hs + build-depends: + base, + QuickCheck == 2.7, + template-haskell >= 2.4, + test-framework >= 0.4 && < 0.9 diff --git a/README b/README --- a/README +++ b/README @@ -1,33 +1,14 @@ This is QuickCheck 2, a library for random testing of program properties. -=== Installation === - -Installation is done with Cabal: +Install it in the usual way: $ cabal install -or, if you're missing the cabal command, - -$ runghc Setup.lhs configure -$ runghc Setup.lhs build -$ runghc Setup.lhs install - -If you get errors about Template Haskell, try - -$ cabal install -f-templateHaskell - -but please report this as a bug, letting us know about your GHC -installation. - -=== Bugs === - Please report bugs to the QuickCheck mailing list at quickcheck@projects.haskell.org. -=== Documentation === - -$ runghc Setup.lhs haddock - -generates API documentation in dist/doc/html/index.html +If you get errors about Template Haskell, try +$ cabal install -f-templateHaskell +but please report this as a bug. diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -13,27 +13,39 @@ , verboseCheckWith , verboseCheckWithResult , verboseCheckResult - , verbose +#ifndef NO_TEMPLATE_HASKELL + -- ** Testing all properties in a module + , quickCheckAll + , verboseCheckAll + , forAllProperties + -- ** Testing polymorphic properties + , polyQuickCheck + , polyVerboseCheck + , monomorphic +#endif -- * Random generation , Gen -- ** Generator combinators - , sized - , resize , choose - , promote - , suchThat - , suchThatMaybe , oneof , frequency , elements , growingElements + , sized + , resize + , suchThat + , suchThatMaybe , listOf , listOf1 , vectorOf + , infiniteListOf -- ** Generators which use Arbitrary , vector , orderedList + , infiniteList + -- ** Running a generator + , generate -- ** Generator debugging , sample , sample' @@ -49,17 +61,24 @@ , arbitraryBoundedIntegral , arbitraryBoundedRandom , arbitraryBoundedEnum - , coarbitraryEnum -- ** Helper functions for implementing shrink +#ifndef NO_GENERICS + , genericShrink + , subterms + , recursivelyShrink +#endif , shrinkNothing + , shrinkList , shrinkIntegral , shrinkRealFrac + , shrinkRealFracToInteger -- ** Helper functions for implementing coarbitrary , variant - , (><) , coarbitraryIntegral , coarbitraryReal , coarbitraryShow + , coarbitraryEnum + , (><) -- ** Type-level modifiers for changing generator behavior , Blind(..) @@ -69,44 +88,50 @@ , Positive(..) , NonZero(..) , NonNegative(..) + , Large(..) + , Small(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) -#endif , ShrinkState(..) +#endif -- * Properties - , Property, Prop, Testable(..) + , Property, Testable(..) -- ** Property combinators - , mapSize - , shrinking - , (==>) - , discard , forAll , forAllShrink - -- *** Experimental combinators for conjunction and disjunction + , shrinking + , (==>) + , (===) + , ioProperty + -- *** Controlling property execution + , verbose + , once + , within + , noShrinking + -- *** Conjunction and disjunction , (.&.) , (.&&.) , conjoin , (.||.) , disjoin - -- *** Handling failure - , whenFail + -- *** What to do on failure + , counterexample , printTestCase + , whenFail , whenFail' , expectFailure - , within - -- *** Test distribution + -- *** Analysing test distribution , label , collect , classify , cover - , once - - -- * Text formatting - , Str(..) - , ranges + -- *** Miscellaneous + , Discard(..) + , discard + , mapSize ) where @@ -120,6 +145,9 @@ import Test.QuickCheck.Test import Test.QuickCheck.Text import Test.QuickCheck.Exception +#ifndef NO_TEMPLATE_HASKELL +import Test.QuickCheck.All +#endif -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs --- a/Test/QuickCheck/All.hs +++ b/Test/QuickCheck/All.hs @@ -1,16 +1,16 @@ {-# LANGUAGE TemplateHaskell, Rank2Types #-} --- | Experimental features using Template Haskell. +-- | 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( - -- ** Testing all properties in a module. + -- ** Testing all properties in a module quickCheckAll, verboseCheckAll, forAllProperties, - -- ** Testing polymorphic properties. + -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, - mono) where + monomorphic) where import Language.Haskell.TH import Test.QuickCheck.Property hiding (Result) @@ -24,22 +24,27 @@ -- Invoke as @$('polyQuickCheck' 'prop)@, where @prop@ is a property. -- Note that just evaluating @'quickCheck' prop@ in GHCi will seem to -- work, but will silently default all type variables to @()@! +-- +-- @$('polyQuickCheck' \'prop)@ means the same as +-- @'quickCheck' $('monomorphic' \'prop)@. +-- If you want to supply custom arguments to 'polyQuickCheck', +-- you will have to combine 'quickCheckWith' and 'monomorphic' yourself. polyQuickCheck :: Name -> ExpQ -polyQuickCheck x = [| quickCheck $(mono x) |] +polyQuickCheck x = [| quickCheck $(monomorphic x) |] -- | Test a polymorphic property, defaulting all type variables to 'Integer'. --- This is just a convenience function that combines 'polyQuickCheck' and 'verbose'. +-- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'. polyVerboseCheck :: Name -> ExpQ -polyVerboseCheck x = [| verboseCheck $(mono x) |] +polyVerboseCheck x = [| verboseCheck $(monomorphic x) |] type Error = forall a. String -> a --- | Monomorphise an arbitrary name by defaulting all type variables to 'Integer'. +-- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'. -- -- For example, if @f@ has type @'Ord' a => [a] -> [a]@ --- then @$('mono' 'f)@ has type @['Integer'] -> ['Integer']@. -mono :: Name -> ExpQ -mono t = do +-- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@. +monomorphic :: Name -> ExpQ +monomorphic t = do ty0 <- fmap infoType (reify t) let err msg = error $ msg ++ ": " ++ pprint ty0 (polys, ctx, ty) <- deconstructType err ty0 @@ -47,7 +52,7 @@ [] -> return (VarE t) _ -> do integer <- [t| Integer |] - ty' <- monomorphise err integer ty + ty' <- monomorphiseType err integer ty return (SigE (VarE t) ty') infoType :: Info -> Type @@ -63,11 +68,11 @@ return (map (\(PlainTV x) -> x) xs, ctx, ty) deconstructType _ ty = return ([], [], ty) -monomorphise :: Error -> Type -> Type -> TypeQ -monomorphise err mono ty@(VarT n) = return mono -monomorphise err mono (AppT t1 t2) = liftM2 AppT (monomorphise err mono t1) (monomorphise err mono t2) -monomorphise err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" -monomorphise err mono ty = return ty +monomorphiseType :: Error -> Type -> Type -> TypeQ +monomorphiseType err mono ty@(VarT n) = return mono +monomorphiseType err mono (AppT t1 t2) = liftM2 AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2) +monomorphiseType err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" +monomorphiseType err mono ty = return ty -- | Test all properties in the current module, using a custom -- 'quickCheck' function. The same caveats as with 'quickCheckAll' @@ -87,7 +92,7 @@ quickCheckOne (l, x) = do exists <- return False `recover` (reify (mkName x) >> return True) if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), - property $(mono (mkName x))) |] ] + property $(monomorphic (mkName x))) |] ] else return [] [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -1,3 +1,8 @@ +-- | Type classes for random generation of values. +{-# LANGUAGE CPP #-} +#ifndef NO_GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} +#endif module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes @@ -12,27 +17,36 @@ , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a -- ** Helper functions for implementing shrink +#ifndef NO_GENERICS + , genericShrink -- :: (Generic a, Typeable a, RecursivelyShrink (Rep a), Subterms (Rep a)) => a -> [a] + , subterms -- :: (Generic a, Subterms (Rep a)) => a -> [a] + , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] +#endif , shrinkNothing -- :: a -> [a] , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] , shrinkIntegral -- :: Integral a => a -> [a] , shrinkRealFrac -- :: RealFrac a => a -> [a] + , shrinkRealFracToInteger -- :: RealFrac a => a -> [a] -- ** Helper functions for implementing coarbitrary - , (><) , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b + , (><) -- ** Generators which use arbitrary - , vector -- :: Arbitrary a => Int -> Gen [a] - , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] + , vector -- :: Arbitrary a => Int -> Gen [a] + , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] + , infiniteList -- :: Arbitrary a => Gen [a] ) where -------------------------------------------------------------------------- -- imports +import System.Random(Random) import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe {- import Data.Generics @@ -52,10 +66,12 @@ , isSpace ) +#ifndef NO_FIXED import Data.Fixed ( Fixed , HasResolution ) +#endif import Data.Ratio ( Ratio @@ -67,10 +83,6 @@ import Data.Complex ( Complex((:+)) ) -import System.Random - ( Random - ) - import Data.List ( sort , nub @@ -87,6 +99,11 @@ import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) +#ifndef NO_GENERICS +import GHC.Generics +import Data.Typeable +#endif + -------------------------------------------------------------------------- -- ** class Arbitrary @@ -97,10 +114,133 @@ arbitrary = error "no default generator" -- | Produces a (possibly) empty list of all the possible - -- immediate shrinks of the given value. + -- immediate shrinks of the given value. The default implementation + -- returns the empty list, so will not try to shrink the value. + -- + -- Most implementations of 'shrink' should try at least three things: + -- + -- 1. Shrink a term to any of its immediate subterms. + -- + -- 2. Recursively apply 'shrink' to all immediate subterms. + -- + -- 3. Type-specific shrinkings such as replacing a constructor by a + -- simpler constructor. + -- + -- For example, suppose we have the following implementation of binary trees: + -- + -- > data Tree a = Nil | Branch a (Tree a) (Tree a) + -- + -- We can then define 'shrink' as follows: + -- + -- > shrink Nil = [] + -- > shrink (Branch x l r) = + -- > -- shrink Branch to Nil + -- > [Nil] ++ + -- > -- shrink to subterms + -- > [l, r] ++ + -- > -- recursively shrink subterms + -- > [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] + -- + -- There are a couple of subtleties here: + -- + -- * QuickCheck tries the shrinking candidates in the order they + -- appear in the list, so we put more aggressive shrinking steps + -- (such as replacing the whole tree by @Nil@) before smaller + -- ones (such as recursively shrinking the subtrees). + -- + -- * It is tempting to write the last line as + -- @[Branch x' l' r' | x' <- shrink x, l' <- shrink l, r' <- shrink r]@ + -- but this is the /wrong thing/! It will force QuickCheck to shrink + -- @x@, @l@ and @r@ in tandem, and shrinking will stop once /one/ of + -- the three is fully shrunk. + -- + -- There is a fair bit of boilerplate in the code above. + -- We can avoid it with the help of some generic functions; + -- note that these only work on GHC 7.2 and above. + -- The function 'genericShrink' tries shrinking a term to all of its + -- subterms and, failing that, recursively shrinks the subterms. + -- Using it, we can define 'shrink' as: + -- + -- > shrink x = shrinkToNil x ++ genericShrink x + -- > where + -- > shrinkToNil Nil = [] + -- > shrinkToNil (Branch _ l r) = [Nil] + -- + -- 'genericShrink' is a combination of 'subterms', which shrinks + -- a term to any of its subterms, and 'recursivelyShrink', which shrinks + -- all subterms of a term. These may be useful if you need a bit more + -- control over shrinking than 'genericShrink' gives you. + -- + -- A final gotcha: we cannot define 'shrink' as simply @'shrink' x = Nil:'genericShrink' x@ + -- as this shrinks @Nil@ to @Nil@, and shrinking will go into an + -- infinite loop. + -- + -- If all this leaves you bewildered, you might try @'shrink' = 'genericShrink'@ to begin with, + -- after deriving @Generic@ and @Typeable@ for your type. However, if your data type has any + -- special invariants, you will need to check that 'genericShrink' can't break those invariants. shrink :: a -> [a] shrink _ = [] +#ifndef NO_GENERICS +-- | Shrink a term to any of its immediate subterms, +-- and also recursively shrink all subterms. +genericShrink :: (Generic a, Typeable a, RecursivelyShrink (Rep a), Subterms (Rep a)) => a -> [a] +genericShrink x = subterms x ++ recursivelyShrink x + +-- | Recursively shrink all immediate subterms. +recursivelyShrink :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] +recursivelyShrink = map to . grecursivelyShrink . from + +class RecursivelyShrink f where + grecursivelyShrink :: f a -> [f a] + +instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :*: g) where + grecursivelyShrink (x :*: y) = + [x' :*: y | x' <- grecursivelyShrink x] ++ + [x :*: y' | y' <- grecursivelyShrink y] + +instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :+: g) where + grecursivelyShrink (L1 x) = map L1 (grecursivelyShrink x) + grecursivelyShrink (R1 x) = map R1 (grecursivelyShrink x) + +instance RecursivelyShrink f => RecursivelyShrink (M1 i c f) where + grecursivelyShrink (M1 x) = map M1 (grecursivelyShrink x) + +instance Arbitrary a => RecursivelyShrink (K1 i a) where + grecursivelyShrink (K1 x) = map K1 (shrink x) + +instance RecursivelyShrink U1 where + grecursivelyShrink U1 = [] + +-- | All immediate subterms of a term. +subterms :: (Generic a, Typeable a, Subterms (Rep a)) => a -> [a] +subterms = gsubterms . from + +class Subterms f where + gsubterms :: Typeable b => f a -> [b] + +instance (Subterms f, Subterms g) => Subterms (f :*: g) where + gsubterms (x :*: y) = + gsubterms x ++ gsubterms y + +instance (Subterms f, Subterms g) => Subterms (f :+: g) where + gsubterms (L1 x) = gsubterms x + gsubterms (R1 x) = gsubterms x + +instance Subterms f => Subterms (M1 i c f) where + gsubterms (M1 x) = gsubterms x + +instance Typeable a => Subterms (K1 i a) where + gsubterms (K1 x) = + case cast x of + Nothing -> [] + Just y -> [y] + +instance Subterms U1 where + gsubterms U1 = [] + +#endif + -- instances instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where @@ -115,7 +255,7 @@ shrink False = [] instance Arbitrary Ordering where - arbitrary = arbitraryBoundedEnum + arbitrary = elements [LT, EQ, GT] shrink GT = [EQ, LT] shrink LT = [EQ] shrink EQ = [] @@ -139,6 +279,7 @@ shrink xs = shrinkList shrink xs +-- | Shrink a list of values given a shrinking function for individual values. shrinkList :: (a -> [a]) -> [a] -> [[a]] shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ] ++ shrinkOne xs @@ -167,54 +308,54 @@ instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac + shrink = shrinkRealFracToInteger instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where arbitrary = liftM2 (:+) arbitrary arbitrary shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ [ x :+ y' | y' <- shrink y ] +#ifndef NO_FIXED instance HasResolution a => Arbitrary (Fixed a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac +#endif instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where arbitrary = liftM2 (,) arbitrary arbitrary - shrink (x,y) = [ (x',y) | x' <- shrink x ] - ++ [ (x,y') | y' <- shrink y ] + shrink (x, y) = + [ (x', y) | x' <- shrink x ] + ++ [ (x, y') | y' <- shrink y ] instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a,b,c) where arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary - shrink (x,y,z) = [ (x',y,z) | x' <- shrink x ] - ++ [ (x,y',z) | y' <- shrink y ] - ++ [ (x,y,z') | z' <- shrink z ] + shrink (x, y, z) = + [ (x', y', z') + | (x', (y', z')) <- shrink (x, (y, z)) ] instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (a,b,c,d) where arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary - shrink (w,x,y,z) = [ (w',x,y,z) | w' <- shrink w ] - ++ [ (w,x',y,z) | x' <- shrink x ] - ++ [ (w,x,y',z) | y' <- shrink y ] - ++ [ (w,x,y,z') | z' <- shrink z ] + shrink (w, x, y, z) = + [ (w', x', y', z') + | (w', (x', (y', z'))) <- shrink (w, (x, (y, z))) ] instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a,b,c,d,e) where arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary - shrink (v,w,x,y,z) = [ (v',w,x,y,z) | v' <- shrink v ] - ++ [ (v,w',x,y,z) | w' <- shrink w ] - ++ [ (v,w,x',y,z) | x' <- shrink x ] - ++ [ (v,w,x,y',z) | y' <- shrink y ] - ++ [ (v,w,x,y,z') | z' <- shrink z ] + shrink (v, w, x, y, z) = + [ (v', w', x', y', z') + | (v', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] -- typical instance for primitive (numerical) types @@ -223,7 +364,7 @@ shrink = shrinkIntegral instance Arbitrary Int where - arbitrary = arbitrarySizedBoundedIntegral + arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral instance Arbitrary Int8 where @@ -310,15 +451,19 @@ where precision = 9999999999999 :: Integer +-- Useful for getting at minBound and maxBound without having to +-- fiddle around with asTypeOf. +withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a +withBounds k = k minBound maxBound + -- | Generates an integral number. The number is chosen uniformly from -- the entire range of the type. You may want to use -- 'arbitrarySizedBoundedIntegral' instead. arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitraryBoundedIntegral = - do let mn = minBound - mx = maxBound `asTypeOf` mn - n <- choose (toInteger mn, toInteger mx) - return (fromInteger n `asTypeOf` mn) + withBounds $ \mn mx -> + do n <- choose (toInteger mn, toInteger mx) + return (fromInteger n) -- | Generates an element of a bounded type. The element is -- chosen from the entire range of the type. @@ -328,10 +473,9 @@ -- | Generates an element of a bounded enumeration. arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a arbitraryBoundedEnum = - do let mn = minBound - mx = maxBound `asTypeOf` mn - n <- choose (fromEnum mn, fromEnum mx) - return (toEnum n `asTypeOf` mn) + withBounds $ \mn mx -> + do n <- choose (fromEnum mn, fromEnum mx) + return (toEnum n) -- | Generates an integral number from a bounded domain. The number is -- chosen from the entire range of the type, but small numbers are @@ -339,14 +483,13 @@ -- Phil Wadler. arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitrarySizedBoundedIntegral = + withBounds $ \mn mx -> sized $ \s -> - do let mn = minBound - mx = maxBound `asTypeOf` mn - bits n | n `quot` 2 == 0 = 0 + do let bits n | n `quot` 2 == 0 = 0 | otherwise = 1 + bits (n `quot` 2) k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100) n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) - return (fromInteger n `asTypeOf` mn) + return (fromInteger n) -- ** Helper functions for implementing shrink @@ -372,17 +515,23 @@ (True, False) -> a + b < 0 (False, True) -> a + b > 0 --- | Shrink a fraction. -shrinkRealFrac :: RealFrac a => a -> [a] -shrinkRealFrac x = +-- | Shrink a fraction, but only shrink to integral values. +shrinkRealFracToInteger :: RealFrac a => a -> [a] +shrinkRealFracToInteger x = nub $ [ -x | x < 0 ] ++ - [ x' - | x' <- [fromInteger (truncate x)] - , x' << x - ] + map fromInteger (shrinkIntegral (truncate x)) + +-- | Shrink a fraction. +shrinkRealFrac :: RealFrac a => a -> [a] +shrinkRealFrac x = + nub $ + shrinkRealFracToInteger x ++ + [ x - x' + | x' <- take 20 (iterate (/ 2) x) + , (x - x') << x ] where a << b = abs a < abs b @@ -391,31 +540,25 @@ -- | Used for random generation of functions. class CoArbitrary a where - -- | Used to generate a function of type @a -> c@. The implementation - -- should use the first argument to perturb the random generator - -- given as the second argument. the returned generator - -- is then used to generate the function result. - -- You can often use 'variant' and '><' to implement - -- 'coarbitrary'. - coarbitrary :: a -> Gen c -> Gen c + -- | Used to generate a function of type @a -> b@. + -- The first argument is a value, the second a generator. + -- You should use 'variant' to perturb the random generator; + -- the goal is that different values for the first argument will + -- lead to different calls to 'variant'. An example will help: + -- + -- @ + -- instance CoArbitrary a => CoArbitrary [a] where + -- coarbitrary [] = 'variant' 0 + -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) + -- @ -{- - -- GHC definition: - coarbitrary{| Unit |} Unit = id - coarbitrary{| a :*: b |} (x :*: y) = coarbitrary x >< coarbitrary y - coarbitrary{| a :+: b |} (Inl x) = variant 0 . coarbitrary x - coarbitrary{| a :+: b |} (Inr y) = variant (-1) . coarbitrary y --} + coarbitrary :: a -> Gen b -> Gen b +{-# DEPRECATED (><) "Use ordinary function composition instead" #-} -- | Combine two generator perturbing functions, for example the -- results of calls to 'variant' or 'coarbitrary'. (><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) -(><) f g gen = - do n <- arbitrary - (g . variant (n :: Int) . f) gen - --- for the sake of non-GHC compilers, I have added definitions --- for coarbitrary here. +(><) = (.) instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where coarbitrary f gen = @@ -427,63 +570,65 @@ instance CoArbitrary Bool where coarbitrary False = variant 0 - coarbitrary True = variant (-1) + coarbitrary True = variant 1 instance CoArbitrary Ordering where - coarbitrary GT = variant 1 - coarbitrary EQ = variant 0 - coarbitrary LT = variant (-1) + coarbitrary GT = variant 0 + coarbitrary EQ = variant 1 + coarbitrary LT = variant 2 instance CoArbitrary a => CoArbitrary (Maybe a) where coarbitrary Nothing = variant 0 - coarbitrary (Just x) = variant (-1) . coarbitrary x + coarbitrary (Just x) = variant 1 . coarbitrary x instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where - coarbitrary (Left x) = variant 0 . coarbitrary x - coarbitrary (Right y) = variant (-1) . coarbitrary y + coarbitrary (Left x) = variant 0 . coarbitrary x + coarbitrary (Right y) = variant 1 . coarbitrary y instance CoArbitrary a => CoArbitrary [a] where coarbitrary [] = variant 0 - coarbitrary (x:xs) = variant (-1) . coarbitrary (x,xs) + coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where coarbitrary r = coarbitrary (numerator r,denominator r) +#ifndef NO_FIXED instance HasResolution a => CoArbitrary (Fixed a) where coarbitrary = coarbitraryReal +#endif instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where - coarbitrary (x :+ y) = coarbitrary x >< coarbitrary y + coarbitrary (x :+ y) = coarbitrary x . coarbitrary y instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a,b) where coarbitrary (x,y) = coarbitrary x - >< coarbitrary y + . coarbitrary y instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a,b,c) where coarbitrary (x,y,z) = coarbitrary x - >< coarbitrary y - >< coarbitrary z + . coarbitrary y + . coarbitrary z instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a,b,c,d) where coarbitrary (x,y,z,v) = coarbitrary x - >< coarbitrary y - >< coarbitrary z - >< coarbitrary v + . coarbitrary y + . coarbitrary z + . coarbitrary v instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) => CoArbitrary (a,b,c,d,e) where coarbitrary (x,y,z,v,w) = coarbitrary x - >< coarbitrary y - >< coarbitrary z - >< coarbitrary v - >< coarbitrary w + . coarbitrary y + . coarbitrary z + . coarbitrary v + . coarbitrary w -- typical instance for primitive (numerical) types @@ -559,6 +704,10 @@ -- | Generates an ordered list of a given length. orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary + +-- | Generate an infinite list. +infiniteList :: Arbitrary a => Gen [a] +infiniteList = infiniteListOf arbitrary -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs --- a/Test/QuickCheck/Exception.hs +++ b/Test/QuickCheck/Exception.hs @@ -1,3 +1,5 @@ +-- | Throwing and catching exceptions. Internal QuickCheck module. + -- Hide away the nasty implementation-specific ways of catching -- exceptions behind a nice API. The main trouble is catching ctrl-C. @@ -20,7 +22,8 @@ #endif #endif -#if defined(OLD_EXCEPTIONS) || defined(NO_BASE_3) +#if defined(NO_EXCEPTIONS) +#elif defined(OLD_EXCEPTIONS) || defined(NO_BASE_3) import qualified Control.Exception as E #else import qualified Control.Exception.Extensible as E @@ -36,12 +39,37 @@ #endif #endif -#if defined(OLD_EXCEPTIONS) +#if defined(NO_EXCEPTIONS) +type AnException = () +#elif defined(OLD_EXCEPTIONS) type AnException = E.Exception #else type AnException = E.SomeException #endif +#ifdef NO_EXCEPTIONS +tryEvaluate :: a -> IO (Either AnException a) +tryEvaluate x = return (Right x) + +tryEvaluateIO :: IO a -> IO (Either AnException a) +tryEvaluateIO m = fmap Right m + +isInterrupt :: AnException -> Bool +isInterrupt _ = False + +discard :: a +discard = error "'discard' not supported, since your Haskell system can't catch exceptions" + +isDiscard :: AnException -> Bool +isDiscard _ = False + +finally :: IO a -> IO b -> IO a +finally mx my = do + x <- mx + my + return x + +#else -------------------------------------------------------------------------- -- try evaluate @@ -61,10 +89,10 @@ isInterrupt (E.DynException e) = fromDynamic e == Just Interrupted isInterrupt _ = False #elif defined(GHCI_INTERRUPTED_EXCEPTION) -isInterrupt (E.SomeException e) = - cast e == Just Interrupted || cast e == Just E.UserInterrupt +isInterrupt e = + E.fromException e == Just Interrupted || E.fromException e == Just E.UserInterrupt #else -isInterrupt (E.SomeException e) = cast e == Just E.UserInterrupt +isInterrupt e = E.fromException e == Just E.UserInterrupt #endif #else /* !defined(GHC_INTERRUPT) */ @@ -94,6 +122,7 @@ finally :: IO a -> IO b -> IO a finally = E.finally +#endif -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs --- a/Test/QuickCheck/Function.hs +++ b/Test/QuickCheck/Function.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators, GADTs #-} -- | Generation of random shrinkable, showable functions. --- Not really documented at the moment! +-- See the paper \"Shrinking and showing functions\" by Koen Claessen. -- -- Example of use: -- @@ -277,8 +277,7 @@ return (mkFun p d) shrink (Fun (p,d) _) = - [ mkFun p' d | p' <- shrink p ] - ++ [ mkFun p d' | d' <- shrink d ] + [ mkFun p' d' | (p', d') <- shrink (p, d) ] -------------------------------------------------------------------------- -- the end. 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,7 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif -- | Test case generation. module Test.QuickCheck.Gen where @@ -21,10 +25,16 @@ ( Applicative(..) ) +import Test.QuickCheck.Random + -------------------------------------------------------------------------- -- ** Generator type -newtype Gen a = MkGen{ unGen :: StdGen -> Int -> a } +-- | A generator for values of type @a@. +newtype Gen a = MkGen{ + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. + -- If you just want to get a random value out, consider using 'generate'. + } instance Functor Gen where fmap f (MkGen h) = @@ -50,13 +60,7 @@ -- | Modifies a generator using an integer seed. variant :: Integral n => n -> Gen a -> Gen a -variant k0 (MkGen m) = MkGen (\r n -> m (var k0 r) n) - where - var k = (if k == k' then id else var k') - . (if even k then fst else snd) - . split - where - k' = k `div` 2 +variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n) -- | Used to construct generators that depend on the size parameter. sized :: (Int -> Gen a) -> Gen a @@ -71,22 +75,22 @@ choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) --- | Promotes a monadic generator to a generator of monadic values. -promote :: Monad m => m (Gen a) -> Gen (m a) -promote m = MkGen (\r n -> liftM (\(MkGen m') -> m' r n) m) +-- | Run a generator. +generate :: Gen a -> IO a +generate (MkGen g) = + do r <- newQCGen + return (g r 30) -- | Generates some example values. sample' :: Gen a -> IO [a] -sample' (MkGen m) = - do rnd0 <- newStdGen - let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = split rnd - return [(m r n) | (r,n) <- rnds rnd0 `zip` [0,2..20] ] +sample' g = + generate (sequence [ resize n g | n <- [0,2..20] ]) -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO () sample g = do cases <- sample' g - sequence_ (map print cases) + mapM_ print cases -------------------------------------------------------------------------- -- ** Common generator combinators @@ -139,10 +143,11 @@ growingElements [] = error "QuickCheck.growingElements used with empty list" growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) where - k = length xs - mx = 100 - log' = round . log . fromIntegral - size n = (log' n + 1) * k `div` log' mx + k = length xs + mx = 100 + log' = round . log . toDouble + size n = (log' n + 1) * k `div` log' mx + toDouble = fromIntegral :: Int -> Double {- WAS: growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) @@ -167,6 +172,10 @@ -- | Generates a list of the given length. vectorOf :: Int -> Gen a -> Gen [a] vectorOf k gen = sequence [ gen | _ <- [1..k] ] + +-- | Generates an infinite list. +infiniteListOf :: Gen a -> Gen [a] +infiniteListOf gen = sequence (repeat gen) -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Gen/Unsafe.hs b/Test/QuickCheck/Gen/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck/Gen/Unsafe.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +-- | Unsafe combinators for the 'Gen' monad. +-- +-- 'Gen' is only morally a monad: two generators that are supposed +-- to be equal will give the same probability distribution, but they +-- might be different as functions from random number seeds to values. +-- QuickCheck maintains the illusion that a 'Gen' is a probability +-- distribution and does not allow you to distinguish two generators +-- that have the same distribution. +-- +-- The functions in this module allow you to break this illusion by +-- reusing the same random number seed twice. This is unsafe because +-- by applying the same seed to two morally equal generators, you can +-- see whether they are really equal or not. +module Test.QuickCheck.Gen.Unsafe where + +import Test.QuickCheck.Gen +import Control.Monad + +-- | Promotes a monadic generator to a generator of monadic values. +promote :: Monad m => m (Gen a) -> Gen (m a) +promote m = do + eval <- delay + return (liftM eval m) + +-- | Randomly generates a function of type @'Gen' a -> a@, which +-- you can then use to evaluate generators. Mostly useful in +-- implementing 'promote'. +delay :: Gen (Gen a -> a) +delay = MkGen (\r n g -> unGen g r n) + +#ifndef NO_ST_MONAD +-- | A variant of 'delay' that returns a polymorphic evaluation function. +-- Can be used in a pinch to generate polymorphic (rank-2) values: +-- +-- > genSelector :: Gen (a -> a -> a) +-- > genSelector = elements [\x y -> x, \x y -> y] +-- > +-- > data Selector = Selector (forall a. a -> a -> a) +-- > genPolySelector :: Gen Selector +-- > genPolySelector = do +-- > Capture eval <- capture +-- > return (Selector (eval genSelector)) +capture :: Gen Capture +capture = MkGen (\r n -> Capture (\g -> unGen g r n)) + +newtype Capture = Capture (forall a. Gen a -> a) +#endif diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs --- a/Test/QuickCheck/Modifiers.hs +++ b/Test/QuickCheck/Modifiers.hs @@ -45,10 +45,14 @@ , Positive(..) , NonZero(..) , NonNegative(..) + , Large(..) + , Small(..) , Smart(..) , Shrink2(..) +#ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) +#endif ) where @@ -64,13 +68,16 @@ -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class. -newtype Blind a = Blind a +newtype Blind a = Blind {getBlind :: a} deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) +instance Functor Blind where + fmap f (Blind x) = Blind (f x) + instance Show (Blind a) where show _ = "(*)" @@ -81,13 +88,16 @@ -------------------------------------------------------------------------- -- | @Fixed x@: as x, but will not be shrunk. -newtype Fixed a = Fixed a +newtype Fixed a = Fixed {getFixed :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) +instance Functor Fixed where + fmap f (Fixed x) = Fixed (f x) + instance Arbitrary a => Arbitrary (Fixed a) where arbitrary = Fixed `fmap` arbitrary @@ -98,6 +108,9 @@ newtype OrderedList a = Ordered {getOrdered :: [a]} deriving ( Eq, Ord, Show, Read ) +instance Functor OrderedList where + fmap f (Ordered x) = Ordered (map f x) + instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where arbitrary = Ordered `fmap` orderedList @@ -112,6 +125,9 @@ newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} deriving ( Eq, Ord, Show, Read ) +instance Functor NonEmptyList where + fmap f (NonEmpty x) = NonEmpty (map f x) + instance Arbitrary a => Arbitrary (NonEmptyList a) where arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) @@ -129,6 +145,10 @@ , Num, Integral, Real, Enum #endif ) + +instance Functor Positive where + fmap f (Positive x) = Positive (f x) + instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where arbitrary = ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0 @@ -149,6 +169,9 @@ #endif ) +instance Functor NonZero where + fmap f (NonZero x) = NonZero (f x) + instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) @@ -163,6 +186,9 @@ #endif ) +instance Functor NonNegative where + fmap f (NonNegative x) = NonNegative (f x) + instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where arbitrary = (frequency @@ -180,14 +206,51 @@ ] -------------------------------------------------------------------------- +-- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small +-- range. @Large Int@ gives you values drawn from the entire range instead. +newtype Large a = Large {getLarge :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif + ) + +instance Functor Large where + fmap f (Large x) = Large (f x) + +instance (Integral a, Bounded a) => Arbitrary (Large a) where + arbitrary = fmap Large arbitrarySizedBoundedIntegral + shrink (Large x) = fmap Large (shrinkIntegral x) + +-------------------------------------------------------------------------- +-- | @Small x@: generates values of @x@ drawn from a small range. +-- The opposite of 'Large'. +newtype Small a = Small {getSmall :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif + ) + +instance Functor Small where + fmap f (Small x) = Small (f x) + +instance Integral a => Arbitrary (Small a) where + arbitrary = fmap Small arbitrarySizedIntegral + shrink (Small x) = map Small (shrinkIntegral x) + +-------------------------------------------------------------------------- -- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x -newtype Shrink2 a = Shrink2 a +newtype Shrink2 a = Shrink2 {getShrink2 :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) +instance Functor Shrink2 where + fmap f (Shrink2 x) = Shrink2 (f x) + instance Arbitrary a => Arbitrary (Shrink2 a) where arbitrary = Shrink2 `fmap` arbitrary @@ -206,6 +269,9 @@ data Smart a = Smart Int a +instance Functor Smart where + fmap f (Smart n x) = Smart n (f x) + instance Show a => Show (Smart a) where showsPrec n (Smart _ x) = showsPrec n x @@ -254,6 +320,9 @@ class ShrinkState s a where shrinkInit :: a -> s shrinkState :: a -> s -> [(a,s)] + +instance Functor (Shrinking s) where + fmap f (Shrinking s x) = Shrinking s (f x) instance Show a => Show (Shrinking s a) where showsPrec n (Shrinking _ x) = showsPrec n x diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs --- a/Test/QuickCheck/Monadic.hs +++ b/Test/QuickCheck/Monadic.hs @@ -11,13 +11,13 @@ -- imports import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe import Test.QuickCheck.Property -import Control.Monad - ( liftM - ) +import Control.Monad(liftM, liftM2) import Control.Monad.ST +import Control.Applicative -- instance of monad transformer? @@ -30,6 +30,10 @@ instance Functor (PropertyM m) where fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) +instance Monad m => Applicative (PropertyM m) where + pure = return + (<*>) = liftM2 ($) + instance Monad m => Monad (PropertyM m) where return x = MkPropertyM (\k -> k x) MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) @@ -78,14 +82,16 @@ monadic' (MkPropertyM m) = m (const (return (return (property True)))) monadicIO :: PropertyM IO a -> Property -monadicIO = monadic morallyDubiousIOProperty +monadicIO = monadic ioProperty #ifndef NO_ST_MONAD monadicST :: (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m)) runSTGen :: (forall s. Gen (ST s a)) -> Gen a -runSTGen g = MkGen $ \r n -> runST (unGen g r n) +runSTGen f = do + Capture eval <- capture + return (runST (eval f)) #endif -------------------------------------------------------------------------- diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs --- a/Test/QuickCheck/Poly.hs +++ b/Test/QuickCheck/Poly.hs @@ -8,7 +8,7 @@ -- implement 'Eq', 'Show', 'Arbitrary' and 'CoArbitrary'. Types -- 'OrdA', 'OrdB' and 'OrdC' also implement 'Ord' and 'Num'. -- --- See also "Test.QuickCheck.All" for an experimental way of testing +-- See also "Test.QuickCheck.All" for an automatic way of testing -- polymorphic properties. module Test.QuickCheck.Poly ( A(..), B(..), C(..) 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 @@ +-- | Combinators for constructing properties. {-# LANGUAGE CPP #-} module Test.QuickCheck.Property where @@ -5,6 +6,7 @@ -- imports import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( showErr, isOneLine, putLine ) import Test.QuickCheck.Exception @@ -14,6 +16,8 @@ import System.Timeout(timeout) #endif import Data.Maybe +import Control.Applicative +import Control.Monad -------------------------------------------------------------------------- -- fixities @@ -55,34 +59,58 @@ -------------------------------------------------------------------------- -- * Property and Testable types -type Property = Gen Prop +-- | The type of properties. +newtype Property = MkProperty { unProperty :: Gen Prop } -- | The class of things which can be tested, i.e. turned into a property. class Testable prop where + -- | Convert the thing to a property. property :: prop -> Property + -- | If true, the property will only be tested once. + -- However, if used inside a quantifier, it will be tested normally. exhaustive :: prop -> Bool exhaustive _ = False +-- | If a property returns 'Discard', the current test case is discarded, +-- the same as if a precondition was false. +data Discard = Discard + +instance Testable Discard where + property _ = property rejected + exhaustive _ = True + instance Testable Bool where property = property . liftBool exhaustive _ = True instance Testable Result where - property = return . MkProp . protectResults . return + property = MkProperty . return . MkProp . protectResults . return exhaustive _ = True instance Testable Prop where - property (MkProp r) = return . MkProp . ioRose . return $ r + property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r exhaustive _ = True instance Testable prop => Testable (Gen prop) where - property mp = do p <- mp; property p + property mp = MkProperty $ do p <- mp; unProperty (property p) +instance Testable Property where + property = id + -- | Do I/O inside a property. This can obviously lead to unrepeatable -- testcases, so use with care. +{-# DEPRECATED morallyDubiousIOProperty "Use ioProperty instead" #-} morallyDubiousIOProperty :: Testable prop => IO prop -> Property -morallyDubiousIOProperty = fmap (MkProp . ioRose . fmap unProp) . promote . fmap property +morallyDubiousIOProperty = ioProperty -- Silly names aren't all they're cracked up to be :) +-- | Do I/O inside a property. This can obviously lead to unrepeatable +-- testcases, so use with care. +-- +-- For more advanced monadic testing you may want to look at +-- "Test.QuickCheck.Monadic". +ioProperty :: Testable prop => IO prop -> Property +ioProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property) + instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where property f = forAllShrink arbitrary shrink f @@ -117,6 +145,11 @@ fmap f (IORose rs) = IORose (fmap (fmap f) rs) fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] +instance Applicative Rose where + pure = return + -- f must be total + (<*>) = liftM2 ($) + instance Monad Rose where return x = MkRose x [] -- k must be total @@ -157,32 +190,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 - , interrupted :: Bool -- ^ indicates if the test case was cancelled by pressing ^C - , abort :: Bool -- ^ if True, the test should not be repeated - , stamp :: [(String,Int)] -- ^ the collected values for this test case - , callbacks :: [Callback] -- ^ the callbacks for this 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 + , stamp :: [(String,Int)] -- ^ the collected values for this test case + , callbacks :: [Callback] -- ^ the callbacks for this test case } result :: Result result = MkResult - { ok = undefined - , expect = True - , reason = "" - , interrupted = False - , abort = False - , stamp = [] - , callbacks = [] + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = False + , stamp = [] + , callbacks = [] } exception :: String -> AnException -> Result exception msg err | isDiscard err = rejected | otherwise = failed{ reason = formatException msg err, - interrupted = isInterrupt err } + theException = Just err } formatException :: String -> AnException -> String formatException msg err = msg ++ ":" ++ format (show err) @@ -219,14 +252,14 @@ mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property -mapProp f = fmap f . property +mapProp f = MkProperty . fmap f . unProperty . property -------------------------------------------------------------------------- -- ** Property combinators -- | Changes the maximum test case size for a property. mapSize :: Testable prop => (Int -> Int) -> prop -> Property -mapSize f p = sized ((`resize` property p) . f) +mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f)) -- | Shrinks the argument to property if it fails. Shrinking is done -- automatically for most types. This is only needed when you want to @@ -235,10 +268,10 @@ (a -> [a]) -- ^ 'shrink'-like function. -> a -- ^ The original argument -> (a -> prop) -> Property -shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0)) +shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0))) where props x = - MkRose (property (pf x)) [ props x' | x' <- shrinker x ] + MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] -- | Disables shrinking for a property altogether. noShrinking :: Testable prop => prop -> Property @@ -248,9 +281,9 @@ callback :: Testable prop => Callback -> prop -> Property callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) --- | Prints a message to the terminal as part of the counterexample. -printTestCase :: Testable prop => String -> prop -> Property -printTestCase s = +-- | Adds the given string to the counterexample. +counterexample :: Testable prop => String -> prop -> Property +counterexample s = callback $ PostFinalFailure Counterexample $ \st _res -> do res <- tryEvaluateIO (putLine (terminal st) s) case res of @@ -259,6 +292,11 @@ Right () -> return () +-- | Adds the given string to the counterexample. +{-# DEPRECATED printTestCase "Use counterexample instead" #-} +printTestCase :: Testable prop => String -> prop -> Property +printTestCase = counterexample + -- | Performs an 'IO' action after the last failure of a property. whenFail :: Testable prop => IO () -> prop -> Property whenFail m = @@ -275,8 +313,7 @@ then m else return () --- | Prints out the generated testcase every time the property is tested, --- like 'verboseCheck' from QuickCheck 1. +-- | 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 }) @@ -287,7 +324,8 @@ status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" --- | Modifies a property so that it is expected to fail for some test cases. +-- | Indicates that a property is supposed to fail. +-- QuickCheck will report an error if it does not fail. expectFailure :: Testable prop => prop -> Property expectFailure = mapTotalResult (\res -> res{ expect = False }) @@ -329,7 +367,7 @@ -- the first argument is 'False' (in which case the test case is discarded), -- or if the given property holds. (==>) :: Testable prop => Bool -> prop -> Property -False ==> _ = property rejected +False ==> _ = property Discard True ==> p = property p -- | Considers a property failed if it does not complete within @@ -355,24 +393,29 @@ forAll :: (Show a, Testable prop) => Gen a -> (a -> prop) -> Property forAll gen pf = + MkProperty $ gen >>= \x -> - printTestCase (show x) (pf x) + unProperty (counterexample (show x) (pf x)) -- | 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 = + MkProperty $ gen >>= \x -> + unProperty $ shrinking shrinker x $ \x' -> - printTestCase (show x') (pf x') + counterexample (show x') (pf x') -- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of -- 'p1' and 'p2' to test. If you test the property 100 times it -- makes 100 random choices. (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 = + MkProperty $ arbitrary >>= \b -> - printTestCase (if b then "LHS" else "RHS") $ + unProperty $ + counterexample (if b then "LHS" else "RHS") $ if b then property p1 else property p2 -- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. @@ -382,7 +425,8 @@ -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property conjoin ps = - do roses <- mapM (fmap unProp . property) ps + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (conj [] roses)) where conj cbs [] = @@ -411,7 +455,8 @@ -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property disjoin ps = - do roses <- mapM (fmap unProp . property) ps + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (foldr disj (MkRose failed []) roses)) where disj :: Rose Result -> Rose Result -> Rose Result @@ -440,13 +485,20 @@ result1 >>> result2 | not (expect result1 && expect result2) = expectFailureError result1 >>> result2 = result2 - { reason = if null (reason result2) then reason result1 else reason result2 - , interrupted = interrupted result1 || interrupted result2 - , stamp = stamp result1 ++ stamp result2 - , callbacks = callbacks result1 ++ + { reason = if null (reason result2) then reason result1 else reason result2 + , theException = if null (reason result2) then theException result1 else theException result2 + , stamp = stamp result1 ++ stamp result2 + , callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ callbacks result2 } + +-- | Like '==', but prints a counterexample when it fails. +infix 4 === +(===) :: (Eq a, Show a) => a -> a -> Property +x === y = + counterexample (show x ++ " /= " ++ show y) (x == y) + -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck/Random.hs @@ -0,0 +1,105 @@ +-- | A wrapper around the system random number generator. Internal QuickCheck module. +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Random where + +#ifndef NO_TF_RANDOM +import System.Random +import System.Random.TF +import System.Random.TF.Gen(splitn) +import Data.Word +import Data.Bits + +#define TheGen TFGen + +newTheGen :: IO TFGen +newTheGen = newTFGen + +bits, mask, doneBit :: Integral a => a +bits = 14 +mask = 0x3fff +doneBit = 0x4000 + +chip :: Bool -> Word32 -> TFGen -> TFGen +chip done n g = splitn g (bits+1) (if done then m .|. doneBit else m) + where + m = n .&. mask + +chop :: Integer -> Integer +chop n = n `shiftR` bits + +stop :: Integral a => a -> Bool +stop n = n <= mask + +mkTheGen :: Int -> TFGen +mkTheGen = mkTFGen + +#else +import System.Random + +#define TheGen StdGen + +newTheGen :: IO StdGen +newTheGen = newStdGen + +mkTheGen :: Int -> StdGen +mkTheGen = mkStdGen + +chip :: Bool -> Int -> StdGen -> StdGen +chip finished n = boolVariant finished . boolVariant (even n) + +chop :: Integer -> Integer +chop n = n `div` 2 + +stop :: Integral a => a -> Bool +stop n = n <= 1 +#endif + +-- | The "standard" QuickCheck random number generator. +-- A wrapper around either 'TFGen' on GHC, or 'StdGen' +-- on other Haskell systems. +newtype QCGen = QCGen TheGen + +instance Show QCGen where + showsPrec n (QCGen g) = showsPrec n g +instance Read QCGen where + readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] + +instance RandomGen QCGen where + split (QCGen g) = (QCGen g1, QCGen g2) + where + (g1, g2) = split g + genRange (QCGen g) = genRange g + next (QCGen g) = (x, QCGen g') + where + (x, g') = next g + +newQCGen :: IO QCGen +newQCGen = fmap QCGen newTheGen + +mkQCGen :: Int -> QCGen +mkQCGen n = QCGen (mkTheGen n) + +bigNatVariant :: Integer -> TheGen -> TheGen +bigNatVariant n g + | g `seq` stop n = chip True (fromInteger n) g + | otherwise = (bigNatVariant $! chop n) $! chip False (fromInteger n) g + +{-# INLINE natVariant #-} +natVariant :: Integral a => a -> TheGen -> TheGen +natVariant n g + | g `seq` stop n = chip True (fromIntegral n) g + | otherwise = bigNatVariant (toInteger n) g + +{-# INLINE variantTheGen #-} +variantTheGen :: Integral a => a -> TheGen -> TheGen +variantTheGen n g + | n >= 1 = natVariant (n-1) (boolVariant False g) + | n == 0 = natVariant (0 `asTypeOf` n) (boolVariant True g) + | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g) + +boolVariant :: Bool -> TheGen -> TheGen +boolVariant False = fst . split +boolVariant True = snd . split + +variantQCGen :: Integral a => a -> QCGen -> QCGen +variantQCGen n (QCGen g) = QCGen (variantTheGen n g) diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs --- a/Test/QuickCheck/State.hs +++ b/Test/QuickCheck/State.hs @@ -1,7 +1,8 @@ +-- | QuickCheck's internal state. Internal QuickCheck module. module Test.QuickCheck.State where import Test.QuickCheck.Text -import System.Random( StdGen ) +import Test.QuickCheck.Random -------------------------------------------------------------------------- -- State @@ -23,7 +24,7 @@ , numRecentlyDiscardedTests :: Int -- ^ the number of discarded tests since the last successful test , collected :: [[(String,Int)]] -- ^ all labels that have been collected so far , expectedFailure :: Bool -- ^ indicates if the property is expected to fail - , randomSeed :: StdGen -- ^ the current random seed + , randomSeed :: QCGen -- ^ the current random seed -- shrinking , numSuccessShrinks :: Int -- ^ number of successful shrinking steps so far diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -1,20 +1,17 @@ +-- | The main test loop. module Test.QuickCheck.Test where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen -import Test.QuickCheck.Property hiding ( Result( reason, interrupted ) ) +import Test.QuickCheck.Property hiding ( Result( reason, theException) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text import Test.QuickCheck.State import Test.QuickCheck.Exception - -import System.Random - ( split - , newStdGen - , StdGen - ) +import Test.QuickCheck.Random +import System.Random(split) import Data.Char ( isSpace @@ -34,49 +31,55 @@ -- | Args specifies arguments to the QuickCheck driver data Args = Args - { replay :: Maybe (StdGen,Int) -- ^ should we replay a previous test? - , maxSuccess :: Int -- ^ maximum number of successful tests before succeeding - , maxDiscardRatio :: Int -- ^ maximum number of discarded tests per successful test before giving up - , maxSize :: Int -- ^ size to use for the biggest test cases - , chatty :: Bool -- ^ whether to print anything + { replay :: Maybe (QCGen,Int) -- ^ Should we replay a previous test? + , maxSuccess :: Int -- ^ Maximum number of successful tests before succeeding + , maxDiscardRatio :: Int -- ^ Maximum number of discarded tests per successful test before giving up + , maxSize :: Int -- ^ Size to use for the biggest test cases + , chatty :: Bool -- ^ Whether to print anything } deriving ( Show, Read ) -- | Result represents the test result data Result - = Success -- a successful test run - { numTests :: Int -- ^ number of successful tests performed - , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests - , output :: String -- ^ printed output + -- | A successful test run + = Success + { numTests :: Int -- ^ Number of tests performed + , labels :: [(String,Int)] -- ^ Labels and frequencies found during all successful tests + , output :: String -- ^ Printed output } - | GaveUp -- given up - { numTests :: Int -- ^ number of successful tests performed - , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests - , output :: String -- ^ printed output + -- | Given up + | GaveUp + { numTests :: Int -- Number of tests performed + , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output } - | Failure -- failed test run - { numTests :: Int -- ^ number of tests performed - , numShrinks :: Int -- ^ number of successful shrinking steps performed - , usedSeed :: StdGen -- ^ what seed was used - , usedSize :: Int -- ^ what was the test size - , reason :: String -- ^ what was the reason - , interrupted :: Bool -- ^ did the user press ctrl-C? - , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests - , output :: String -- ^ printed output + -- | 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,Int)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output } - | NoExpectedFailure -- the expected failure did not happen - { numTests :: Int -- ^ number of tests performed - , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests - , output :: String -- ^ printed output + -- | A property that should have failed did not + | NoExpectedFailure + { numTests :: Int -- Number of tests performed + , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output } - deriving ( Show, Read ) + deriving ( Show ) --- | isSuccess checks if the test run result was a success +-- | Check if the test run result was a success isSuccess :: Result -> Bool isSuccess Success{} = True isSuccess _ = False --- | stdArgs are the default test arguments used +-- | The default test arguments stdArgs :: Args stdArgs = Args { replay = Nothing @@ -103,11 +106,11 @@ quickCheckWithResult :: Testable prop => Args -> prop -> IO Result quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of - Nothing -> newStdGen + Nothing -> newQCGen Just (rnd,_) -> return rnd test MkState{ terminal = tm - , maxSuccessTests = if exhaustive p then 1 else maxSuccess a - , maxDiscardedTests = if exhaustive p then maxDiscardRatio a else maxDiscardRatio a * maxSuccess a + , maxSuccessTests = maxSuccess a + , maxDiscardedTests = maxDiscardRatio a * maxSuccess a , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s @@ -120,7 +123,7 @@ , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 - } (unGen (property p)) + } (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. @@ -132,9 +135,12 @@ n `roundTo` m = (n `div` m) * m at0 f s 0 0 = s at0 f s n d = f n d + property' p + | exhaustive p = once (property p) + | otherwise = property p -- | Tests a property and prints the results and all test cases generated to 'stdout'. --- This is just a convenience function that means the same as 'quickCheck' '.' 'verbose'. +-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. verboseCheck :: Testable prop => prop -> IO () verboseCheck p = quickCheck (verbose p) @@ -156,13 +162,13 @@ -------------------------------------------------------------------------- -- main test loop -test :: State -> (StdGen -> Int -> Prop) -> IO Result +test :: State -> (QCGen -> Int -> Prop) -> IO Result test st f | numSuccessTests st >= maxSuccessTests st = doneTesting st f | numDiscardedTests st >= maxDiscardedTests st = giveUp st f | otherwise = runATest st f -doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result +doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result doneTesting st _f = do -- CALLBACK done_testing? if expectedFailure st then @@ -189,7 +195,7 @@ numTests = numSuccessTests st, output = theOutput } -giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result +giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result giveUp st _f = do -- CALLBACK gave_up? putPart (terminal st) @@ -205,7 +211,7 @@ , output = theOutput } -runATest :: State -> (StdGen -> Int -> Prop) -> IO Result +runATest :: State -> (QCGen -> Int -> Prop) -> IO Result runATest st f = do -- CALLBACK before_test putTemp (terminal st) @@ -245,21 +251,23 @@ do if expect res then putPart (terminal st) (bold "*** Failed! ") else putPart (terminal st) "+++ OK, failed as expected. " - numShrinks <- foundFailure st res ts + (numShrinks, totFailed, lastFailed) <- foundFailure st res ts theOutput <- terminalOutput (terminal st) if not (expect res) then return Success{ labels = summary st, numTests = numSuccessTests st+1, output = theOutput } else - return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) - , usedSize = size - , numTests = numSuccessTests st+1 - , numShrinks = numShrinks - , output = theOutput - , reason = P.reason res - , interrupted = P.interrupted res - , labels = summary st + return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + , usedSize = size + , numTests = numSuccessTests st+1 + , numShrinks = numShrinks + , numShrinkTries = totFailed + , numShrinkFinal = lastFailed + , output = theOutput + , reason = P.reason res + , theException = P.theException res + , labels = summary st } where (rnd1,rnd2) = split (randomSeed st) @@ -323,13 +331,14 @@ -------------------------------------------------------------------------- -- main shrinking loop -foundFailure :: State -> P.Result -> [Rose P.Result] -> IO Int +foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) foundFailure st res ts = - do localMin st{ numTryShrinks = 0 } res ts + do localMin st{ numTryShrinks = 0 } res res ts -localMin :: State -> P.Result -> [Rose P.Result] -> IO Int -localMin st res _ | P.interrupted res = localMinFound st res -localMin st res ts = do +localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) +localMin st MkResult{P.theException = Just e} lastRes _ + | isInterrupt e = localMinFound st lastRes +localMin st res _ ts = do putTemp (terminal st) ( short 26 (oneLine (P.reason res)) ++ " (after " ++ number (numSuccessTests st+1) "test" @@ -351,18 +360,19 @@ (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } Right ts' -> localMin' st res ts' -localMin' :: State -> P.Result -> [Rose P.Result] -> IO Int +localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) localMin' st res [] = localMinFound st res localMin' st res (t:ts) = do -- CALLBACK before_test MkRose res' ts' <- protectRose (reduceRose t) callbackPostTest st res' if ok res' == Just False - then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts' + then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, + numTryShrinks = 0 } res' res ts' else localMin st{ numTryShrinks = numTryShrinks st + 1, - numTotTryShrinks = numTotTryShrinks st + 1 } res ts + numTotTryShrinks = numTotTryShrinks st + 1 } res res ts -localMinFound :: State -> P.Result -> IO Int +localMinFound :: State -> P.Result -> IO (Int, Int, Int) localMinFound st res = do let report = concat [ "(after " ++ number (numSuccessTests st+1) "test", @@ -380,7 +390,7 @@ | msg <- lines (P.reason res) ] callbackPostFinalFailure st res - return (numSuccessShrinks st) + return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st) -------------------------------------------------------------------------- -- callbacks diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs --- a/Test/QuickCheck/Text.hs +++ b/Test/QuickCheck/Text.hs @@ -1,3 +1,4 @@ +-- | Terminal control. Internal QuickCheck module. module Test.QuickCheck.Text ( Str(..) , ranges diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,62 @@ +QuickCheck 2.7 (released 2014-03-19) + + * New features: + * New genericShrink function provides generic shrinking with GHC. + * New combinator x === y: fails if x /= y, but also prints their values + * New function generate :: Gen a -> IO a for running a generator. + * New combinators infiniteList and infiniteListOf for generating infinite lists. + * Several combinators added to the main Test.QuickCheck module which + were previously languishing in other modules. Of particular interest: + quickCheckAll, ioProperty. + * New combinators delay and capture which can be used (unsafely!) + to reuse the random number seed. Useful for generating + polymorphic (rank-2) values. + * A new Discard data type and a Testable instance for discarding test cases. + * All modifiers now have Functor instances and accessor functions. + * Pressing ctrl-C during shrinking now shows the last failed + test case, rather than the current shrinking candidate. + * Experimental support for UHC. You will need the latest version of Cabal from git. + + * Better distribution of test data: + * The Int generator now only generates fairly small numbers. + * The new Small and Large modifiers control the distribution of integers + (Small generates small numbers, Large from the whole range). + * Floating-point numbers shrink better. + + * Improved random number generation: + * QuickCheck now uses TFGen rather than StdGen on newer versions + of GHC, because StdGen's random numbers aren't always random. + * 'variant' now uses a prefix code. This should prevent some + potential bananaskins with coarbitrary. + + * API changes: + * The Gen monad now uses an abstract type QCGen rather than StdGen. + * The Result type now returns the thrown exception and number + of failed shrink attempts. + * Property is now a newtype rather than Gen Prop as it was before. + * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. + * 'printTestCase' is deprecated - its new name is 'counterexample' + * 'morallyDubiousIOProperty' is deprecated - its new name is + 'ioProperty', no moral judgement involved :) + +QuickCheck 2.6, released 2013-03-07 + + * Add convenience Function instances for up to 7-tuples + * Make stderr line buffered to reduce console I/O. + * Return a flag to say whether the test case was interrupted. + +QuickCheck 2.5, released 2012-06-18 + + * Replace maxDiscard with maxDiscardRatio + * Remove Testable () instance. + * Added a 'discard' exception that discards the current test case + * Add accessors for modifiers (where it makes sense) + * Rename 'stop' to 'abort' to avoid a name clash + * Added a 'once' combinator + * If a property is of type Bool, only run it once + * Add coarbitraryEnum to Test.QuickCheck module. + * Add 'coarbitrary' helper for Enums. + * Rejiggled the formatting code to support multi-line error messages + * Add instances for Ordering and Fixed. + * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). + * Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/examples/Heap.hs b/examples/Heap.hs new file mode 100644 --- /dev/null +++ b/examples/Heap.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck +import Test.QuickCheck.Text +import Test.QuickCheck.All + +import Data.List + ( sort + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Empty + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Empty + +isEmpty :: Heap a -> Bool +isEmpty Empty = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Empty = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Empty = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Empty = h1 +Empty `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] + where + merging [] = empty + merging [h] = h + merging hs = merging (sweep hs) + + sweep [] = [] + sweep [h] = [h] + sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Empty : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Empty = [] +toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- specification + +invariant :: Ord a => Heap a -> Bool +invariant Empty = True +invariant (Node x h1 h2) = x <=? h1 && x <=? h2 && invariant h1 && invariant h2 + +(<=?) :: Ord a => a -> Heap a -> Bool +x <=? Empty = True +x <=? Node y _ _ = x <= y + +(==?) :: Ord a => Heap a -> [a] -> Bool +h ==? xs = invariant h && sort (toList h) == sort xs + +-------------------------------------------------------------------------- +-- properties + +prop_Empty = + empty ==? ([] :: [Int]) + +prop_IsEmpty (h :: Heap Int) = + isEmpty h == null (toList h) + +prop_Unit (x :: Int) = + unit x ==? [x] + +prop_Size (h :: Heap Int) = + size h == length (toList h) + +prop_Insert x (h :: Heap Int) = + insert x h ==? (x : toList h) + +prop_RemoveMin (h :: Heap Int) = + cover (size h > 1) 80 "non-trivial" $ + case removeMin h of + Nothing -> h ==? [] + Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) + +prop_Merge h1 (h2 :: Heap Int) = + (h1 `merge` h2) ==? (toList h1 ++ toList h2) + +prop_FromList (xs :: [Int]) = + fromList xs ==? xs + +prop_ToSortedList (h :: Heap Int) = + h ==? xs && xs == sort xs + where + xs = toSortedList h + +-------------------------------------------------------------------------- +-- generators + +instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where + arbitrary = sized (arbHeap Nothing) + where + arbHeap mx n = + frequency $ + [ (1, return Empty) ] ++ + [ (7, do my <- arbitrary `suchThatMaybe` ((>= mx) . Just) + case my of + Nothing -> return Empty + Just y -> liftM2 (Node y) arbHeap2 arbHeap2 + where arbHeap2 = arbHeap (Just y) (n `div` 2)) + | n > 0 + ] + +-------------------------------------------------------------------------- +-- main + +main = $(quickCheckAll) + +-------------------------------------------------------------------------- +-- the end. +{- + shrink Empty = [] + shrink (Node x h1 h2) = + [ h1, h2 ] + ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] + ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] + ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] +-} + +-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + +{- +prop_HeapIsNotSorted (h :: Heap Int) = + expectFailure $ + toList h == toSortedList h +-} +