QuickCheck-2.9.2/0000755000000000000000000000000012766470776011752 5ustar0000000000000000QuickCheck-2.9.2/LICENSE0000644000000000000000000000304712766470776012763 0ustar0000000000000000Copyright (c) 2000-2016, Koen Claessen Copyright (c) 2006-2008, Björn Bringert Copyright (c) 2009-2016, 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.9.2/Setup.lhs0000644000000000000000000000015712766470776013565 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain QuickCheck-2.9.2/QuickCheck.cabal0000644000000000000000000001203512766470776014751 0ustar0000000000000000Name: QuickCheck Version: 2.9.2 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Extra-source-files: README changelog Copyright: 2000-2016 Koen Claessen, 2006-2008 Björn Bringert, 2009-2016 Nick Smallbone Author: Koen Claessen Maintainer: QuickCheck developers Bug-reports: mailto:quickcheck@projects.haskell.org Tested-with: GHC >= 7 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.9.2 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True library Build-depends: base >=4.3 && <5, random, 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 Build-depends: transformers >= 0.2 else cpp-options: -DNO_TRANSFORMERS if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 Other-Extensions: TemplateHaskell Exposed-Modules: Test.QuickCheck.All else cpp-options: -DNO_TEMPLATE_HASKELL -- 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) Build-depends: tf-random >= 0.4 else cpp-options: -DNO_TF_RANDOM if impl(ghc) if impl(ghc < 7.10) -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8 build-depends: nats>=1 else cpp-options: -DNO_NATURALS if impl(ghc) -- 'Data.List.NonEmpty' is available in base only since GHC 8.0 / base 4.9 if impl(ghc < 8.0) build-depends: semigroups >=0.9 else cpp-options: -DNO_NONEMPTY -- 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.9.2, template-haskell >= 2.4, test-framework >= 0.4 && < 0.9 if flag(templateHaskell) Buildable: True else Buildable: False Test-Suite test-quickcheck-gcoarbitrary type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck == 2.9.2 if impl(ghc < 7.2) buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Generators.hs build-depends: base, QuickCheck == 2.9.2 if !flag(templateHaskell) Buildable: False Test-Suite test-quickcheck-gshrink type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: GShrinkExample.hs build-depends: base, QuickCheck == 2.9.2 if impl(ghc < 7.2) buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim QuickCheck-2.9.2/README0000644000000000000000000000050512766470776012632 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.9.2/changelog0000644000000000000000000001260412766470776013627 0ustar0000000000000000QuickCheck 2.9.2 (released 2016-09-15) * Fix a bug where some properties were only being tested once * Make shrinking of floating-point values less aggressive * Add function chooseAny :: Random a => Gen a QuickCheck 2.9.1 (released 2016-07-11) * 'again' was only used in forAllShrink, not forAll QuickCheck 2.9 (released 2016-07-10) * Arbitrary, CoArbitrary and Function instances for more types * Generics for automatic Function instances * A new combinator "again" which undoes the effect of "once" * Remove "exhaustive" from Testable typeclass; instead, combinators which are nonexhaustive (such as forAll) call "again", which should be more robust * Drop support for GHC 6.x * Fixed bugs: * arbitrarySizedBoundedIntegral wasn't generating huge integers * verboseCheck failed with Test.QuickCheck.Function * label had a space leak QuickCheck 2.8.2 (released 2016-01-15) * GHC 8 support * Add Arbitrary and CoArbitrary instances for types in containers package * Improve speed of shuffle combinator * Only print to stderr if it's a terminal. * Small changes: slightly improve documentation, remove redundant constraints from some functions' types, small improvements to Test.QuickCheck.All. QuickCheck 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.9.2/Test/0000755000000000000000000000000012766470776012671 5ustar0000000000000000QuickCheck-2.9.2/Test/QuickCheck.hs0000644000000000000000000001146512766470776015246 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 -- ** 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 , again , 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.9.2/Test/QuickCheck/0000755000000000000000000000000012766470776014703 5ustar0000000000000000QuickCheck-2.9.2/Test/QuickCheck/Arbitrary.hs0000644000000000000000000010434212766470776017202 0ustar0000000000000000-- | Type classes for random generation of values. {-# LANGUAGE CPP #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} {-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif #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] -- ** 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 Data.Foldable(toList) 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 ) #ifndef NO_NONEMPTY import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe (mapMaybe) #endif import Data.Version (Version (..)) 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 import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified Data.Sequence as Sequence import qualified Data.Monoid as Monoid #ifndef NO_TRANSFORMERS import Data.Functor.Identity import Data.Functor.Constant #endif -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. class Arbitrary a where -- | A generator for values of the given type. arbitrary :: Gen a -- | 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, 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, 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 {-# OVERLAPPING #-} GSubtermsIncl (K1 i a) a where gSubtermsIncl (K1 x) = [x] instance {-# OVERLAPPING #-} 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 = listOf arbitrary shrink xs = shrinkList shrink xs #ifndef NO_NONEMPTY instance Arbitrary a => Arbitrary (NonEmpty a) where arbitrary = liftM2 (:|) arbitrary arbitrary shrink (x :| xs) = mapMaybe nonEmpty . shrinkList shrink $ x : xs #endif -- | 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 (Ratio a) where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac 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)))) ] instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e , Arbitrary f ) => Arbitrary (a,b,c,d,e,f) where arbitrary = return (,,,,,) <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink (u, v, w, x, y, z) = [ (u', v', w', x', y', z') | (u', (v', (w', (x', (y', z'))))) <- shrink (u, (v, (w, (x, (y, z))))) ] instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e , Arbitrary f, Arbitrary g ) => Arbitrary (a,b,c,d,e,f,g) where arbitrary = return (,,,,,,) <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink (t, u, v, w, x, y, z) = [ (t', u', v', w', x', y', z') | (t', (u', (v', (w', (x', (y', z')))))) <- shrink (t, (u, (v, (w, (x, (y, z)))))) ] instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e , Arbitrary f, Arbitrary g, Arbitrary h ) => Arbitrary (a,b,c,d,e,f,g,h) where arbitrary = return (,,,,,,,) <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink (s, t, u, v, w, x, y, z) = [ (s', t', u', v', w', x', y', z') | (s', (t', (u', (v', (w', (x', (y', z'))))))) <- shrink (s, (t, (u, (v, (w, (x, (y, z))))))) ] instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i ) => Arbitrary (a,b,c,d,e,f,g,h,i) where arbitrary = return (,,,,,,,,) <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink (r, s, t, u, v, w, x, y, z) = [ (r', s', t', u', v', w', x', y', z') | (r', (s', (t', (u', (v', (w', (x', (y', z')))))))) <- shrink (r, (s, (t, (u, (v, (w, (x, (y, z)))))))) ] instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j ) => Arbitrary (a,b,c,d,e,f,g,h,i,j) where arbitrary = return (,,,,,,,,,) <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary shrink (q, r, s, t, u, v, w, x, y, z) = [ (q', r', s', t', u', v', w', x', y', z') | (q', (r', (s', (t', (u', (v', (w', (x', (y', z'))))))))) <- shrink (q, (r, (s, (t, (u, (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 -- Arbitrary instances for container types instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where arbitrary = fmap Set.fromList arbitrary shrink = map Set.fromList . shrink . Set.toList instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where arbitrary = fmap Map.fromList arbitrary shrink = map Map.fromList . shrink . Map.toList instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary shrink = map IntSet.fromList . shrink . IntSet.toList instance Arbitrary a => Arbitrary (IntMap.IntMap a) where arbitrary = fmap IntMap.fromList arbitrary shrink = map IntMap.fromList . shrink . IntMap.toList instance Arbitrary a => Arbitrary (Sequence.Seq a) where arbitrary = fmap Sequence.fromList arbitrary shrink = map Sequence.fromList . shrink . toList -- Arbitrary instance for Ziplist instance Arbitrary a => Arbitrary (ZipList a) where arbitrary = fmap ZipList arbitrary shrink = map ZipList . shrink . getZipList #ifndef NO_TRANSFORMERS -- Arbitrary instance for transformers' Functors instance Arbitrary a => Arbitrary (Identity a) where arbitrary = fmap Identity arbitrary shrink = map Identity . shrink . runIdentity instance Arbitrary a => Arbitrary (Constant a b) where arbitrary = fmap Constant arbitrary shrink = map Constant . shrink . getConstant #endif -- Arbitrary instance for Const instance Arbitrary a => Arbitrary (Const a b) where arbitrary = fmap Const arbitrary shrink = map Const . shrink . getConst -- Arbitrary instances for Monoid instance Arbitrary a => Arbitrary (Monoid.Dual a) where arbitrary = fmap Monoid.Dual arbitrary shrink = map Monoid.Dual . shrink . Monoid.getDual instance (Arbitrary a, CoArbitrary a) => Arbitrary (Monoid.Endo a) where arbitrary = fmap Monoid.Endo arbitrary shrink = map Monoid.Endo . shrink . Monoid.appEndo instance Arbitrary Monoid.All where arbitrary = fmap Monoid.All arbitrary shrink = map Monoid.All . shrink . Monoid.getAll instance Arbitrary Monoid.Any where arbitrary = fmap Monoid.Any arbitrary shrink = map Monoid.Any . shrink . Monoid.getAny instance Arbitrary a => Arbitrary (Monoid.Sum a) where arbitrary = fmap Monoid.Sum arbitrary shrink = map Monoid.Sum . shrink . Monoid.getSum instance Arbitrary a => Arbitrary (Monoid.Product a) where arbitrary = fmap Monoid.Product arbitrary shrink = map Monoid.Product . shrink . Monoid.getProduct #if defined(MIN_VERSION_base) #if MIN_VERSION_base(3,0,0) instance Arbitrary a => Arbitrary (Monoid.First a) where arbitrary = fmap Monoid.First arbitrary shrink = map Monoid.First . shrink . Monoid.getFirst instance Arbitrary a => Arbitrary (Monoid.Last a) where arbitrary = fmap Monoid.Last arbitrary shrink = map Monoid.Last . shrink . Monoid.getLast #endif #if MIN_VERSION_base(4,8,0) instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where arbitrary = fmap Monoid.Alt arbitrary shrink = map Monoid.Alt . shrink . Monoid.getAlt #endif #endif -- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ instance Arbitrary Version where arbitrary = sized $ \n -> do k <- choose (0, log2 n) xs <- vectorOf (k+1) arbitrarySizedNatural return (Version xs []) where log2 :: Int -> Int log2 n | n <= 1 = 0 | otherwise = 1 + log2 (n `div` 2) shrink (Version xs _) = [ Version xs' [] | xs' <- shrink xs , length xs' > 0 , all (>=0) xs' ] -- ** 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 == 0 = 0 | otherwise = 1 + bits (n `quot` 2) k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 80) 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. shrinkRealFrac :: RealFrac a => a -> [a] shrinkRealFrac x = nub $ [ -x | x < 0 ] ++ map fromInteger (shrinkIntegral (truncate x)) -------------------------------------------------------------------------- -- ** 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) #ifndef NO_NONEMPTY instance CoArbitrary a => CoArbitrary (NonEmpty a) where coarbitrary (x :| xs) = coarbitrary (x, xs) #endif 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 -- Coarbitrary instances for container types instance CoArbitrary a => CoArbitrary (Set.Set a) where coarbitrary = coarbitrary. Set.toList instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where coarbitrary = coarbitrary . Map.toList instance CoArbitrary IntSet.IntSet where coarbitrary = coarbitrary . IntSet.toList instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where coarbitrary = coarbitrary . IntMap.toList instance CoArbitrary a => CoArbitrary (Sequence.Seq a) where coarbitrary = coarbitrary . toList -- CoArbitrary instance for Ziplist instance CoArbitrary a => CoArbitrary (ZipList a) where coarbitrary = coarbitrary . getZipList #ifndef NO_TRANSFORMERS -- CoArbitrary instance for transformers' Functors instance CoArbitrary a => CoArbitrary (Identity a) where coarbitrary = coarbitrary . runIdentity instance CoArbitrary a => CoArbitrary (Constant a b) where coarbitrary = coarbitrary . getConstant #endif -- CoArbitrary instance for Const instance CoArbitrary a => CoArbitrary (Const a b) where coarbitrary = coarbitrary . getConst -- CoArbitrary instances for Monoid instance CoArbitrary a => CoArbitrary (Monoid.Dual a) where coarbitrary = coarbitrary . Monoid.getDual instance (Arbitrary a, CoArbitrary a) => CoArbitrary (Monoid.Endo a) where coarbitrary = coarbitrary . Monoid.appEndo instance CoArbitrary Monoid.All where coarbitrary = coarbitrary . Monoid.getAll instance CoArbitrary Monoid.Any where coarbitrary = coarbitrary . Monoid.getAny instance CoArbitrary a => CoArbitrary (Monoid.Sum a) where coarbitrary = coarbitrary . Monoid.getSum instance CoArbitrary a => CoArbitrary (Monoid.Product a) where coarbitrary = coarbitrary . Monoid.getProduct #if defined(MIN_VERSION_base) #if MIN_VERSION_base(3,0,0) instance CoArbitrary a => CoArbitrary (Monoid.First a) where coarbitrary = coarbitrary . Monoid.getFirst instance CoArbitrary a => CoArbitrary (Monoid.Last a) where coarbitrary = coarbitrary . Monoid.getLast #endif #if MIN_VERSION_base(4,8,0) instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where coarbitrary = coarbitrary . Monoid.getAlt #endif #endif instance CoArbitrary Version where coarbitrary (Version a b) = coarbitrary (a, b) -- ** 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. 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.9.2/Test/QuickCheck/Gen.hs0000644000000000000000000001403512766470776015753 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif -- | Test case generation. module Test.QuickCheck.Gen where -------------------------------------------------------------------------- -- imports import System.Random ( Random , StdGen , random , randomR , split , newStdGen ) import Control.Monad ( liftM , ap , replicateM , filterM ) import Control.Applicative ( Applicative(..) , (<$>) ) import Control.Arrow ( second ) import Test.QuickCheck.Random import Data.List import Data.Ord -------------------------------------------------------------------------- -- ** 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) -- | Generates a random element over the natural range of `a`. chooseAny :: Random a => Gen a chooseAny = MkGen (\r _ -> let (x,_) = random 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 xs = do ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) return (map snd (sortBy (comparing fst) (zip ns xs))) -- | 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.9.2/Test/QuickCheck/Monadic.hs0000644000000000000000000001467612766470776016627 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.9.2/Test/QuickCheck/Modifiers.hs0000644000000000000000000002236612766470776017171 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, Eq 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.9.2/Test/QuickCheck/Property.hs0000644000000000000000000004655312766470776017100 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. 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 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 instance Testable Bool where property = property . liftBool instance Testable Result where property = MkProperty . return . MkProp . protectResults . return instance Testable Prop where property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r instance Testable prop => Testable (Gen prop) where property mp = MkProperty $ do p <- mp; unProperty (again 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". -- -- Note that if you use 'ioProperty' on a property of type @IO Bool@, -- or more generally a property that does no quantification, the property -- will only be executed once. To test the property repeatedly you must -- use the 'again' combinator. 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 = True , 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 }) -- | Undoes the effect of 'once'. again :: Testable prop => prop -> Property again = mapTotalResult (\res -> res{ abort = False }) -- | 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 = forAllShrink gen (\_ -> []) pf -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop) => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrink gen shrinker pf = again $ 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 = again $ 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 = again $ 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 = again $ 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.9.2/Test/QuickCheck/Test.hs0000644000000000000000000004316712766470776016171 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) #if defined(MIN_VERSION_containers) #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map #else import qualified Data.Map as Map #endif #else import qualified Data.Map as Map #endif 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? -- Note: saving a seed from one version of QuickCheck and -- replaying it in another is not supported. -- If you want to store a test case permanently you should save -- the test case itself. , 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 -- | 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.9.2/Test/QuickCheck/Text.hs0000644000000000000000000000666212766470776016175 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 , hIsTerminalDevice ) 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 = do isatty <- hIsTerminalDevice stderr let err = if isatty then handle stderr else const (return ()) withBuffering (newTerminal (handle stdout) err >>= 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.9.2/Test/QuickCheck/Poly.hs0000644000000000000000000000613512766470776016167 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.9.2/Test/QuickCheck/State.hs0000644000000000000000000000411112766470776016314 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.9.2/Test/QuickCheck/Random.hs0000644000000000000000000000514712766470776016466 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) = case split g of (g1, g2) -> (QCGen g1, QCGen g2) genRange (QCGen g) = genRange g next (QCGen g) = case next g of (x, g') -> (x, QCGen 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.9.2/Test/QuickCheck/Exception.hs0000644000000000000000000000476012766470776017204 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__ < 700) #define OLD_EXCEPTIONS #endif #if defined(NO_EXCEPTIONS) #else import qualified Control.Exception as E #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(OLD_EXCEPTIONS) isInterrupt _ = False #else isInterrupt e = E.fromException e == Just E.UserInterrupt #endif -- | A special exception that makes QuickCheck discard the test case. -- Normally you should use '==>', but if for some reason this isn't -- possible (e.g. you are deep inside a generator), use 'discard' -- instead. 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 = case E.fromException 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.9.2/Test/QuickCheck/Function.hs0000644000000000000000000003364112766470776017033 0ustar0000000000000000{-# LANGUAGE TypeOperators, GADTs, CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts #-} #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 , functionIntegral , functionRealFrac , functionBoundedEnum #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( (&&&) ) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Sequence as Sequence import Data.Int import Data.Word import Data.Complex import Data.Foldable(toList) #ifndef NO_FIXED import Data.Fixed #endif #ifndef NO_NATURALS import Numeric.Natural #endif #ifndef NO_NONEMPTY import Data.List.NonEmpty(NonEmpty(..)) #endif #ifndef NO_GENERICS import GHC.Generics hiding (C) #endif -------------------------------------------------------------------------- -- 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) #ifndef NO_GENERICS default function :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) function = genericFunction #endif -- basic instances -- | Provides a 'Function' instance for types with 'Bounded' and 'Enum'. -- Use only for small types (i.e. not integers): creates -- the list @['minBound'..'maxBound']@! functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b) functionBoundedEnum f = Table [(x,f x) | x <- [minBound..maxBound]] -- | Provides a 'Function' instance for types with 'RealFrac'. functionRealFrac :: RealFrac a => (a->b) -> (a:->b) functionRealFrac = functionMap toRational fromRational -- | Provides a 'Function' instance for types with 'Integral'. functionIntegral :: Integral a => (a->b) -> (a:->b) functionIntegral = functionMap fromIntegral fromInteger -- | Provides a 'Function' instance for types with 'Show' and 'Read'. functionShow :: (Show a, Read a) => (a->c) -> (a:->c) functionShow f = functionMap show read f -- | The basic building block for 'Function' instances. -- Provides a 'Function' instance by mapping to and from a type that -- already has a 'Function' instance. functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMap = functionMapWith function functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMapWith function g h f = Map g h (function (\b -> f (h b))) instance Function () where function f = Unit (f ()) instance (Function a, Function b) => Function (a,b) where function = functionPairWith function function functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) instance (Function a, Function b) => Function (Either a b) where function = functionEitherWith function function functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (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 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 = functionIntegral instance Function Char where function = functionMap ord chr instance Function Float where function = functionRealFrac instance Function Double where function = functionRealFrac -- instances for assorted types in the base package instance Function Ordering where function = functionMap g h where g LT = Left False g EQ = Left True g GT = Right () h (Left False) = LT h (Left True) = EQ h (Right _) = GT #ifndef NO_NONEMPTY instance Function a => Function (NonEmpty a) where function = functionMap g h where g (x :| xs) = (x, xs) h (x, xs) = x :| xs #endif instance (Integral a, Function a) => Function (Ratio a) where function = functionMap g h where g r = (numerator r, denominator r) h (n, d) = n % d #ifndef NO_FIXED instance HasResolution a => Function (Fixed a) where function = functionRealFrac #endif instance (RealFloat a, Function a) => Function (Complex a) where function = functionMap g h where g (x :+ y) = (x, y) h (x, y) = x :+ y instance (Ord a, Function a) => Function (Set.Set a) where function = functionMap Set.toList Set.fromList instance (Ord a, Function a, Function b) => Function (Map.Map a b) where function = functionMap Map.toList Map.fromList instance Function IntSet.IntSet where function = functionMap IntSet.toList IntSet.fromList instance Function a => Function (IntMap.IntMap a) where function = functionMap IntMap.toList IntMap.fromList instance Function a => Function (Sequence.Seq a) where function = functionMap toList Sequence.fromList #ifndef NO_NATURALS instance Function Natural where function = functionIntegral #endif instance Function Int8 where function = functionBoundedEnum instance Function Int16 where function = functionIntegral instance Function Int32 where function = functionIntegral instance Function Int64 where function = functionIntegral instance Function Word8 where function = functionBoundedEnum instance Function Word16 where function = functionIntegral instance Function Word32 where function = functionIntegral instance Function Word64 where function = functionIntegral -- 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 -------------------------------------------------------------------------- -- generic function instances #ifndef NO_GENERICS -- | Generic 'Function' implementation. genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) genericFunction = functionMapWith gFunction from to class GFunction f where gFunction :: (f a -> b) -> (f a :-> b) instance GFunction U1 where gFunction = functionMap (\U1 -> ()) (\() -> U1) instance (GFunction f, GFunction g) => GFunction (f :*: g) where gFunction = functionMapWith (functionPairWith gFunction gFunction) g h where g (x :*: y) = (x, y) h (x, y) = x :*: y instance (GFunction f, GFunction g) => GFunction (f :+: g) where gFunction = functionMapWith (functionEitherWith gFunction gFunction) g h where g (L1 x) = Left x g (R1 x) = Right x h (Left x) = L1 x h (Right x) = R1 x instance GFunction f => GFunction (M1 i c f) where gFunction = functionMapWith gFunction (\(M1 x) -> x) M1 instance Function a => GFunction (K1 i a) where gFunction = functionMap (\(K1 x) -> x) K1 #endif -------------------------------------------------------------------------- -- 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, Bool) (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, False) (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 (_, _, False) _) = "" show (Fun (p, d, True) _) = 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, b) f) = [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ [ Fun (p, d, True) f | not b ] -------------------------------------------------------------------------- -- the end. QuickCheck-2.9.2/Test/QuickCheck/All.hs0000644000000000000000000001726412766470776015761 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 (expName t) _ -> do integer <- [t| Integer |] ty' <- monomorphiseType err integer ty return (SigE (expName t) ty') expName :: Name -> Exp expName n = if isVar n then VarE n else ConE n -- See section 2.4 of the Haskell 2010 Language Report, plus support for "[]" isVar :: Name -> Bool isVar = let isVar' (c:_) = not (isUpper c || c `elem` ":[") isVar' _ = True in isVar' . nameBase infoType :: Info -> Type #if MIN_VERSION_template_haskell(2,11,0) infoType (ClassOpI _ ty _) = ty infoType (DataConI _ ty _) = ty infoType (VarI _ ty _) = ty #else infoType (ClassOpI _ ty _ _) = ty infoType (DataConI _ ty _ _) = ty infoType (VarI _ ty _ _) = ty #endif deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) deconstructType err ty0@(ForallT xs ctx ty) = do let plain (PlainTV _) = True #if MIN_VERSION_template_haskell(2,8,0) plain (KindedTV _ StarT) = True #else plain (KindedTV _ StarK) = True #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 MIN_VERSION_template_haskell(2,8,0) 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.9.2/Test/QuickCheck/Gen/0000755000000000000000000000000012766470776015414 5ustar0000000000000000QuickCheck-2.9.2/Test/QuickCheck/Gen/Unsafe.hs0000644000000000000000000000343312766470776017174 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.9.2/tests/0000755000000000000000000000000012766470776013114 5ustar0000000000000000QuickCheck-2.9.2/tests/GShrinkExample.hs0000644000000000000000000000046712766470776016340 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} module Main where import GHC.Generics (Generic) import Test.QuickCheck data Nat = Z | S Nat deriving (Eq, Show, Generic) instance Arbitrary Nat main :: IO () main = do print $ genericShrink (S (S Z)) == [S Z] print $ genericShrink [0::Int] == [[]] QuickCheck-2.9.2/tests/Generators.hs0000644000000000000000000001243512766470776015566 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe import Data.List import Data.Int import Data.Word import Data.Version (showVersion, parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) newtype Path a = Path [a] deriving (Show, Functor) instance Arbitrary a => Arbitrary (Path a) where arbitrary = do x <- arbitrary fmap Path (pathFrom x) where pathFrom x = sized $ \n -> fmap (x:) $ oneof $ [return []] ++ [resize (n-1) (pathFrom y) | n > 0, y <- shrink x] shrink (Path xs) = map Path [ ys | ys <- inits xs, length ys > 0 && length ys < length xs ] path :: (a -> Bool) -> Path a -> Bool path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property somePath p = expectFailure . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) instance (Arbitrary a, Bounded a) => Arbitrary (Extremal a) where arbitrary = fmap Extremal $ frequency [(1, return minBound), (1, return maxBound), (8, arbitrary)] shrink (Extremal x) = map Extremal (shrink x) smallProp :: Integral a => Path a -> Bool smallProp = path (\x -> (x >= -100 || -100 `asTypeOf` x >= 0) && x <= 100) largeProp :: Integral a => Path a -> Property largeProp = somePath (\x -> x < -1000000 || x > 1000000) prop_int :: Path Int -> Bool prop_int = smallProp prop_int32 :: Path Int32 -> Property prop_int32 = largeProp prop_word :: Path Word -> Property prop_word = largeProp prop_word32 :: Path Word32 -> Property prop_word32 = largeProp prop_integer :: Path Integer -> Bool prop_integer = smallProp prop_small :: Path (Small Int) -> Bool prop_small = smallProp prop_large :: Path (Large Int) -> Property prop_large = largeProp prop_smallWord :: Path (Small Word) -> Bool prop_smallWord = smallProp prop_largeWord :: Path (Large Word) -> Property prop_largeWord = largeProp data Choice a b = Choice a b deriving Show instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where arbitrary = do Capture eval <- capture return (Choice (eval arbitrary) (eval arbitrary)) idemProp :: (Eq a, Arbitrary a, Arbitrary b) => (b -> a) -> Choice a b -> Bool idemProp f (Choice x y) = x == f y prop_fixed_length :: Arbitrary a => Path (Fixed a) -> Bool prop_fixed_length (Path xs) = length xs == 1 prop_fixed_idem = idemProp getFixed prop_blind_idem = idemProp getBlind prop_ordered_list = path (\(Ordered xs) -> sort xs == xs) prop_nonempty_list = path (\(NonEmpty xs) -> not (null xs)) pathInt, somePathInt :: (Arbitrary (f (Extremal Int)), Show (f (Extremal Int)), Arbitrary (f Integer), Show (f Integer), Arbitrary (f (Extremal Int8)), Show (f (Extremal Int8)), Arbitrary (f (Extremal Int16)), Show (f (Extremal Int16)), Arbitrary (f (Extremal Int32)), Show (f (Extremal Int32)), Arbitrary (f (Extremal Int64)), Show (f (Extremal Int64)), Arbitrary (f (Extremal Word)), Show (f (Extremal Word)), Arbitrary (f (Extremal Word8)), Show (f (Extremal Word8)), Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)), Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)), Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) => (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property pathInt f p = conjoin [counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)), counterexample "Integer" (path ((p :: Integer -> Bool) . f)), counterexample "Int8" (path ((p :: Int8 -> Bool) . getExtremal . f)), counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)), counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)), counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)), counterexample "Word" (path ((p :: Word -> Bool) . getExtremal . f)), counterexample "Word8" (path ((p :: Word8 -> Bool) . getExtremal . f)), counterexample "Word16" (path ((p :: Word16 -> Bool) . getExtremal . f)), counterexample "Word32" (path ((p :: Word32 -> Bool) . getExtremal . f)), counterexample "Word64" (path ((p :: Word64 -> Bool) . getExtremal . f))] somePathInt f p = expectFailure (pathInt f (not . p)) prop_positive = pathInt getPositive (> 0) prop_positive_bound = somePathInt getPositive (== 1) prop_nonzero = pathInt getNonZero (/= 0) prop_nonzero_bound_1 = somePathInt getNonZero (== 1) prop_nonzero_bound_2 = somePathInt getNonZero (== -1) prop_nonnegative = pathInt getNonNegative (>= 0) prop_nonnegative_bound = somePathInt getNonNegative (== 0) reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property reachesBound x = expectFailure (x < 3 * (maxBound `div` 4)) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property prop_reachesBound_Int32 = reachesBound :: Int32 -> Property prop_reachesBound_Int64 = reachesBound :: Int64 -> Property prop_reachesBound_Word = reachesBound :: Word -> Property prop_reachesBound_Word8 = reachesBound :: Word8 -> Property prop_reachesBound_Word16 = reachesBound :: Word16 -> Property prop_reachesBound_Word32 = reachesBound :: Word32 -> Property prop_reachesBound_Word64 = reachesBound :: Word64 -> Property return [] main = $quickCheckAll >>= print QuickCheck-2.9.2/tests/GCoArbitraryExample.hs0000644000000000000000000000072112766470776017314 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} module Main where import GHC.Generics (Generic) import Test.QuickCheck import Test.QuickCheck.Function data D a = C1 a | C2 deriving (Eq, Show, Read, Generic) instance Arbitrary a => Arbitrary (D a) instance CoArbitrary a => CoArbitrary (D a) instance (Show a, Read a) => Function (D a) where function = functionShow main :: IO () main = quickCheck $ \(Fun _ f) -> f (C1 (2::Int)) `elem` [0, 1 :: Int] QuickCheck-2.9.2/examples/0000755000000000000000000000000012766470776013570 5ustar0000000000000000QuickCheck-2.9.2/examples/Heap.hs0000644000000000000000000001006712766470776015005 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 -}