QuickCheck-2.8.1/0000755000000000000000000000000012507503070011721 5ustar0000000000000000QuickCheck-2.8.1/LICENSE0000644000000000000000000000304712507503070012732 0ustar0000000000000000Copyright (c) 2000-2015, Koen Claessen Copyright (c) 2006-2008, Björn Bringert Copyright (c) 2009-2015, Nick Smallbone All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the names of the copyright owners nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. QuickCheck-2.8.1/Setup.lhs0000644000000000000000000000015712507503070013534 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain QuickCheck-2.8.1/QuickCheck.cabal0000644000000000000000000001207512507503070014724 0ustar0000000000000000Name: QuickCheck Version: 2.8.1 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Extra-source-files: README changelog Copyright: 2000-2015 Koen Claessen, 2006-2008 Björn Bringert, 2009-2015 Nick Smallbone Author: Koen Claessen Maintainer: QuickCheck developers Bug-reports: mailto:quickcheck@projects.haskell.org Tested-with: GHC >=6.10, Hugs, UHC Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs Description: QuickCheck is a library for random testing of program properties. . The programmer provides a specification of the program, in the form of properties which functions should satisfy, and QuickCheck then tests that the properties hold in a large number of randomly generated cases. . Specifications are expressed in Haskell, using combinators defined in the QuickCheck library. QuickCheck provides combinators to define properties, observe the distribution of test data, and define test data generators. . You can find a (slightly out-of-date but useful) manual at . source-repository head type: git location: https://github.com/nick8325/quickcheck source-repository this type: git location: https://github.com/nick8325/quickcheck tag: 2.8.1 flag base3 Description: Choose the new smaller, split-up base package. flag base4 Description: Choose the even newer base package with extensible exceptions. flag base4point8 Description: Choose the even more newer base package with natural numbers. flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. library -- Choose which library versions to use. if flag(base4point8) Build-depends: base >= 4.8 && < 5 else if flag(base4) Build-depends: base >= 4 && < 4.8 else if flag(base3) Build-depends: base >= 3 && < 4 else Build-depends: base < 3 if flag(base4point8) || flag(base4) || flag(base3) Build-depends: random Build-depends: containers -- 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, Test.QuickCheck.Random, Test.QuickCheck.Exception -- GHC-specific modules. if impl(ghc) Exposed-Modules: Test.QuickCheck.Function if impl(ghc >= 7) Build-depends: transformers >= 0.2 else cpp-options: -DNO_TRANSFORMERS 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 -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. if impl (ghc < 7.4) cpp-options: -DNO_SAFE_HASKELL -- Use tf-random on newer GHCs. if impl(ghc >= 7) && (flag(base4point8) || flag(base4)) Build-depends: tf-random >= 0.4 else cpp-options: -DNO_TF_RANDOM -- Natural numbers. if !flag(base4point8) cpp-options: -DNO_NATURALS -- 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 -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES -- 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, containers, QuickCheck == 2.8.1, template-haskell >= 2.4, test-framework >= 0.4 && < 0.9 if flag(templateHaskell) Buildable: True else Buildable: False QuickCheck-2.8.1/README0000644000000000000000000000050512507503070012601 0ustar0000000000000000This is QuickCheck 2, a library for random testing of program properties. Install it in the usual way: $ cabal install Please report bugs to the QuickCheck mailing list at quickcheck@projects.haskell.org. If you get errors about Template Haskell, try $ cabal install -f-templateHaskell but please report this as a bug. QuickCheck-2.8.1/changelog0000644000000000000000000001026112507503070013573 0ustar0000000000000000QuickCheck 2.8.1 (released 2015-04-03) * Fix bug where exceptions thrown printing counterexamples weren't being caught when terminal output was disabled * Don't export Test.QuickCheck.Property.result QuickCheck 2.8 (released 2015-03-18) * New features: * Support for GHC 7.10 * Arbitrary instance for Natural * New generators shuffle and sublistOf * Support for generic coarbitrary * When using the cover combinator, insufficient coverage now causes the property to fail * API changes: * Test.QuickCheck.Function: new pattern synonym Fn * genericShrink no longer requires Typeable * Result has a new constructor InsufficientCoverage * resize throws an error if the size is negative * Bug fixes: * Fix memory leaks * Exceptions thrown by callbacks now cause the test to fail * Fixed a bug where the cover combinator wouldn't give a warning if coverage was 0% QuickCheck 2.7.3 (released 2014-03-24) * Add annotations for Safe Haskell. QuickCheck 2.7.2 (released 2014-03-22) * Fix bug in cabal file which broke cabal test QuickCheck 2.7.1 (released 2014-03-20) * Fixed bug - the Small modifier didn't work on unsigned types * Changed arbitrarySizedIntegral to have an Integral constraint instead of just Num 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. QuickCheck-2.8.1/Test/0000755000000000000000000000000012507503070012640 5ustar0000000000000000QuickCheck-2.8.1/Test/QuickCheck.hs0000644000000000000000000001150712507503070015212 0ustar0000000000000000{-| For further information see the . To use QuickCheck to check a property, first define a function expressing that property (functions expressing properties under test tend to be prefixed with @prop_@). Testing that @n + m = m + n@ holds for @Integer@s one might write: @ import Test.QuickCheck prop_commutativeAdd :: Integer -> Integer -> Bool prop_commutativeAdd n m = n + m == m + n @ and testing: >>> quickcheck prop_commutativeAdd +++ OK, passed 100 tests. which tests @prop_commutativeAdd@ on 100 random @(Integer, Integer)@ pairs. 'verboseCheck' can be used to see the actual values generated: >>> verboseCheck prop_commutativeAdd Passed: 0 0 …98 tests omitted… Passed: -68 6 +++ OK, passed 100 tests. and if more than 100 tests are needed the number of tests can be increased by updating the 'stdArgs' record: >>> quickCheckWith stdArgs { maxSuccess = 500 } prop_commutativeAdd +++ OK, passed 500 tests. To let QuickCheck generate values of your own data type an 'Arbitrary' instance must be defined: @ data Point = MkPoint Int Int deriving Eq instance Arbitrary Point where arbitrary = do x <- 'arbitrary' y <- arbitrary return (MkPoint x y) swapPoint :: Point -> Point swapPoint (MkPoint x y) = MkPoint y x -- swapPoint . swapPoint = id prop_swapInvolution point = swapPoint (swapPoint point) == point @ >>> quickCheck prop_swapInvolution +++ OK, passed 100 tests. See "Test.QuickCheck.Function" for generating random shrinkable, showable functions used for testing higher-order functions and "Test.QuickCheck.Monadic" for testing impure or monadic code (e.g. effectful code in 'IO'). -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif module Test.QuickCheck ( -- * Running tests quickCheck , Args(..), Result(..) , stdArgs , quickCheckWith , quickCheckWithResult , quickCheckResult -- ** Running tests verbosely , verboseCheck , verboseCheckWith , verboseCheckWithResult , verboseCheckResult #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 , choose , oneof , frequency , elements , growingElements , sized , resize , scale , suchThat , suchThatMaybe , listOf , listOf1 , vectorOf , infiniteListOf , shuffle , sublistOf -- ** Generators which use Arbitrary , vector , orderedList , infiniteList -- ** Running a generator , generate -- ** Generator debugging , sample , sample' -- * Arbitrary and CoArbitrary classes , Arbitrary(..) , CoArbitrary(..) -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral , arbitrarySizedNatural , arbitrarySizedFractional , arbitrarySizedBoundedIntegral , arbitraryBoundedIntegral , arbitraryBoundedRandom , arbitraryBoundedEnum -- ** Helper functions for implementing shrink #ifndef NO_GENERICS , genericCoarbitrary , 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(..) , Fixed(..) , OrderedList(..) , NonEmptyList(..) , Positive(..) , NonZero(..) , NonNegative(..) , Large(..) , Small(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) #endif -- * Properties , Property, Testable(..) -- ** Property combinators , forAll , forAllShrink , shrinking , (==>) , (===) , ioProperty -- *** Controlling property execution , verbose , once , within , noShrinking -- *** Conjunction and disjunction , (.&.) , (.&&.) , conjoin , (.||.) , disjoin -- *** What to do on failure , counterexample , printTestCase , whenFail , whenFail' , expectFailure -- *** Analysing test distribution , label , collect , classify , cover -- *** Miscellaneous , Discard(..) , discard , mapSize ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Text import Test.QuickCheck.Exception #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/0000755000000000000000000000000012507503070014652 5ustar0000000000000000QuickCheck-2.8.1/Test/QuickCheck/Arbitrary.hs0000644000000000000000000006326112507503070017155 0ustar0000000000000000-- | Type classes for random generation of values. {-# LANGUAGE CPP #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} {-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes Arbitrary(..) , CoArbitrary(..) -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral -- :: Integral a => Gen a , arbitrarySizedNatural -- :: Integral a => Gen a , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedFractional -- :: Fractional a => Gen a , 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, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] , subterms -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b #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] , infiniteList -- :: Arbitrary a => Gen [a] ) where -------------------------------------------------------------------------- -- imports import Control.Applicative import System.Random(Random) import Test.QuickCheck.Gen import Test.QuickCheck.Gen.Unsafe {- import Data.Generics ( (:*:)(..) , (:+:)(..) , Unit(..) ) -} import Data.Char ( chr , ord , isLower , isUpper , toLower , isDigit , isSpace ) #ifndef NO_FIXED import Data.Fixed ( Fixed , HasResolution ) #endif #ifndef NO_NATURALS import Numeric.Natural #endif import Data.Ratio ( Ratio , (%) , numerator , denominator ) import Data.Complex ( Complex((:+)) ) import Data.List ( sort , nub ) import Control.Monad ( liftM , liftM2 , liftM3 , liftM4 , liftM5 ) import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) #ifndef NO_GENERICS import GHC.Generics #endif -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. class Arbitrary a where -- | A generator for values of the given type. arbitrary :: Gen a arbitrary = error "no default generator" -- | Produces a (possibly) empty list of all the possible -- 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@ 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, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) 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 = [] instance RecursivelyShrink V1 where -- The empty type can't be shrunk to anything. grecursivelyShrink _ = [] -- | All immediate subterms of a term. subterms :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] subterms = gSubterms . from class GSubterms f a where -- | Provides the immediate subterms of a term that are of the same type -- as the term itself. -- -- Requires a constructor to be stripped off; this means it skips through -- @M1@ wrappers and returns @[]@ on everything that's not `(:*:)` or `(:+:)`. -- -- Once a `(:*:)` or `(:+:)` constructor has been reached, this function -- delegates to `gSubtermsIncl` to return the immediately next constructor -- available. gSubterms :: f a -> [a] instance GSubterms V1 a where -- The empty type can't be shrunk to anything. gSubterms _ = [] instance GSubterms U1 a where gSubterms U1 = [] instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :*: g) a where gSubterms (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :+: g) a where gSubterms (L1 x) = gSubtermsIncl x gSubterms (R1 x) = gSubtermsIncl x instance GSubterms f a => GSubterms (M1 i c f) a where gSubterms (M1 x) = gSubterms x instance GSubterms (K1 i a) b where gSubterms (K1 _) = [] class GSubtermsIncl f a where -- | Provides the immediate subterms of a term that are of the same type -- as the term itself. -- -- In contrast to `gSubterms`, this returns the immediate next constructor -- available. gSubtermsIncl :: f a -> [a] instance GSubtermsIncl V1 a where -- The empty type can't be shrunk to anything. gSubtermsIncl _ = [] instance GSubtermsIncl U1 a where gSubtermsIncl U1 = [] instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :*: g) a where gSubtermsIncl (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :+: g) a where gSubtermsIncl (L1 x) = gSubtermsIncl x gSubtermsIncl (R1 x) = gSubtermsIncl x instance GSubtermsIncl f a => GSubtermsIncl (M1 i c f) a where gSubtermsIncl (M1 x) = gSubtermsIncl x -- This is the important case: We've found a term of the same type. instance Arbitrary a => GSubtermsIncl (K1 i a) a where gSubtermsIncl (K1 x) = [x] instance GSubtermsIncl (K1 i a) b where gSubtermsIncl (K1 _) = [] #endif -- instances instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where arbitrary = promote (`coarbitrary` arbitrary) instance Arbitrary () where arbitrary = return () instance Arbitrary Bool where arbitrary = choose (False,True) shrink True = [False] shrink False = [] instance Arbitrary Ordering where arbitrary = elements [LT, EQ, GT] shrink GT = [EQ, LT] shrink LT = [EQ] shrink EQ = [] instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)] shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ] shrink _ = [] instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary] shrink (Left x) = [ Left x' | x' <- shrink x ] shrink (Right y) = [ Right y' | y' <- shrink y ] instance Arbitrary a => Arbitrary [a] where arbitrary = sized $ \n -> do k <- choose (0,n) sequence [ arbitrary | _ <- [1..k] ] 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 where n = length xs shrinkOne [] = [] shrinkOne (x:xs) = [ x':xs | x' <- shr x ] ++ [ x:xs' | xs' <- shrinkOne xs ] removes k n xs | k > n = [] | null xs2 = [[]] | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2) where xs1 = take k xs xs2 = drop k xs {- -- "standard" definition for lists: shrink [] = [] shrink (x:xs) = [ xs ] ++ [ x:xs' | xs' <- shrink xs ] ++ [ x':xs | x' <- shrink x ] -} instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where arbitrary = arbitrarySizedFractional 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 #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 ] 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', (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', (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', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] -- typical instance for primitive (numerical) types instance Arbitrary Integer where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral #ifndef NO_NATURALS instance Arbitrary Natural where arbitrary = arbitrarySizedNatural shrink = shrinkIntegral #endif instance Arbitrary Int where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral instance Arbitrary Int8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Char where arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)] shrink c = filter (<. c) $ nub $ ['a','b','c'] ++ [ toLower c | isUpper c ] ++ ['A','B','C'] ++ ['1','2','3'] ++ [' ','\n'] where a <. b = stamp a < stamp b stamp a = ( (not (isLower a) , not (isUpper a) , not (isDigit a)) , (not (a==' ') , not (isSpace a) , a) ) instance Arbitrary Float where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance Arbitrary Double where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac -- ** Helper functions for implementing arbitrary -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Integral a => Gen a arbitrarySizedIntegral = sized $ \n -> inBounds fromInteger (choose (-toInteger n, toInteger n)) -- | Generates a natural number. The number's maximum value depends on -- the size parameter. arbitrarySizedNatural :: Integral a => Gen a arbitrarySizedNatural = sized $ \n -> inBounds fromInteger (choose (0, toInteger n)) inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x)) -- | Generates a fractional number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedFractional :: Fractional a => Gen a arbitrarySizedFractional = sized $ \n -> let n' = toInteger n in do a <- choose ((-n') * precision, n' * precision) b <- choose (1, precision) return (fromRational (a % b)) 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 = 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. arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a arbitraryBoundedRandom = choose (minBound,maxBound) -- | Generates an element of a bounded enumeration. arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a arbitraryBoundedEnum = 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 -- generated more often than big numbers. Inspired by demands from -- Phil Wadler. arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitrarySizedBoundedIntegral = withBounds $ \mn mx -> sized $ \s -> 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) -- ** Helper functions for implementing shrink -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = nub $ [ -x | x < 0, -x > x ] ++ [ x' | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) ] where -- a << b is "morally" abs a < abs b, but taking care of overflow. a << b = case (a >= 0, b >= 0) of (True, True) -> a < b (False, False) -> a > b (True, False) -> a + b < 0 (False, True) -> a + b > 0 -- | Shrink a fraction, but only shrink to integral values. shrinkRealFracToInteger :: RealFrac a => a -> [a] shrinkRealFracToInteger x = nub $ [ -x | x < 0 ] ++ 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 -------------------------------------------------------------------------- -- ** CoArbitrary #ifndef NO_GENERICS -- | Used for random generation of functions. -- -- If you are using a recent GHC, there is a default definition of -- 'coarbitrary' using 'genericCoarbitrary', so if your type has a -- 'Generic' instance it's enough to say -- -- > instance CoArbitrary MyType -- -- You should only use 'genericCoarbitrary' for data types where -- equality is structural, i.e. if you can't have two different -- representations of the same value. An example where it's not -- safe is sets implemented using binary search trees: the same -- set can be represented as several different trees. -- Here you would have to explicitly define -- @coarbitrary s = coarbitrary (toList s)@. #else -- | Used for random generation of functions. #endif class CoArbitrary a where -- | 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) -- @ coarbitrary :: a -> Gen b -> Gen b #ifndef NO_GENERICS default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b coarbitrary = genericCoarbitrary -- | Generic CoArbitrary implementation. genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b genericCoarbitrary = gCoarbitrary . from class GCoArbitrary f where gCoarbitrary :: f a -> Gen b -> Gen b instance GCoArbitrary U1 where gCoarbitrary U1 = id instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where -- Like the instance for tuples. gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where -- Like the instance for Either. gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x instance GCoArbitrary f => GCoArbitrary (M1 i c f) where gCoarbitrary (M1 x) = gCoarbitrary x instance CoArbitrary a => GCoArbitrary (K1 i a) where gCoarbitrary (K1 x) = coarbitrary x #endif {-# 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) (><) = (.) instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where coarbitrary f gen = do xs <- arbitrary coarbitrary (map f xs) gen instance CoArbitrary () where coarbitrary _ = id instance CoArbitrary Bool where coarbitrary False = variant 0 coarbitrary True = variant 1 instance CoArbitrary Ordering where 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 instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where 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) 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 instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a,b) where coarbitrary (x,y) = coarbitrary x . coarbitrary y instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a,b,c) where coarbitrary (x,y,z) = coarbitrary x . 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 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 -- typical instance for primitive (numerical) types instance CoArbitrary Integer where coarbitrary = coarbitraryIntegral #ifndef NO_NATURALS instance CoArbitrary Natural where coarbitrary = coarbitraryIntegral #endif instance CoArbitrary Int where coarbitrary = coarbitraryIntegral instance CoArbitrary Int8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word where coarbitrary = coarbitraryIntegral instance CoArbitrary Word8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Char where coarbitrary = coarbitrary . ord instance CoArbitrary Float where coarbitrary = coarbitraryReal instance CoArbitrary Double where coarbitrary = coarbitraryReal -- ** Helpers for implementing coarbitrary -- | A 'coarbitrary' implementation for integral numbers. coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b coarbitraryIntegral = variant -- | A 'coarbitrary' implementation for real numbers. coarbitraryReal :: Real a => a -> Gen b -> Gen b coarbitraryReal x = coarbitrary (toRational x) -- | 'coarbitrary' helper for lazy people :-). coarbitraryShow :: Show a => a -> Gen b -> Gen b coarbitraryShow x = coarbitrary (show x) -- | A 'coarbitrary' implementation for enums. coarbitraryEnum :: Enum a => a -> Gen b -> Gen b coarbitraryEnum = variant . fromEnum -------------------------------------------------------------------------- -- ** arbitrary generators -- these are here and not in Gen because of the Arbitrary class constraint -- | Generates a list of a given length. vector :: Arbitrary a => Int -> Gen [a] vector k = vectorOf k arbitrary -- | 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. QuickCheck-2.8.1/Test/QuickCheck/Gen.hs0000644000000000000000000001362312507503070015724 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif -- | Test case generation. module Test.QuickCheck.Gen where -------------------------------------------------------------------------- -- imports import System.Random ( Random , StdGen , randomR , split , newStdGen ) import Control.Monad ( liftM , ap , replicateM , filterM ) import Control.Applicative ( Applicative(..) , (<$>) ) import Control.Arrow ( second ) import Test.QuickCheck.Random -------------------------------------------------------------------------- -- ** Generator type -- | 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) = MkGen (\r n -> f (h r n)) instance Applicative Gen where pure = return (<*>) = ap instance Monad Gen where return x = MkGen (\_ _ -> x) MkGen m >>= k = MkGen (\r n -> let (r1,r2) = split r MkGen m' = k (m r1 n) in m' r2 n ) -------------------------------------------------------------------------- -- ** Primitive generator combinators -- | Modifies a generator using an integer seed. variant :: Integral n => n -> Gen a -> Gen a 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 sized f = MkGen (\r n -> let MkGen m = f n in m r n) -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. resize :: Int -> Gen a -> Gen a resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" resize n (MkGen g) = MkGen (\r _ -> g r n) -- | Adjust the size parameter, by transforming it with the given -- function. scale :: (Int -> Int) -> Gen a -> Gen a scale f g = sized (\n -> resize (f n) g) -- | Generates a random element in the given inclusive range. choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) -- | Run a generator. The size passed to the generator is always 30; -- if you want another size then you should explicitly use 'resize'. 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' 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 mapM_ print cases -------------------------------------------------------------------------- -- ** Common generator combinators -- | Generates a value that satisfies a predicate. suchThat :: Gen a -> (a -> Bool) -> Gen a gen `suchThat` p = do mx <- gen `suchThatMaybe` p case mx of Just x -> return x Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) -- | Tries to generate a value that satisfies a predicate. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) gen `suchThatMaybe` p = sized (try 0 . max 1) where try _ 0 = return Nothing try k n = do x <- resize (2*k+n) gen if p x then return (Just x) else try (k+1) (n-1) -- | Randomly uses one of the given generators. The input list -- must be non-empty. oneof :: [Gen a] -> Gen a oneof [] = error "QuickCheck.oneof used with empty list" oneof gs = choose (0,length gs - 1) >>= (gs !!) -- | Chooses one of the given generators, with a weighted random distribution. -- The input list must be non-empty. frequency :: [(Int, Gen a)] -> Gen a frequency [] = error "QuickCheck.frequency used with empty list" frequency xs0 = choose (1, tot) >>= (`pick` xs0) where tot = sum (map fst xs0) pick n ((k,x):xs) | n <= k = x | otherwise = pick (n-k) xs pick _ _ = error "QuickCheck.pick used with empty list" -- | Generates one of the given values. The input list must be non-empty. elements :: [a] -> Gen a elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` choose (0, length xs - 1) -- | Generates a random subsequence of the given list. sublistOf :: [a] -> Gen [a] sublistOf xs = filterM (\_ -> choose (False, True)) xs -- | Generates a random permutation of the given list. shuffle :: [a] -> Gen [a] shuffle [] = return [] shuffle xs = do (y, ys) <- elements (selectOne xs) (y:) <$> shuffle ys where selectOne [] = [] selectOne (y:ys) = (y,ys) : map (second (y:)) (selectOne ys) -- | Takes a list of elements of increasing size, and chooses -- among an initial segment of the list. The size of this initial -- segment increases with the size parameter. -- The input list must be non-empty. growingElements :: [a] -> Gen a 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 . 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) where k = length xs -} -- | Generates a list of random length. The maximum length depends on the -- size parameter. listOf :: Gen a -> Gen [a] listOf gen = sized $ \n -> do k <- choose (0,n) vectorOf k gen -- | Generates a non-empty list of random length. The maximum length -- depends on the size parameter. listOf1 :: Gen a -> Gen [a] listOf1 gen = sized $ \n -> do k <- choose (1,1 `max` n) vectorOf k gen -- | Generates a list of the given length. vectorOf :: Int -> Gen a -> Gen [a] vectorOf = replicateM -- | Generates an infinite list. infiniteListOf :: Gen a -> Gen [a] infiniteListOf gen = sequence (repeat gen) -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Monadic.hs0000644000000000000000000001467612507503070016576 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif {-| Module : Test.QuickCheck.Monadic Allows testing of monadic values. Will generally follow this form: @ prop_monadic a b = 'monadicIO' $ do a\' \<- 'run' (f a) b\' \<- 'run' (f b) -- ... 'assert' someBoolean @ Example using the @FACTOR(1)@ command-line utility: @ import System.Process import Test.QuickCheck import Test.QuickCheck.Monadic -- $ factor 16 -- 16: 2 2 2 2 factor :: Integer -> IO [Integer] factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where parse :: String -> [Integer] parse = map read . tail . words prop_factor :: Positive Integer -> Property prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do factors \<- 'run' (factor n) 'assert' (product factors == n) @ >>> quickCheck prop_factor +++ OK, passed 100 tests. See the paper \"\". -} module Test.QuickCheck.Monadic ( -- * Property monad PropertyM(..) -- * Monadic specification combinators , run , assert , pre , wp , pick , forAllM , monitor , stop -- * Run functions , monadic , monadic' , monadicIO #ifndef NO_ST_MONAD , monadicST , runSTGen #endif ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Gen.Unsafe import Test.QuickCheck.Property import Control.Monad(liftM, liftM2) import Control.Monad.ST import Control.Applicative #ifndef NO_TRANSFORMERS import Control.Monad.IO.Class import Control.Monad.Trans.Class #endif -------------------------------------------------------------------------- -- type PropertyM -- | The property monad is really a monad transformer that can contain -- monadic computations in the monad @m@ it is parameterized by: -- -- * @m@ - the @m@-computations that may be performed within @PropertyM@ -- -- Elements of @PropertyM m a@ may mix property operations and @m@-computations. newtype PropertyM m a = MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } 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)) fail s = stop (failed { reason = s }) #ifndef NO_TRANSFORMERS instance MonadTrans PropertyM where lift = run instance MonadIO m => MonadIO (PropertyM m) where liftIO = run . liftIO #endif stop :: (Testable prop, Monad m) => prop -> PropertyM m a stop p = MkPropertyM (\_k -> return (return (property p))) -- should think about strictness/exceptions here -- assert :: Testable prop => prop -> PropertyM m () -- | Allows embedding non-monadic properties into monadic ones. assert :: Monad m => Bool -> PropertyM m () assert True = return () assert False = fail "Assertion failed" -- should think about strictness/exceptions here -- | Tests preconditions. Unlike 'assert' this does not cause the -- property to fail, rather it discards them just like using the -- implication combinator 'Test.QuickCheck.Property.==>'. -- -- This allows representing the -- -- > {p} x ← e{q} -- -- as -- -- @ -- pre p -- x \<- run e -- assert q -- @ -- pre :: Monad m => Bool -> PropertyM m () pre True = return () pre False = stop rejected -- should be called lift? -- | The lifting operation of the property monad. Allows embedding -- monadic\/'IO'-actions in properties: -- -- @ -- log :: Int -> IO () -- -- prop_foo n = monadicIO $ do -- run (log n) -- -- ... -- @ run :: Monad m => m a -> PropertyM m a run m = MkPropertyM (liftM (m >>=) . promote) -- | Quantification in a monadic property, fits better with -- /do-notation/ than 'forAllM'. pick :: (Monad m, Show a) => Gen a -> PropertyM m a pick gen = MkPropertyM $ \k -> do a <- gen mp <- k a return (do p <- mp return (forAll (return a) (const p))) -- | The -- -- > wp(x ← e, p) -- -- can be expressed as in code as @wp e (\\x -> p)@. wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b wp m k = run m >>= k -- | An alternative to quantification a monadic properties to 'pick', -- with a notation similar to 'forAll'. forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k -- | Allows making observations about the test data: -- -- @ -- monitor ('collect' e) -- @ -- -- collects the distribution of value of @e@. -- -- @ -- monitor ('counterexample' "Failure!") -- @ -- -- Adds @"Failure!"@ to the counterexamples. monitor :: Monad m => (Property -> Property) -> PropertyM m () monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) -- run functions monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property monadic runner m = property (fmap runner (monadic' m)) monadic' :: Monad m => PropertyM m a -> Gen (m Property) monadic' (MkPropertyM m) = m (const (return (return (property True)))) -- | Runs the property monad for 'IO'-computations. -- -- @ -- prop_cat msg = monadicIO $ do -- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) -- -- pre ('System.Exit.ExitSuccess' == exitCode) -- -- assert (stdout == msg) -- @ -- -- >>> quickCheck prop_cat -- +++ OK, passed 100 tests. -- monadicIO :: PropertyM IO a -> Property monadicIO = monadic ioProperty #ifndef NO_ST_MONAD -- | Runs the property monad for 'ST'-computations. -- -- @ -- -- Your mutable sorting algorithm here -- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) -- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' -- -- prop_sortST xs = monadicST $ do -- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) -- assert ('Data.Vector.toList' sorted == sort xs) -- @ -- -- >>> quickCheck prop_sortST -- +++ OK, passed 100 tests. -- monadicST :: (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m)) runSTGen :: (forall s. Gen (ST s a)) -> Gen a runSTGen f = do Capture eval <- capture return (runST (eval f)) #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Modifiers.hs0000644000000000000000000002236712507503070017141 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif #ifndef NO_MULTI_PARAM_TYPE_CLASSES {-# LANGUAGE MultiParamTypeClasses #-} #endif #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif -- | Modifiers for test data. -- -- These types do things such as restricting the kind of test data that can be generated. -- They can be pattern-matched on in properties as a stylistic -- alternative to using explicit quantification. -- -- Examples: -- -- @ -- -- Functions cannot be shown (but see "Test.QuickCheck.Function") -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ -- -- Instead of 'forAll' 'orderedList' -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = -- sort xs == xs -- @ module Test.QuickCheck.Modifiers ( -- ** Type-level modifiers for changing generator behavior Blind(..) , Fixed(..) , OrderedList(..) , NonEmptyList(..) , Positive(..) , NonZero(..) , NonNegative(..) , Large(..) , Small(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) #endif ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Data.List ( sort ) -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class. 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 _ = "(*)" instance Arbitrary a => Arbitrary (Blind a) where arbitrary = Blind `fmap` arbitrary shrink (Blind x) = [ Blind x' | x' <- shrink x ] -------------------------------------------------------------------------- -- | @Fixed x@: as x, but will not be shrunk. 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 -- no shrink function -------------------------------------------------------------------------- -- | @Ordered xs@: guarantees that xs is ordered. 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 shrink (Ordered xs) = [ Ordered xs' | xs' <- shrink xs , sort xs' == xs' ] -------------------------------------------------------------------------- -- | @NonEmpty xs@: guarantees that xs is non-empty. 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)) shrink (NonEmpty xs) = [ NonEmpty xs' | xs' <- shrink xs , not (null xs') ] -------------------------------------------------------------------------- -- | @Positive x@: guarantees that @x \> 0@. newtype Positive a = Positive {getPositive :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , 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 where gt0 (Positive x) = x > 0 shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] -------------------------------------------------------------------------- -- | @NonZero x@: guarantees that @x \/= 0@. newtype NonZero a = NonZero {getNonZero :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Enum #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) shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] -------------------------------------------------------------------------- -- | @NonNegative x@: guarantees that @x \>= 0@. newtype NonNegative a = NonNegative {getNonNegative :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Enum #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 -- why is this distrbution like this? [ (5, (NonNegative . abs) `fmap` arbitrary) , (1, return (NonNegative 0)) ] ) `suchThat` ge0 where ge0 (NonNegative x) = x >= 0 shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] -------------------------------------------------------------------------- -- | @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 {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 shrink (Shrink2 x) = [ Shrink2 y | y <- shrink_x ] ++ [ Shrink2 z | y <- shrink_x , z <- shrink y ] where shrink_x = shrink x -------------------------------------------------------------------------- -- | @Smart _ x@: tries a different order when shrinking. 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 instance Arbitrary a => Arbitrary (Smart a) where arbitrary = do x <- arbitrary return (Smart 0 x) shrink (Smart i x) = take i' ys `ilv` drop i' ys where ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] i' = 0 `max` (i-2) [] `ilv` bs = bs as `ilv` [] = as (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) {- shrink (Smart i x) = part0 ++ part2 ++ part1 where ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] i' = 0 `max` (i-2) k = i `div` 10 part0 = take k ys part1 = take (i'-k) (drop k ys) part2 = drop i' ys -} -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 -- take a (take b xs) == take (a `min` b) xs -- take a xs ++ drop a xs == xs -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) -- == take k ys ++ drop k ys -- == ys #ifndef NO_MULTI_PARAM_TYPE_CLASSES -------------------------------------------------------------------------- -- | @Shrinking _ x@: allows for maintaining a state during shrinking. data Shrinking s a = Shrinking s a 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 instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where arbitrary = do x <- arbitrary return (Shrinking (shrinkInit x) x) shrink (Shrinking s x) = [ Shrinking s' x' | (x',s') <- shrinkState x s ] #endif /* NO_MULTI_PARAM_TYPE_CLASSES */ -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Property.hs0000644000000000000000000004747612507503070017054 0ustar0000000000000000-- | Combinators for constructing properties. {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif module Test.QuickCheck.Property where -------------------------------------------------------------------------- -- 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 import Test.QuickCheck.State hiding (labels) #ifndef NO_TIMEOUT import System.Timeout(timeout) #endif import Data.Maybe import Control.Applicative import Control.Monad import qualified Data.Map as Map import Data.Map(Map) import qualified Data.Set as Set import Data.Set(Set) -------------------------------------------------------------------------- -- fixities infixr 0 ==> infixr 1 .&. infixr 1 .&&. infixr 1 .||. -- The story for exception handling: -- -- To avoid insanity, we have rules about which terms can throw -- exceptions when we evaluate them: -- * A rose tree must evaluate to WHNF without throwing an exception -- * The 'ok' component of a Result must evaluate to Just True or -- Just False or Nothing rather than raise an exception -- * IORose _ must never throw an exception when executed -- -- Both rose trees and Results may loop when we evaluate them, though, -- so we have to be careful not to force them unnecessarily. -- -- We also have to be careful when we use fmap or >>= in the Rose -- monad that the function we supply is total, or else use -- protectResults afterwards to install exception handlers. The -- mapResult function on Properties installs an exception handler for -- us, though. -- -- Of course, the user is free to write "error "ha ha" :: Result" if -- they feel like it. We have to make sure that any user-supplied Rose -- Results or Results get wrapped in exception handlers, which we do by: -- * Making the 'property' function install an exception handler -- round its argument. This function always gets called in the -- right places, because all our Property-accepting functions are -- actually polymorphic over the Testable class so they have to -- call 'property'. -- * Installing an exception handler round a Result before we put it -- in a rose tree (the only place Results can end up). -------------------------------------------------------------------------- -- * Property and Testable types -- | The type of properties. -- -- Backwards combatibility note: in older versions of QuickCheck -- 'Property' was a type synonym for @'Gen' 'Prop'@, so you could mix -- and match property combinators and 'Gen' monad operations. Code -- that does this will no longer typecheck. -- However, it is easy to fix: because of the 'Testable' typeclass, any -- combinator that expects a 'Property' will also accept a @'Gen' 'Property'@. -- If you have a 'Property' where you need a @'Gen' 'a'@, simply wrap -- the property combinator inside a 'return' to get a @'Gen' 'Property'@, and -- all should be well. 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 = MkProperty . return . MkProp . protectResults . return exhaustive _ = True instance Testable Prop where property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r exhaustive _ = True instance Testable prop => Testable (Gen prop) where property mp = MkProperty $ do p <- mp; unProperty (property p) instance Testable Property where property = property . unProperty -- | 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 = 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 -- ** Exception handling protect :: (AnException -> a) -> IO a -> IO a protect f x = either f id `fmap` tryEvaluateIO x -------------------------------------------------------------------------- -- ** Type Prop newtype Prop = MkProp{ unProp :: Rose Result } -- ** type Rose data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) -- Only use IORose if you know that the argument is not going to throw an exception! -- Otherwise, try ioRose. ioRose :: IO (Rose Result) -> Rose Result ioRose = IORose . protectRose joinRose :: Rose (Rose a) -> Rose a joinRose (IORose rs) = IORose (fmap joinRose rs) joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) joinRose (MkRose (MkRose x ts) tts) = -- first shrinks outer quantification; makes most sense MkRose x (map joinRose tts ++ ts) -- first shrinks inner quantification: terrible --MkRose x (ts ++ map joinRose tts) instance Functor Rose where -- f must be total 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 m >>= k = joinRose (fmap k m) -- | Execute the "IORose" bits of a rose tree, returning a tree -- constructed by MkRose. reduceRose :: Rose Result -> IO (Rose Result) reduceRose r@(MkRose _ _) = return r reduceRose (IORose m) = m >>= reduceRose -- | Apply a function to the outermost MkRose constructor of a rose tree. -- The function must be total! onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a onRose f (MkRose x rs) = f x rs onRose f (IORose m) = IORose (fmap (onRose f) m) -- | Wrap a rose tree in an exception handler. protectRose :: IO (Rose Result) -> IO (Rose Result) protectRose = protect (return . exception "Exception") -- | Wrap all the Results in a rose tree in exception handlers. protectResults :: Rose Result -> Rose Result protectResults = onRose $ \x rs -> IORose $ do y <- protectResult (return x) return (MkRose y (map protectResults rs)) -- ** Result type -- | Different kinds of callbacks data Callback = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator | NotCounterexample -- ^ Not affected by the 'verbose' combinator -- | The result of a single test. data Result = MkResult { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard , expect :: Bool -- ^ indicates what the expected result of the property is , reason :: String -- ^ a message indicating what went wrong , theException :: Maybe AnException -- ^ the exception thrown, if any , abort :: Bool -- ^ if True, the test should not be repeated , labels :: Map String Int -- ^ all labels used by this property , stamp :: Set String -- ^ the collected values for this test case , callbacks :: [Callback] -- ^ the callbacks for this test case } exception :: String -> AnException -> Result exception msg err | isDiscard err = rejected | otherwise = failed{ reason = formatException msg err, theException = Just err } formatException :: String -> AnException -> String formatException msg err = msg ++ ":" ++ format (show err) where format xs | isOneLine xs = " '" ++ xs ++ "'" | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] protectResult :: IO Result -> IO Result protectResult = protect (exception "Exception") succeeded, failed, rejected :: Result (succeeded, failed, rejected) = (result{ ok = Just True }, result{ ok = Just False }, result{ ok = Nothing }) where result = MkResult { ok = undefined , expect = True , reason = "" , theException = Nothing , abort = False , labels = Map.empty , stamp = Set.empty , callbacks = [] } -------------------------------------------------------------------------- -- ** Lifting and mapping functions liftBool :: Bool -> Result liftBool True = succeeded liftBool False = failed { reason = "Falsifiable" } mapResult :: Testable prop => (Result -> Result) -> prop -> Property mapResult f = mapRoseResult (protectResults . fmap f) mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property mapTotalResult f = mapRoseResult (fmap f) -- f here mustn't throw an exception (rose tree invariant). mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) mapProp :: Testable prop => (Prop -> Prop) -> prop -> 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 = 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 -- override the default behavior. shrinking :: Testable prop => (a -> [a]) -- ^ 'shrink'-like function. -> a -- ^ The original argument -> (a -> prop) -> Property shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0))) where props x = MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] -- | Disables shrinking for a property altogether. noShrinking :: Testable prop => prop -> Property noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) -- | Adds a callback callback :: Testable prop => Callback -> prop -> Property callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) -- | 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 Left err -> putLine (terminal st) (formatException "Exception thrown while printing test case" err) 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 = callback $ PostFinalFailure NotCounterexample $ \_st _res -> m -- | Performs an 'IO' action every time a property fails. Thus, -- if shrinking is done, this can be used to keep track of the -- failures along the way. whenFail' :: Testable prop => IO () -> prop -> Property whenFail' m = callback $ PostTest NotCounterexample $ \_st res -> if ok res == Just False then m else return () -- | Prints out the generated testcase every time the property is tested. -- Only variables quantified over /inside/ the 'verbose' are printed. verbose :: Testable prop => prop -> Property verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res }) where newCallbacks cbs = PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")): [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] status MkResult{ok = Just True} = "Passed" status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" -- | 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 }) -- | Modifies a property so that it only will be tested once. once :: Testable prop => prop -> Property once = mapTotalResult (\res -> res{ abort = True }) -- | Attaches a label to a property. This is used for reporting -- test case distribution. label :: Testable prop => String -> prop -> Property label s = classify True s -- | Labels a property with a value: -- -- > collect x = label (show x) collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) -- | Conditionally labels test case. classify :: Testable prop => Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property classify b s = cover b 0 s -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage. cover :: Testable prop => Bool -- ^ @True@ if the test case belongs to the class. -> Int -- ^ The required percentage (0-100) of test cases. -> String -- ^ Label for the test case class. -> prop -> Property cover x n s = x `seq` n `seq` s `listSeq` mapTotalResult $ \res -> res { labels = Map.insertWith max s n (labels res), stamp = if x then Set.insert s (stamp res) else stamp res } where [] `listSeq` z = z (x:xs) `listSeq` z = x `seq` xs `listSeq` z -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded), -- or if the given property holds. (==>) :: Testable prop => Bool -> prop -> Property False ==> _ = property Discard True ==> p = property p -- | Considers a property failed if it does not complete within -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property within n = mapRoseResult f -- We rely on the fact that the property will catch the timeout -- exception and turn it into a failed test case. where f rose = ioRose $ do let m `orError` x = fmap (fromMaybe (error x)) m MkRose res roses <- timeout n (reduceRose rose) `orError` "within: timeout exception not caught in Rose Result" res' <- timeout n (protectResult (return res)) `orError` "within: timeout exception not caught in Result" return (MkRose res' (map f roses)) #ifdef NO_TIMEOUT timeout _ = fmap Just #endif -- | Explicit universal quantification: uses an explicitly given -- test case generator. forAll :: (Show a, Testable prop) => Gen a -> (a -> prop) -> Property forAll gen pf = MkProperty $ gen >>= \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' -> 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 -> 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. (.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&&. p2 = conjoin [property p1, property p2] -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property conjoin ps = MkProperty $ do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (conj id roses)) where conj k [] = MkRose (k succeeded) [] conj k (p : ps) = IORose $ do rose@(MkRose result _) <- reduceRose p case ok result of _ | not (expect result) -> return (return failed { reason = "expectFailure may not occur inside a conjunction" }) Just True -> return (conj (addLabels result . addCallbacks result . k) ps) Just False -> return rose Nothing -> do rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps) return $ -- Nasty work to make sure we use the right callbacks case ok result2 of Just True -> MkRose (result2 { ok = Nothing }) [] Just False -> rose2 Nothing -> rose2 addCallbacks result r = r { callbacks = callbacks result ++ callbacks r } addLabels result r = r { labels = Map.unionWith max (labels result) (labels r), stamp = Set.union (stamp result) (stamp r) } -- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .||. p2 = disjoin [property p1, property p2] -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property disjoin 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 disj p q = do result1 <- p case ok result1 of _ | not (expect result1) -> return expectFailureError Just True -> return result1 Just False -> do result2 <- q return $ case ok result2 of _ | not (expect result2) -> expectFailureError Just True -> result2 Just False -> MkResult { ok = Just False, expect = True, reason = sep (reason result1) (reason result2), theException = theException result1 `mplus` theException result2, -- The following three fields are not important because the -- test case has failed anyway abort = False, labels = Map.empty, stamp = Set.empty, callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ callbacks result2 } Nothing -> result2 Nothing -> do result2 <- q return (case ok result2 of _ | not (expect result2) -> expectFailureError Just True -> result2 _ -> result1) expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } sep [] s = s sep s [] = s sep s s' = s ++ ", " ++ s' -- | 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. QuickCheck-2.8.1/Test/QuickCheck/Test.hs0000644000000000000000000004260612507503070016135 0ustar0000000000000000-- | The main test loop. {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif module Test.QuickCheck.Test where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, theException, labels ) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text import Test.QuickCheck.State hiding (labels) import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random import System.Random(split) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char ( isSpace ) import Data.List ( sort , group , groupBy , intersperse ) -------------------------------------------------------------------------- -- quickCheck -- * Running tests -- | Args specifies arguments to the QuickCheck driver data Args = Args { 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 -- | 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 } -- | Given up | GaveUp { numTests :: Int -- Number of tests performed , 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 } -- | 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 } -- | The tests passed but a use of 'cover' had insufficient coverage | InsufficientCoverage { numTests :: Int -- Number of tests performed , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests , output :: String -- Printed output } deriving ( Show ) -- | Check if the test run result was a success isSuccess :: Result -> Bool isSuccess Success{} = True isSuccess _ = False -- | The default test arguments stdArgs :: Args stdArgs = Args { replay = Nothing , maxSuccess = 100 , maxDiscardRatio = 10 , maxSize = 100 , chatty = True -- noShrinking flag? } -- | Tests a property and prints the results to 'stdout'. quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p -- | Tests a property, using test arguments, and prints the results to 'stdout'. quickCheckWith :: Testable prop => Args -> prop -> IO () quickCheckWith args p = quickCheckWithResult args p >> return () -- | Tests a property, produces a test result, and prints the results to 'stdout'. quickCheckResult :: Testable prop => prop -> IO Result quickCheckResult p = quickCheckWithResult stdArgs p -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. quickCheckWithResult :: Testable prop => Args -> prop -> IO Result quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of Nothing -> newQCGen Just (rnd,_) -> return rnd test MkState{ terminal = tm , maxSuccessTests = maxSuccess a , maxDiscardedTests = maxDiscardRatio a * maxSuccess a , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s , numSuccessTests = 0 , numDiscardedTests = 0 , numRecentlyDiscardedTests = 0 , S.labels = Map.empty , collected = [] , expectedFailure = False , randomSeed = rnd , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 } (unGen (unProperty (property' p))) where computeSize' n d -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. | n `roundTo` maxSize a + maxSize a <= maxSuccess a || n >= maxSuccess a || maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a | otherwise = ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a 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'@. verboseCheck :: Testable prop => prop -> IO () verboseCheck p = quickCheck (verbose p) -- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. verboseCheckWith :: Testable prop => Args -> prop -> IO () verboseCheckWith args p = quickCheckWith args (verbose p) -- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. verboseCheckResult :: Testable prop => prop -> IO Result verboseCheckResult p = quickCheckResult (verbose p) -- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result verboseCheckWithResult a p = quickCheckWithResult a (verbose p) -------------------------------------------------------------------------- -- main test loop 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 -> (QCGen -> Int -> Prop) -> IO Result doneTesting st _f | not (expectedFailure st) = do putPart (terminal st) ( bold ("*** Failed!") ++ " Passed " ++ show (numSuccessTests st) ++ " tests (expected failure)" ) finished NoExpectedFailure | insufficientCoverage st = do putPart (terminal st) ( bold ("*** Insufficient coverage after ") ++ show (numSuccessTests st) ++ " tests" ) finished InsufficientCoverage | otherwise = do putPart (terminal st) ( "+++ OK, passed " ++ show (numSuccessTests st) ++ " tests" ) finished Success where finished k = do success st theOutput <- terminalOutput (terminal st) return (k (numSuccessTests st) (summary st) theOutput) giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result giveUp st _f = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") ++ " Passed only " ++ show (numSuccessTests st) ++ " tests" ) success st theOutput <- terminalOutput (terminal st) return GaveUp{ numTests = numSuccessTests st , labels = summary st , output = theOutput } runATest :: State -> (QCGen -> Int -> Prop) -> IO Result runATest st f = do -- CALLBACK before_test putTemp (terminal st) ( "(" ++ number (numSuccessTests st) "test" ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" | numDiscardedTests st > 0 ] ++ ")" ) let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size))) res <- callbackPostTest st res let continue break st' | abort res = break st' | otherwise = test st' cons x xs | Set.null x = xs | otherwise = x:xs case res of MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test do continue doneTesting st{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 , randomSeed = rnd2 , S.labels = Map.unionWith max (S.labels st) (P.labels res) , collected = stamp `cons` collected st , expectedFailure = expect } f MkResult{ok = Nothing, expect = expect} -> -- discarded test do continue giveUp st{ numDiscardedTests = numDiscardedTests st + 1 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 , randomSeed = rnd2 , S.labels = Map.unionWith max (S.labels st) (P.labels res) , expectedFailure = expect } f MkResult{ok = Just False} -> -- failed test do if expect res then putPart (terminal st) (bold "*** Failed! ") else putPart (terminal st) "+++ OK, failed as expected. " (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 , numShrinkTries = totFailed , numShrinkFinal = lastFailed , output = theOutput , reason = P.reason res , theException = P.theException res , labels = summary st } where (rnd1,rnd2) = split (randomSeed st) summary :: State -> [(String,Int)] summary st = reverse . sort . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st)) . group . sort $ [ concat (intersperse ", " (Set.toList s)) | s <- collected st , not (Set.null s) ] success :: State -> IO () success st = case allLabels ++ covers of [] -> do putLine (terminal st) "." [pt] -> do putLine (terminal st) ( " (" ++ dropWhile isSpace pt ++ ")." ) cases -> do putLine (terminal st) ":" sequence_ [ putLine (terminal st) pt | pt <- cases ] where allLabels = reverse . sort . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss)) . group . sort $ [ concat (intersperse ", " s') | s <- collected st , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ] , not (null s') ] covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%") | (l, reqP) <- Map.toList (S.labels st) , labelPercentage l st < reqP ] showP p = (if p < 10 then " " else "") ++ show p ++ "% " labelPercentage :: String -> State -> Int labelPercentage l st = -- XXX in case of a disjunction, a label can occur several times, -- need to think what to do there (100 * occur) `div` maxSuccessTests st where occur = length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] insufficientCoverage :: State -> Bool insufficientCoverage st = or [ labelPercentage l st < reqP | (l, reqP) <- Map.toList (S.labels st) ] -------------------------------------------------------------------------- -- main shrinking loop foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) foundFailure st res ts = do localMin st{ numTryShrinks = 0 } res res ts 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 r <- tryEvaluateIO $ putTemp (terminal st) ( short 26 (oneLine (P.reason res)) ++ " (after " ++ number (numSuccessTests st+1) "test" ++ concat [ " and " ++ show (numSuccessShrinks st) ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ] ++ " shrink" ++ (if numSuccessShrinks st == 1 && numTryShrinks st == 0 then "" else "s") | numSuccessShrinks st > 0 || numTryShrinks st > 0 ] ++ ")..." ) case r of Left err -> localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } Right () -> do r <- tryEvaluate ts case r of Left err -> localMinFound st (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, Int, Int) localMin' st res [] = localMinFound st res localMin' st res (t:ts) = do -- CALLBACK before_test MkRose res' ts' <- protectRose (reduceRose t) res' <- callbackPostTest st res' if ok res' == Just False then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, numTryShrinks = 0 } res' res ts' else localMin st{ numTryShrinks = numTryShrinks st + 1, numTotTryShrinks = numTotTryShrinks st + 1 } res res ts localMinFound :: State -> P.Result -> IO (Int, Int, Int) localMinFound st res = do let report = concat [ "(after " ++ number (numSuccessTests st+1) "test", concat [ " and " ++ number (numSuccessShrinks st) "shrink" | numSuccessShrinks st > 0 ], "): " ] if isOneLine (P.reason res) then putLine (terminal st) (P.reason res ++ " " ++ report) else do putLine (terminal st) report sequence_ [ putLine (terminal st) msg | msg <- lines (P.reason res) ] callbackPostFinalFailure st res -- NB no need to check if callbacks threw an exception because -- we are about to return to the user anyway return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st) -------------------------------------------------------------------------- -- callbacks callbackPostTest :: State -> P.Result -> IO P.Result callbackPostTest st res = protect (exception "Exception running callback") $ do sequence_ [ f st res | PostTest _ f <- callbacks res ] return res callbackPostFinalFailure :: State -> P.Result -> IO () callbackPostFinalFailure st res = do x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ] case x of Left err -> do putLine (terminal st) "*** Exception running callback: " tryEvaluateIO $ putLine (terminal st) (show err) return () Right () -> return () -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Text.hs0000644000000000000000000000650012507503070016133 0ustar0000000000000000-- | Terminal control. Internal QuickCheck module. module Test.QuickCheck.Text ( Str(..) , ranges , number , short , showErr , oneLine , isOneLine , bold , newTerminal , withStdioTerminal , withNullTerminal , terminalOutput , handle , Terminal , putTemp , putPart , putLine ) where -------------------------------------------------------------------------- -- imports import Control.Applicative import System.IO ( hFlush , hPutStr , stdout , stderr , Handle , BufferMode (..) , hGetBuffering , hSetBuffering ) import Data.IORef import Test.QuickCheck.Exception -------------------------------------------------------------------------- -- literal string newtype Str = MkStr String instance Show Str where show (MkStr s) = s ranges :: (Show a, Integral a) => a -> a -> Str ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1)) where n' = k * (n `div` k) -------------------------------------------------------------------------- -- formatting number :: Int -> String -> String number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" short :: Int -> String -> String short n s | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s | otherwise = s where k = length s i = if n >= 5 then 3 else 0 showErr :: Show a => a -> String showErr = unwords . words . show oneLine :: String -> String oneLine = unwords . words isOneLine :: String -> Bool isOneLine xs = '\n' `notElem` xs bold :: String -> String -- not portable: --bold s = "\ESC[1m" ++ s ++ "\ESC[0m" bold s = s -- for now -------------------------------------------------------------------------- -- putting strings data Terminal = MkTerminal (IORef String) (IORef Int) (String -> IO ()) (String -> IO ()) newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal newTerminal out err = do res <- newIORef "" tmp <- newIORef 0 return (MkTerminal res tmp out err) withBuffering :: IO a -> IO a withBuffering action = do mode <- hGetBuffering stderr -- By default stderr is unbuffered. This is very slow, hence we explicitly -- enable line buffering. hSetBuffering stderr LineBuffering action `finally` hSetBuffering stderr mode withStdioTerminal :: (Terminal -> IO a) -> IO a withStdioTerminal action = withBuffering (newTerminal (handle stdout) (handle stderr) >>= action) withNullTerminal :: (Terminal -> IO a) -> IO a withNullTerminal action = newTerminal (const (return ())) (const (return ())) >>= action terminalOutput :: Terminal -> IO String terminalOutput (MkTerminal res _ _ _) = readIORef res handle :: Handle -> String -> IO () handle h s = do hPutStr h s hFlush h flush :: Terminal -> IO () flush (MkTerminal _ tmp _ err) = do n <- readIORef tmp writeIORef tmp 0 err (replicate n ' ' ++ replicate n '\b') putPart, putTemp, putLine :: Terminal -> String -> IO () putPart tm@(MkTerminal res _ out _) s = do flush tm force s out s modifyIORef res (++ s) where force :: [a] -> IO () force = evaluate . seqList seqList :: [a] -> () seqList [] = () seqList (x:xs) = x `seq` seqList xs putLine tm s = putPart tm (s ++ "\n") putTemp tm@(MkTerminal _ tmp _ err) s = do flush tm err (s ++ [ '\b' | _ <- s ]) modifyIORef tmp (+ length s) -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Poly.hs0000644000000000000000000000613512507503070016136 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif -- | Types to help with testing polymorphic properties. -- -- Types 'A', 'B' and 'C' are @newtype@ wrappers around 'Integer' that -- implement 'Eq', 'Show', 'Arbitrary' and 'CoArbitrary'. Types -- 'OrdA', 'OrdB' and 'OrdC' also implement 'Ord' and 'Num'. -- -- See also "Test.QuickCheck.All" for an automatic way of testing -- polymorphic properties. module Test.QuickCheck.Poly ( A(..), B(..), C(..) , OrdA(..), OrdB(..), OrdC(..) ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Arbitrary -------------------------------------------------------------------------- -- polymorphic A, B, C (in Eq) -- A newtype A = A{ unA :: Integer } deriving ( Eq ) instance Show A where showsPrec n (A x) = showsPrec n x instance Arbitrary A where arbitrary = (A . (+1) . abs) `fmap` arbitrary shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ] instance CoArbitrary A where coarbitrary = coarbitrary . unA -- B newtype B = B{ unB :: Integer } deriving ( Eq ) instance Show B where showsPrec n (B x) = showsPrec n x instance Arbitrary B where arbitrary = (B . (+1) . abs) `fmap` arbitrary shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ] instance CoArbitrary B where coarbitrary = coarbitrary . unB -- C newtype C = C{ unC :: Integer } deriving ( Eq ) instance Show C where showsPrec n (C x) = showsPrec n x instance Arbitrary C where arbitrary = (C . (+1) . abs) `fmap` arbitrary shrink (C x) = [ C x' | x' <- shrink x, x' > 0 ] instance CoArbitrary C where coarbitrary = coarbitrary . unC -------------------------------------------------------------------------- -- polymorphic OrdA, OrdB, OrdC (in Eq, Ord) -- OrdA newtype OrdA = OrdA{ unOrdA :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdA where showsPrec n (OrdA x) = showsPrec n x instance Arbitrary OrdA where arbitrary = (OrdA . (+1) . abs) `fmap` arbitrary shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdA where coarbitrary = coarbitrary . unOrdA -- OrdB newtype OrdB = OrdB{ unOrdB :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdB where showsPrec n (OrdB x) = showsPrec n x instance Arbitrary OrdB where arbitrary = (OrdB . (+1) . abs) `fmap` arbitrary shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdB where coarbitrary = coarbitrary . unOrdB -- OrdC newtype OrdC = OrdC{ unOrdC :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdC where showsPrec n (OrdC x) = showsPrec n x instance Arbitrary OrdC where arbitrary = (OrdC . (+1) . abs) `fmap` arbitrary shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdC where coarbitrary = coarbitrary . unOrdC -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/State.hs0000644000000000000000000000411112507503070016263 0ustar0000000000000000-- | QuickCheck's internal state. Internal QuickCheck module. module Test.QuickCheck.State where import Test.QuickCheck.Text import Test.QuickCheck.Random import qualified Data.Map as Map import Data.Map(Map) import Data.Set(Set) -------------------------------------------------------------------------- -- State -- | State represents QuickCheck's internal state while testing a property. -- The state is made visible to callback functions. data State = MkState -- static { terminal :: Terminal -- ^ the current terminal , maxSuccessTests :: Int -- ^ maximum number of successful tests needed , maxDiscardedTests :: Int -- ^ maximum number of tests that can be discarded , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests -- dynamic , numSuccessTests :: !Int -- ^ the current number of tests that have succeeded , numDiscardedTests :: !Int -- ^ the current number of discarded tests , numRecentlyDiscardedTests :: !Int -- ^ the number of discarded tests since the last successful test , labels :: !(Map String Int) -- ^ all labels that have been defined so far , collected :: ![Set String] -- ^ all labels that have been collected so far , expectedFailure :: !Bool -- ^ indicates if the property is expected to fail , randomSeed :: !QCGen -- ^ the current random seed -- shrinking , numSuccessShrinks :: !Int -- ^ number of successful shrinking steps so far , numTryShrinks :: !Int -- ^ number of failed shrinking steps since the last successful shrink , numTotTryShrinks :: !Int -- ^ total number of failed shrinking steps } -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Random.hs0000644000000000000000000000514112507503070016427 0ustar0000000000000000-- | A wrapper around the system random number generator. Internal QuickCheck module. {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif 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) QuickCheck-2.8.1/Test/QuickCheck/Exception.hs0000644000000000000000000000646212507503070017154 0ustar0000000000000000-- | 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. {-# LANGUAGE CPP #-} module Test.QuickCheck.Exception where #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 609) #define OLD_EXCEPTIONS #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 607 #define GHC_INTERRUPT #if __GLASGOW_HASKELL__ < 613 #define GHCI_INTERRUPTED_EXCEPTION #endif #if __GLASGOW_HASKELL__ >= 700 #define NO_BASE_3 #endif #endif #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 #endif #if defined(GHC_INTERRUPT) #if defined(GHCI_INTERRUPTED_EXCEPTION) import Panic(GhcException(Interrupted)) #endif import Data.Typeable #if defined(OLD_EXCEPTIONS) import Data.Dynamic #endif #endif #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 evaluate :: a -> IO a evaluate x = x `seq` return x 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 tryEvaluate :: a -> IO (Either AnException a) tryEvaluate x = tryEvaluateIO (return x) tryEvaluateIO :: IO a -> IO (Either AnException a) tryEvaluateIO m = E.try (m >>= E.evaluate) --tryEvaluateIO m = Right `fmap` m evaluate :: a -> IO a evaluate = E.evaluate -- | Test if an exception was a @^C@. -- QuickCheck won't try to shrink an interrupted test case. isInterrupt :: AnException -> Bool #if defined(GHC_INTERRUPT) #if defined(OLD_EXCEPTIONS) isInterrupt (E.DynException e) = fromDynamic e == Just Interrupted isInterrupt _ = False #elif defined(GHCI_INTERRUPTED_EXCEPTION) isInterrupt e = E.fromException e == Just Interrupted || E.fromException e == Just E.UserInterrupt #else isInterrupt e = E.fromException e == Just E.UserInterrupt #endif #else /* !defined(GHC_INTERRUPT) */ isInterrupt _ = False #endif -- | A special exception that makes QuickCheck discard the test case. -- Normally you should use '==>', but if for some reason this isn't -- possible (e.g. you are deep inside a generator), use 'discard' -- instead. discard :: a isDiscard :: AnException -> Bool (discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) where msg = "DISCARD. " ++ "You should not see this exception, it is internal to QuickCheck." #if defined(OLD_EXCEPTIONS) isDiscard (E.ErrorCall msg') = msg' == msg isDiscard _ = False #else isDiscard (E.SomeException e) = case cast e of Just (E.ErrorCall msg') -> msg' == msg _ -> False #endif finally :: IO a -> IO b -> IO a finally = E.finally #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/Function.hs0000644000000000000000000002164312507503070017001 0ustar0000000000000000{-# LANGUAGE TypeOperators, GADTs, CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. -- -- Example of use: -- -- >>> :{ -- >>> let prop :: Fun String Integer -> Bool -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" -- >>> :} -- >>> quickCheck prop -- *** Failed! Falsifiable (after 3 tests and 134 shrinks): -- {"elephant"->1, "monkey"->1, _->0} -- -- To generate random values of type @'Fun' a b@, -- you must have an instance @'Function' a@. -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function ( Fun(..) , apply , (:->) , Function(..) , functionMap , functionShow #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 , pattern Fn #endif ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly import Data.Char import Data.Word import Data.List( intersperse ) import Data.Maybe( fromJust ) import Data.Ratio import Control.Arrow( (&&&) ) -------------------------------------------------------------------------- -- concrete functions -- | The type of possibly partial concrete functions data a :-> c where Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c) (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) Unit :: c -> (() :-> c) Nil :: a :-> c Table :: Eq a => [(a,c)] -> (a :-> c) Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c) instance Functor ((:->) a) where fmap f (Pair p) = Pair (fmap (fmap f) p) fmap f (p:+:q) = fmap f p :+: fmap f q fmap f (Unit c) = Unit (f c) fmap f Nil = Nil fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ] fmap f (Map g h p) = Map g h (fmap f p) instance (Show a, Show b) => Show (a:->b) where show p = showFunction p Nothing -- only use this on finite functions showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String showFunction p md = "{" ++ concat (intersperse ", " ( [ show x ++ "->" ++ show c | (x,c) <- table p ] ++ [ "_->" ++ show d | Just d <- [md] ] )) ++ "}" -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy abstract (Unit c) _ _ = c abstract Nil d _ = d abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d]) abstract (Map g _ p) d x = abstract p d (g x) -- generating a table from a concrete function table :: (a :-> c) -> [(a,c)] table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ] table (p :+: q) = [ (Left x, c) | (x,c) <- table p ] ++ [ (Right y,c) | (y,c) <- table q ] table (Unit c) = [ ((), c) ] table Nil = [] table (Table xys) = xys table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] -------------------------------------------------------------------------- -- Function class Function a where function :: (a->b) -> (a:->b) -- basic instances instance Function () where function f = Unit (f ()) instance Function Word8 where function f = Table [(x,f x) | x <- [0..255]] instance (Function a, Function b) => Function (a,b) where function f = Pair (function `fmap` function (curry f)) instance (Function a, Function b) => Function (Either a b) where function f = function (f . Left) :+: function (f . Right) -- tuple convenience instances instance (Function a, Function b, Function c) => Function (a,b,c) where function = functionMap (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c)) instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where function = functionMap (\(a,b,c,d) -> (a,(b,c,d))) (\(a,(b,c,d)) -> (a,b,c,d)) instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where function = functionMap (\(a,b,c,d,e) -> (a,(b,c,d,e))) (\(a,(b,c,d,e)) -> (a,b,c,d,e)) instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where function = functionMap (\(a,b,c,d,e,f) -> (a,(b,c,d,e,f))) (\(a,(b,c,d,e,f)) -> (a,b,c,d,e,f)) instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where function = functionMap (\(a,b,c,d,e,f,g) -> (a,(b,c,d,e,f,g))) (\(a,(b,c,d,e,f,g)) -> (a,b,c,d,e,f,g)) -- other instances functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMap g h f = Map g h (function (\b -> f (h b))) functionShow :: (Show a, Read a) => (a->c) -> (a:->c) functionShow f = functionMap show read f instance Function a => Function [a] where function = functionMap g h where g [] = Left () g (x:xs) = Right (x,xs) h (Left _) = [] h (Right (x,xs)) = x:xs instance Function a => Function (Maybe a) where function = functionMap g h where g Nothing = Left () g (Just x) = Right x h (Left _) = Nothing h (Right x) = Just x instance Function Bool where function = functionMap g h where g False = Left () g True = Right () h (Left _) = False h (Right _) = True instance Function Integer where function = functionMap gInteger hInteger where gInteger n | n < 0 = Left (gNatural (abs n - 1)) | otherwise = Right (gNatural n) hInteger (Left ws) = -(hNatural ws + 1) hInteger (Right ws) = hNatural ws gNatural 0 = [] gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256) hNatural [] = 0 hNatural (w:ws) = fromIntegral w + 256 * hNatural ws instance Function Int where function = functionMap fromIntegral fromInteger instance Function Char where function = functionMap ord' chr' where ord' c = fromIntegral (ord c) :: Word8 chr' n = chr (fromIntegral n) instance (Function a, Integral a) => Function (Ratio a) where function = functionMap (numerator &&& denominator) (uncurry (%)) -- poly instances instance Function A where function = functionMap unA A instance Function B where function = functionMap unB B instance Function C where function = functionMap unC C instance Function OrdA where function = functionMap unOrdA OrdA instance Function OrdB where function = functionMap unOrdB OrdB instance Function OrdC where function = functionMap unOrdC OrdC -- instance Arbitrary instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where arbitrary = function `fmap` arbitrary shrink = shrinkFun shrink -------------------------------------------------------------------------- -- shrinking shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] shrinkFun shr (Pair p) = [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] where pair Nil = Nil pair p = Pair p shrinkFun shr (p :+: q) = [ p .+. Nil | not (isNil q) ] ++ [ Nil .+. q | not (isNil p) ] ++ [ p .+. q' | q' <- shrinkFun shr q ] ++ [ p' .+. q | p' <- shrinkFun shr p ] where isNil :: (a :-> b) -> Bool isNil Nil = True isNil _ = False Nil .+. Nil = Nil p .+. q = p :+: q shrinkFun shr (Unit c) = [ Nil ] ++ [ Unit c' | c' <- shr c ] shrinkFun shr (Table xys) = [ table xys' | xys' <- shrinkList shrXy xys ] where shrXy (x,y) = [(x,y') | y' <- shr y] table [] = Nil table xys = Table xys shrinkFun shr Nil = [] shrinkFun shr (Map g h p) = [ mapp g h p' | p' <- shrinkFun shr p ] where mapp g h Nil = Nil mapp g h p = Map g h p -------------------------------------------------------------------------- -- the Fun modifier data Fun a b = Fun (a :-> b, b) (a -> b) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -- | A pattern for matching against the function only: -- -- > prop :: Fun String Integer -> Bool -- > prop (Fn f) = f "banana" == f "monkey" -- || f "banana" == f "elephant" pattern Fn f <- Fun _ f #endif mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p,d) (abstract p d) apply :: Fun a b -> (a -> b) apply (Fun _ f) = f instance (Show a, Show b) => Show (Fun a b) where show (Fun (p,d) _) = showFunction p (Just d) instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where arbitrary = do p <- arbitrary d <- arbitrary return (mkFun p d) shrink (Fun (p,d) _) = [ mkFun p' d' | (p', d') <- shrink (p, d) ] -------------------------------------------------------------------------- -- the end. QuickCheck-2.8.1/Test/QuickCheck/All.hs0000644000000000000000000001650412507503070015724 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif -- | 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 quickCheckAll, verboseCheckAll, forAllProperties, -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, monomorphic) where import Language.Haskell.TH import Test.QuickCheck.Property hiding (Result) import Test.QuickCheck.Test import Data.Char import Data.List import Control.Monad import qualified System.IO as S -- | Test a polymorphic property, defaulting all type variables to 'Integer'. -- -- 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. -- -- If you want to use 'polyQuickCheck' in the same file where you defined the -- property, the same scoping problems pop up as in 'quickCheckAll': -- see the note there about @return []@. polyQuickCheck :: Name -> ExpQ polyQuickCheck x = [| quickCheck $(monomorphic x) |] -- | Test a polymorphic property, defaulting all type variables to 'Integer'. -- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'. -- -- If you want to use 'polyVerboseCheck' in the same file where you defined the -- property, the same scoping problems pop up as in 'quickCheckAll': -- see the note there about @return []@. polyVerboseCheck :: Name -> ExpQ polyVerboseCheck x = [| verboseCheck $(monomorphic x) |] type Error = forall a. String -> a -- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'. -- -- For example, if @f@ has type @'Ord' a => [a] -> [a]@ -- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@. -- -- If you want to use 'monomorphic' in the same file where you defined the -- property, the same scoping problems pop up as in 'quickCheckAll': -- see the note there about @return []@. monomorphic :: Name -> ExpQ monomorphic t = do ty0 <- fmap infoType (reify t) let err msg = error $ msg ++ ": " ++ pprint ty0 (polys, ctx, ty) <- deconstructType err ty0 case polys of [] -> return (VarE t) _ -> do integer <- [t| Integer |] ty' <- monomorphiseType err integer ty return (SigE (VarE t) ty') infoType :: Info -> Type infoType (ClassOpI _ ty _ _) = ty infoType (DataConI _ ty _ _) = ty infoType (VarI _ ty _ _) = ty deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) deconstructType err ty0@(ForallT xs ctx ty) = do let plain (PlainTV _) = True #ifndef MIN_VERSION_template_haskell plain (KindedTV _ StarT) = True #else #if MIN_VERSION_template_haskell(2,8,0) plain (KindedTV _ StarT) = True #else plain (KindedTV _ StarK) = True #endif #endif plain _ = False unless (all plain xs) $ err "Higher-kinded type variables in type" return (map (\(PlainTV x) -> x) xs, ctx, ty) deconstructType _ 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' -- apply. -- -- @$'forAllProperties'@ has type @('Property' -> 'IO' 'Result') -> 'IO' 'Bool'@. -- An example invocation is @$'forAllProperties' 'quickCheckResult'@, -- which does the same thing as @$'quickCheckAll'@. -- -- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool forAllProperties = do Loc { loc_filename = filename } <- location when (filename == "") $ error "don't run this interactively" ls <- runIO (fmap lines (readUTF8File filename)) let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') . dropWhile (\c -> isSpace c || c == '>')) ls idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes)) #if __GLASGOW_HASKELL__ > 705 warning x = reportWarning ("Name " ++ x ++ " found in source file but was not in scope") #else warning x = report False ("Name " ++ x ++ " found in source file but was not in scope") #endif quickCheckOne :: (Int, String) -> Q [Exp] quickCheckOne (l, x) = do exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True) if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), property $(monomorphic (mkName x))) |] ] else return [] [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] readUTF8File name = S.openFile name S.ReadMode >>= set_utf8_io_enc >>= S.hGetContents -- Deal with UTF-8 input and output. set_utf8_io_enc :: S.Handle -> IO S.Handle #if __GLASGOW_HASKELL__ > 611 -- possibly if MIN_VERSION_base(4,2,0) set_utf8_io_enc h = do S.hSetEncoding h S.utf8; return h #else set_utf8_io_enc h = return h #endif -- | Test all properties in the current module. -- The name of the property must begin with @prop_@. -- Polymorphic properties will be defaulted to 'Integer'. -- Returns 'True' if all tests succeeded, 'False' otherwise. -- -- To use 'quickCheckAll', add a definition to your module along -- the lines of -- -- > return [] -- > runTests = $quickCheckAll -- -- and then execute @runTests@. -- -- Note: the bizarre @return []@ in the example above is needed on -- GHC 7.8; without it, 'quickCheckAll' will not be able to find -- any of the properties. For the curious, the @return []@ is a -- Template Haskell splice that makes GHC insert the empty list -- of declarations at that point in the program; GHC typechecks -- everything before the @return []@ before it starts on the rest -- of the module, which means that the later call to 'quickCheckAll' -- can see everything that was defined before the @return []@. Yikes! quickCheckAll :: Q Exp quickCheckAll = [| $(forAllProperties) quickCheckResult |] -- | Test all properties in the current module. -- This is just a convenience function that combines 'quickCheckAll' and 'verbose'. -- -- 'verboseCheckAll' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. verboseCheckAll :: Q Exp verboseCheckAll = [| $(forAllProperties) verboseCheckResult |] runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool runQuickCheckAll ps qc = fmap and . forM ps $ \(xs, p) -> do putStrLn $ "=== " ++ xs ++ " ===" r <- qc p putStrLn "" return $ case r of Success { } -> True Failure { } -> False NoExpectedFailure { } -> False GaveUp { } -> False InsufficientCoverage { } -> False QuickCheck-2.8.1/Test/QuickCheck/Gen/0000755000000000000000000000000012507503070015363 5ustar0000000000000000QuickCheck-2.8.1/Test/QuickCheck/Gen/Unsafe.hs0000644000000000000000000000343312507503070017143 0ustar0000000000000000{-# 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 QuickCheck-2.8.1/examples/0000755000000000000000000000000012507503070013537 5ustar0000000000000000QuickCheck-2.8.1/examples/Heap.hs0000644000000000000000000001006712507503070014754 0ustar0000000000000000{-# 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 return [] 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 -}