QuickCheck 2.6 → 2.7
raw patch · 20 files changed
+1089/−326 lines, 20 filesdep +QuickCheckdep +ghc-primdep +old-localedep ~basedep ~template-haskell
Dependencies added: QuickCheck, ghc-prim, old-locale, old-time, test-framework, tf-random
Dependency ranges changed: base, template-haskell
Files
- LICENSE +2/−2
- QuickCheck.cabal +69/−31
- README +4/−23
- Test/QuickCheck.hs +52/−24
- Test/QuickCheck/All.hs +23/−18
- Test/QuickCheck/Arbitrary.hs +234/−85
- Test/QuickCheck/Exception.hs +34/−5
- Test/QuickCheck/Function.hs +2/−3
- Test/QuickCheck/Gen.hs +29/−20
- Test/QuickCheck/Gen/Unsafe.hs +51/−0
- Test/QuickCheck/Modifiers.hs +72/−3
- Test/QuickCheck/Monadic.hs +11/−5
- Test/QuickCheck/Poly.hs +1/−1
- Test/QuickCheck/Property.hs +92/−40
- Test/QuickCheck/Random.hs +105/−0
- Test/QuickCheck/State.hs +3/−2
- Test/QuickCheck/Test.hs +74/−64
- Test/QuickCheck/Text.hs +1/−0
- changelog +62/−0
- examples/Heap.hs +168/−0
LICENSE view
@@ -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
QuickCheck.cabal view
@@ -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 <koen@chalmers.se> Maintainer: QuickCheck developers <quickcheck@projects.haskell.org> 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
README view
@@ -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.
Test/QuickCheck.hs view
@@ -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.
Test/QuickCheck/All.hs view
@@ -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)) |]
Test/QuickCheck/Arbitrary.hs view
@@ -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.
Test/QuickCheck/Exception.hs view
@@ -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.
Test/QuickCheck/Function.hs view
@@ -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.
Test/QuickCheck/Gen.hs view
@@ -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.
+ Test/QuickCheck/Gen/Unsafe.hs view
@@ -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
Test/QuickCheck/Modifiers.hs view
@@ -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
Test/QuickCheck/Monadic.hs view
@@ -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 --------------------------------------------------------------------------
Test/QuickCheck/Poly.hs view
@@ -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(..)
Test/QuickCheck/Property.hs view
@@ -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.
+ Test/QuickCheck/Random.hs view
@@ -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)
Test/QuickCheck/State.hs view
@@ -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
Test/QuickCheck/Test.hs view
@@ -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
Test/QuickCheck/Text.hs view
@@ -1,3 +1,4 @@+-- | Terminal control. Internal QuickCheck module. module Test.QuickCheck.Text ( Str(..) , ranges
+ changelog view
@@ -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.
+ examples/Heap.hs view
@@ -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+-}+