QuickCheck-2.13.2/0000755000000000000000000000000013506212053011774 5ustar0000000000000000QuickCheck-2.13.2/LICENSE0000644000000000000000000000310013506212053012773 0ustar0000000000000000(The following is the 3-clause BSD license.) Copyright (c) 2000-2019, Koen Claessen Copyright (c) 2006-2008, Björn Bringert Copyright (c) 2009-2019, Nick Smallbone 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.13.2/Setup.lhs0000644000000000000000000000015713506212053013607 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain QuickCheck-2.13.2/QuickCheck.cabal0000644000000000000000000001545013506212053014777 0ustar0000000000000000Name: QuickCheck Version: 2.13.2 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Copyright: 2000-2019 Koen Claessen, 2006-2008 Björn Bringert, 2009-2019 Nick Smallbone Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues Tested-with: GHC >= 7.0 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs Description: QuickCheck is a library for random testing of program properties. The programmer provides a specification of the program, in the form of properties which functions should satisfy, and QuickCheck then tests that the properties hold in a large number of randomly generated cases. Specifications are expressed in Haskell, using combinators provided by QuickCheck. QuickCheck provides combinators to define properties, observe the distribution of test data, and define test data generators. . Most of QuickCheck's functionality is exported by the main "Test.QuickCheck" module. The main exception is the monadic property testing library in "Test.QuickCheck.Monadic". . If you are new to QuickCheck, you can try looking at the following resources: . * The . It's a bit out-of-date in some details and doesn't cover newer QuickCheck features, but is still full of good advice. * , a detailed tutorial written by a user of QuickCheck. . The companion package provides instances for types in Haskell Platform packages at the cost of additional dependencies. extra-source-files: README changelog examples/Heap.hs examples/Heap_Program.hs examples/Heap_ProgramAlgebraic.hs examples/Lambda.hs examples/Merge.hs examples/Set.hs examples/Simple.hs make-hugs source-repository head type: git location: https://github.com/nick8325/quickcheck source-repository this type: git location: https://github.com/nick8325/quickcheck tag: 2.13.2 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True library Build-depends: base >=4.3 && <5, random >=1.0.0.3 && <1.2, containers -- random is explicitly Trustworthy since 1.0.1.0 -- similar constraint for containers -- Note: QuickCheck is Safe only with GHC >= 7.4 (see below) if impl(ghc >= 7.2) Build-depends: random >=1.0.1.0 if impl(ghc >= 7.4) Build-depends: containers >=0.4.2.1 -- 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, Test.QuickCheck.Features -- GHC-specific modules. if impl(ghc) Exposed-Modules: Test.QuickCheck.Function Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 else cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ 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 if !impl(ghc >= 7.4) cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -- The new generics appeared in GHC 7.2... if impl(ghc < 7.2) 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 splitmix on newer GHCs. if impl(ghc >= 7.0) Build-depends: splitmix >= 0.0.2 else cpp-options: -DNO_SPLITMIX if !impl(ghc >= 7.6) cpp-options: -DNO_POLYKINDS if !impl(ghc >= 8.0) cpp-options: -DNO_MONADFAIL -- 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 -DNO_TYPEABLE -DNO_GADTS 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, QuickCheck if !flag(templateHaskell) Buildable: False Test-Suite test-quickcheck-gcoarbitrary type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck if !flag(templateHaskell) || !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 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 if !flag(templateHaskell) || !impl(ghc >= 7.2) buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Terminal.hs build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck if !flag(templateHaskell) || !impl(ghc >= 7.10) buildable: False Test-Suite test-quickcheck-monadfix type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: MonadFix.hs build-depends: base, QuickCheck if !flag(templateHaskell) || !impl(ghc >= 7.10) buildable: False Test-Suite test-quickcheck-split type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Split.hs build-depends: base, QuickCheck Test-Suite test-quickcheck-misc type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Misc.hs build-depends: base, QuickCheck if !flag(templateHaskell) || !impl(ghc >= 7.10) buildable: False QuickCheck-2.13.2/README0000644000000000000000000000070713506212053012660 0ustar0000000000000000This is QuickCheck 2, a library for random testing of program properties. Install it in the usual way: $ cabal install The quickcheck-instances [1] companion package provides instances for types in Haskell Platform packages at the cost of additional dependencies. The make-hugs script makes a Hugs-compatible version of QuickCheck. It may also be useful for other non-GHC implementations. [1]: http://hackage.haskell.org/package/quickcheck-instances QuickCheck-2.13.2/changelog0000644000000000000000000003307213506212053013653 0ustar0000000000000000QuickCheck 2.13.2 (released 2019-06-30) * Compatibility with GHC 8.8 (thanks to Bodigrim) * Improve error message when 'frequency' is used with only zero weights * Add 'functionVoid' combinator (thanks to Oleg Grenrus) * Tighten bounds for random package (thanks to Oleg Grenrus) QuickCheck 2.13.1 (released 2019-03-29) * A couple of bug fixes QuickCheck 2.13 (released 2019-03-26) * Properties with multiple arguments now shrink better. Previously, the first argument was shrunk, then the second, and so on. Now, the arguments are shrunk as a whole, so shrink steps for different arguments can be interleaved. * New features: - New modifiers Negative and NonPositive - A Testable instance for Maybe prop (where Nothing means 'discard the test case') * Dependencies on C code removed: - Use splitmix instead of tf-random for random number generation - Remove dependency on 'erf' package * Small changes: - Say 'Falsified' instead of 'Falsifiable' when a property fails * Compatibility improvements: - Explicitly derive instance Typeable Args - Lower bound on deepseq - A script for building Hugs packages QuickCheck 2.12.6 (released 2018-10-02) * Make arbitrarySizedBoundedIntegral handle huge sizes correctly. * Add changelog for QuickCheck 2.12.5 :) QuickCheck 2.12.5 (released 2018-09-30) * Export isSuccess from Test.QuickCheck. * Export CoArbitrary even when generics are disabled (bugfix). * Fix bug in shrinkDecimal. * Include Test.QuickCheck.Gen in exposed modules for Haddock. QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) * Shrinking for Float and Decimal now works by reducing the number of digits in the number. The new function shrinkDecimal implements this shrinking behaviour. * Shrinking for Rational now tries to make the numerator and denominator of the number smaller. Previously it tried to reduce the magnitude of the number. QuickCheck 2.12.2 (released 2018-09-10) * Fix infinite shrinking loop for fractional types. * Add SortedList modifier. QuickCheck 2.12.1 (released 2018-09-06) * Fix bug in 'classify'. QuickCheck 2.12 (released 2018-09-03) * Silently breaking changes! - The Arbitrary instance for Word now generates only small values, the same as Int - cover no longer causes a property failure if coverage is insufficient. It just prints a warning. (But see next item!) * Overhaul of label/cover family of combinators: - New property combinator checkCoverage, which checks coverage requirements in a statistically sound way, and *does* fail if they are not met. - Order of arguments to cover swapped, to make it easier to switch between classify and cover - New combinators tabulate and coverTable, for reporting test case distribution more flexibly than label. - When label is called multiple times in a property, each call produces a separate table of frequencies. * New functions: - (=/=): like (/=), but prints a counterexample (thanks to tom-bop) - forAllShow/forAllShrinkShow: quantification using an explicit show function (thanks to Stevan Andjelkovic) - forAllBlind/forAllShrinkBlind: quantification without printing anything - verboseShrinking: see how a counterexample is shrunk - labelledExamples: given a property which uses label, generate an example test case for each label - idempotentIOProperty: a variant of ioProperty which shrinks better but only works for idempotent I/O actions * Other improvements: - MonadFix Gen instance (thanks to Jon Fowler) - Rational numbers shrink using continued fractions (thanks to Justus Sagemüller) - Function instances for Const, Identity, and the types in Data.Monoid; instance Functor Fun (thanks to Erik Schnetter and Xia Li-yao) - More of Test.QuickCheck.Function is exported from Test.QuickCheck - Semantics of .||. changed to improve short-circuiting: if the left argument's precondition is false, the right argument is not evaluated and the whole disjunction is considered to have a false precondition - Bug fix: suchThatMaybe always increased size to at least 1 * Miscellaneous API changes: - Result type has changed a bit: - InsufficientCovered constructor is gone - Type of labels has changed - New fields classes, tables QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) * Cosmetic fixes. QuickCheck 2.11 (released 2018-01-12) * New features: - InfiniteList modifier generates infinite lists and shows only the relevant part. - applyArbitrary2/3/4 for applying a function to random arguments. - Template Haskell function allProperties returns all properties in a module. * Applicative Gen instances do less splitting. * Property now has a Typeable instance. * (===) now prints correct output when the property is true. * Test.QuickCheck now exports Fun constructor. * verboseCheck output is now slightly less confusing. QuickCheck 2.10.1 (released 2017-10-06) * Arbitrary instances for Foreign.C.Types are available in more GHC versions. * Fixed a bug where withMaxSuccess didn't adjust the allowed number of discarded tests. * Remove quadratic behaviour in terminal output. QuickCheck 2.10 (released 2017-06-15) * New combinators: - withMaxSuccess sets the maximum number of test cases for a property. - shrinkMap/shrinkMapBy are helpers for defining shrink functions. - total checks that a value is non-crashing. - suchThatMap is similar to 'suchThat' but takes a Maybe-returning function instead of a predicate. - getSize returns the current test case size. * Random strings and characters now include Unicode characters by default. To generate only ASCII characters, use the new ASCIIString modifier or arbitraryASCIIChar generator. The following modifiers and generators also control the kind of strings generated: UnicodeString, PrintableString, arbitraryUnicodeChar, arbitraryPrintableChar. * QuickCheck no longer catches asynchronous exceptions, which means that pressing ctrl-C will now cancel testing without printing a counterexample. If you are debugging an infinite loop, please use the 'within' combinator or 'verboseCheck' instead. ('within' is better as it allows the counterexample to be shrunk.) * Much of Test.QuickCheck.Function (showable random functions) is now exported from Test.QuickCheck. - Test.QuickCheck.Function now defines functions and pattern synonyms which simplify testing functions of more than one argument: apply2, apply3, Fn2, Fn3. * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary to unary/binary type constructors, like in Data.Functor.Classes. * Some Arbitrary instances have been removed: NonEmpty, Natural. This is because they resulted in a lot of extra dependencies. You can now find them in the quickcheck-instances package. Alternatively, use the NonEmptyList and NonNegative modifiers. * New Arbitrary instances for the following types: Proxy, ExitCode, WrappedMonad, WrappedArrow, QCGen, and the types in Foreign.C.Types and Data.Functor.{Product,Compose}. Also a Function instance for Word. * The functions in Test.QuickCheck.Monadic which take an argument of type PropertyM m a now expect that 'a' to be Testable, and test it. To reduce breakage from this, () is now an instance of Testable which always succeeds. - PropertyM now has a MonadFail instance on recent GHCs. Furthermore, the constraints on some instances were loosened. * Miscellaneous API changes: - Result now returns the counterexample as a list of strings. See the "failingTestCase" field. - Args now has a `maxShrinks` argument, the maximum number of shrinks to try before giving up shrinking. - The 'labels' field of Result now encodes frequencies as Doubles rather than Ints. * Bugfixes: - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and 'Test.QuickCheck.Monadic' are now Safe modules. - Result.theException and Result.reason were taken from the pre-shrunk counterexample, not the shrunk one. - The Testable Property instance improperly used 'again'. - Gen.>>= is strict in the result of split, fixing a space leak. - within now gives a better error message on timeout * Some more examples and links have been added to the documentation. QuickCheck 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.13.2/make-hugs0000755000000000000000000000131413506212053013602 0ustar0000000000000000#!/bin/bash cd $(dirname $0) for i in $(find Test -name '*.hs'); do mkdir -p quickcheck-hugs/$(dirname $i) # If you want to switch on and off other features, look in # QuickCheck.cabal to see what's available, or submit a patch # adding a new -DNO_... flag. cpphs --noline -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \ -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \ -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \ -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \ -DNO_DEEPSEQ \ $i > quickcheck-hugs/$i done echo "A Hugs-compatible version of QuickCheck is now" echo "available in the quickcheck-hugs directory." echo "Load it with hugs -98." QuickCheck-2.13.2/Test/0000755000000000000000000000000013506212053012713 5ustar0000000000000000QuickCheck-2.13.2/Test/QuickCheck.hs0000644000000000000000000001726513506212053015274 0ustar0000000000000000{-| The gives detailed information about using QuickCheck effectively. You can also try , a tutorial written by a user of QuickCheck. To start using QuickCheck, write down your property as a function returning @Bool@. For example, to check that reversing a list twice gives back the same list you can write: @ import Test.QuickCheck prop_reverse :: [Int] -> Bool prop_reverse xs = reverse (reverse xs) == xs @ You can then use QuickCheck to test @prop_reverse@ on 100 random lists: >>> quickCheck prop_reverse +++ OK, passed 100 tests. To run more tests you can use the 'withMaxSuccess' combinator: >>> quickCheck (withMaxSuccess 10000 prop_reverse) +++ OK, passed 10000 tests. To use QuickCheck on your own data types you will need to write 'Arbitrary' instances for those types. See the for details about how to do that. -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif module Test.QuickCheck ( -- * Running tests quickCheck , Args(..), Result(..) , stdArgs , quickCheckWith , quickCheckWithResult , quickCheckResult , isSuccess -- ** Running tests verbosely , verboseCheck , verboseCheckWith , verboseCheckWithResult , verboseCheckResult #ifndef NO_TEMPLATE_HASKELL -- ** Testing all properties in a module -- | These functions test all properties in the current module, using -- Template Haskell. You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ -- pragma in your module for any of these to work. , quickCheckAll , verboseCheckAll , forAllProperties , allProperties -- ** Testing polymorphic properties , polyQuickCheck , polyVerboseCheck , monomorphic #endif -- * The 'Arbitrary' typeclass: generation of random values , Arbitrary(..) -- ** Helper functions for implementing 'shrink' #ifndef NO_GENERICS , genericShrink , subterms , recursivelyShrink #endif , shrinkNothing , shrinkList , shrinkMap , shrinkMapBy , shrinkIntegral , shrinkRealFrac , shrinkDecimal -- ** Lifting of 'Arbitrary' to unary and binary type constructors , Arbitrary1(..) , arbitrary1 , shrink1 , Arbitrary2(..) , arbitrary2 , shrink2 -- * The 'Gen' monad: combinators for building random generators , Gen -- ** Generator combinators , choose , oneof , frequency , elements , growingElements , sized , getSize , resize , scale , suchThat , suchThatMap , suchThatMaybe , applyArbitrary2 , applyArbitrary3 , applyArbitrary4 -- ** Generators for lists , listOf , listOf1 , vectorOf , vector , infiniteListOf , infiniteList , shuffle , sublistOf , orderedList -- ** Generators for particular types , arbitrarySizedIntegral , arbitrarySizedNatural , arbitrarySizedFractional , arbitrarySizedBoundedIntegral , arbitraryBoundedIntegral , arbitraryBoundedRandom , arbitraryBoundedEnum , arbitraryUnicodeChar , arbitraryASCIIChar , arbitraryPrintableChar -- ** Running generators , generate -- ** Debugging generators , sample , sample' #ifndef NO_GADTS -- * The 'Function' typeclass: generation of random shrinkable, showable functions -- | Example of use: -- -- >>> :{ -- >>> let prop :: Fun String Integer -> Bool -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" -- >>> :} -- >>> quickCheck prop -- *** Failed! Falsified (after 3 tests and 134 shrinks): -- {"elephant"->1, "monkey"->1, _->0} -- -- To generate random values of type @'Fun' a b@, -- you must have an instance @'Function' a@. -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. -- See the @'Function' [a]@ instance for an example of the latter. -- -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. , Fun (..) , applyFun , applyFun2 , applyFun3 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 , pattern Fn , pattern Fn2 , pattern Fn3 #endif , Function (..) , functionMap , functionShow , functionIntegral , functionRealFrac , functionBoundedEnum , functionVoid #endif -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way , CoArbitrary(..) #ifndef NO_GENERICS , genericCoarbitrary #endif , variant , coarbitraryIntegral , coarbitraryReal , coarbitraryShow , coarbitraryEnum , (><) -- * Type-level modifiers for changing generator behavior -- | These types do things such as restricting the kind of test data that can be generated. -- They can be pattern-matched on in properties as a stylistic -- alternative to using explicit quantification. -- -- Examples: -- -- @ -- -- Functions cannot be shown (but see 'Function') -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ -- -- Instead of 'forAll' 'orderedList' -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = -- sort xs == xs -- @ , Blind(..) , Fixed(..) , OrderedList(..) , NonEmptyList(..) , InfiniteList(..) , SortedList(..) , Positive(..) , Negative(..) , NonZero(..) , NonNegative(..) , NonPositive(..) , Large(..) , Small(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) #endif , ASCIIString(..) , UnicodeString(..) , PrintableString(..) -- * Property combinators , Property, Testable(..) , forAll , forAllShrink , forAllShow , forAllShrinkShow , forAllBlind , forAllShrinkBlind , shrinking , (==>) , Discard(..) , discard , (===) , (=/=) #ifndef NO_DEEPSEQ , total #endif , ioProperty , idempotentIOProperty -- ** Controlling property execution , verbose , verboseShrinking , noShrinking , withMaxSuccess , within , once , again , mapSize -- ** Conjunction and disjunction , (.&.) , (.&&.) , conjoin , (.||.) , disjoin -- ** What to do on failure , counterexample , printTestCase , whenFail , whenFail' , expectFailure -- * Analysing test case distribution , label , collect , classify , tabulate -- ** Checking test case distribution , cover , coverTable , checkCoverage , checkCoverageWith , Confidence(..) , stdConfidence -- ** Generating example test cases , labelledExamples , labelledExamplesWith , labelledExamplesWithResult , labelledExamplesResult ) 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.Exception #ifndef NO_GADTS import Test.QuickCheck.Function #endif import Test.QuickCheck.Features import Test.QuickCheck.State #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/0000755000000000000000000000000013506212053014725 5ustar0000000000000000QuickCheck-2.13.2/Test/QuickCheck/Arbitrary.hs0000644000000000000000000013443113506212053017226 0ustar0000000000000000-- | Type classes for random generation of values. -- -- __Note__: the contents of this module are re-exported by -- "Test.QuickCheck". You do not need to import it directly. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} {-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPING_ #endif #endif #ifndef NO_POLYKINDS {-# LANGUAGE PolyKinds #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes Arbitrary(..) , CoArbitrary(..) -- ** Unary and Binary classes , Arbitrary1(..) , arbitrary1 , shrink1 , Arbitrary2(..) , arbitrary2 , shrink2 -- ** Helper functions for implementing arbitrary , applyArbitrary2 , applyArbitrary3 , applyArbitrary4 , 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 -- ** Generators for various kinds of character , arbitraryUnicodeChar -- :: Gen Char , arbitraryASCIIChar -- :: Gen Char , arbitraryPrintableChar -- :: Gen Char -- ** 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]] , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] , shrinkIntegral -- :: Integral a => a -> [a] , shrinkRealFrac -- :: RealFrac a => a -> [a] , shrinkDecimal -- :: 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.Random import Test.QuickCheck.Gen.Unsafe {- import Data.Generics ( (:*:)(..) , (:+:)(..) , Unit(..) ) -} import Data.Char ( ord , isLower , isUpper , toLower , isDigit , isSpace , isPrint , generalCategory , GeneralCategory(..) ) #ifndef NO_FIXED import Data.Fixed ( Fixed , HasResolution ) #endif import Data.Ratio ( Ratio , (%) , numerator , denominator ) import Data.Complex ( Complex((:+)) ) import Data.List ( sort , nub ) 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) import System.Exit (ExitCode(..)) import Foreign.C.Types #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 import Data.Functor.Compose import Data.Functor.Product #endif -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. -- -- QuickCheck provides @Arbitrary@ instances for most types in @base@, -- except those which incur extra dependencies. -- For a wider range of @Arbitrary@ instances see the -- -- package. class Arbitrary a where -- | A generator for values of the given type. -- -- It is worth spending time thinking about what sort of test data -- you want - good generators are often the difference between -- finding bugs and not finding them. You can use 'sample', -- 'label' and 'classify' to check the quality of your test data. -- -- There is no generic @arbitrary@ implementation included because we don't -- know how to make a high-quality one. If you want one, consider using the -- or -- packages. -- -- The -- goes into detail on how to write good generators. Make sure to look at it, -- especially if your type is recursive! 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. If your data type has no special invariants, you can -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising -- the behaviour of @shrink@ you can often get simpler counterexamples. -- -- Most implementations of 'shrink' should try at least three things: -- -- 1. Shrink a term to any of its immediate subterms. -- You can use 'subterms' to do this. -- -- 2. Recursively apply 'shrink' to all immediate subterms. -- You can use 'recursivelyShrink' to do this. -- -- 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. -- 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 _ = [] -- | Lifting of the 'Arbitrary' class to unary type constructors. class Arbitrary1 f where liftArbitrary :: Gen a -> Gen (f a) liftShrink :: (a -> [a]) -> f a -> [f a] liftShrink _ _ = [] arbitrary1 :: (Arbitrary1 f, Arbitrary a) => Gen (f a) arbitrary1 = liftArbitrary arbitrary shrink1 :: (Arbitrary1 f, Arbitrary a) => f a -> [f a] shrink1 = liftShrink shrink -- | Lifting of the 'Arbitrary' class to binary type constructors. class Arbitrary2 f where liftArbitrary2 :: Gen a -> Gen b -> Gen (f a b) liftShrink2 :: (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] liftShrink2 _ _ _ = [] arbitrary2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => Gen (f a b) arbitrary2 = liftArbitrary2 arbitrary arbitrary shrink2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => f a b -> [f a b] shrink2 = liftShrink2 shrink 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) => Arbitrary1 ((->) a) where liftArbitrary arbB = promote (`coarbitrary` arbB) instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where arbitrary = arbitrary1 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 Arbitrary1 Maybe where liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] liftShrink _ Nothing = [] instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary2 Either where liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] instance Arbitrary a => Arbitrary1 (Either a) where liftArbitrary = liftArbitrary2 arbitrary liftShrink = liftShrink2 shrink instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = arbitrary2 shrink = shrink2 instance Arbitrary1 [] where liftArbitrary = listOf liftShrink = shrinkList instance Arbitrary a => Arbitrary [a] where arbitrary = arbitrary1 shrink = shrink1 -- | 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 = shrinkDecimal #endif instance Arbitrary2 (,) where liftArbitrary2 = liftM2 (,) liftShrink2 shrA shrB (x, y) = [ (x', y) | x' <- shrA x ] ++ [ (x, y') | y' <- shrB y ] instance (Arbitrary a) => Arbitrary1 ((,) a) where liftArbitrary = liftArbitrary2 arbitrary liftShrink = liftShrink2 shrink instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where arbitrary = arbitrary2 shrink = shrink2 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 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 = arbitrarySizedIntegral 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 = frequency [(3, arbitraryASCIIChar), (1, arbitraryUnicodeChar)] 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 = shrinkDecimal instance Arbitrary Double where arbitrary = arbitrarySizedFractional shrink = shrinkDecimal instance Arbitrary CChar where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CSChar where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CUChar where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CShort where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CUShort where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CInt where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CUInt where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CLong where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CULong where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CPtrdiff where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CSize where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CWchar where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CSigAtomic where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CLLong where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CULLong where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CIntPtr where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CUIntPtr where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CIntMax where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary CUIntMax where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral #ifndef NO_CTYPES_CONSTRUCTORS -- The following four types have no Bounded instance, -- so we fake it by discovering the bounds at runtime. instance Arbitrary CClock where arbitrary = fmap CClock arbitrary shrink (CClock x) = map CClock (shrink x) instance Arbitrary CTime where arbitrary = fmap CTime arbitrary shrink (CTime x) = map CTime (shrink x) #ifndef NO_FOREIGN_C_USECONDS instance Arbitrary CUSeconds where arbitrary = fmap CUSeconds arbitrary shrink (CUSeconds x) = map CUSeconds (shrink x) instance Arbitrary CSUSeconds where arbitrary = fmap CSUSeconds arbitrary shrink (CSUSeconds x) = map CSUSeconds (shrink x) #endif #endif instance Arbitrary CFloat where arbitrary = arbitrarySizedFractional shrink = shrinkDecimal instance Arbitrary CDouble where arbitrary = arbitrarySizedFractional shrink = shrinkDecimal -- 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) => Arbitrary1 (Map.Map k) where liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary shrink = map IntSet.fromList . shrink . IntSet.toList instance Arbitrary1 IntMap.IntMap where liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList instance Arbitrary a => Arbitrary (IntMap.IntMap a) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary1 Sequence.Seq where liftArbitrary = fmap Sequence.fromList . liftArbitrary liftShrink shr = map Sequence.fromList . liftShrink shr . toList instance Arbitrary a => Arbitrary (Sequence.Seq a) where arbitrary = arbitrary1 shrink = shrink1 -- Arbitrary instance for Ziplist instance Arbitrary1 ZipList where liftArbitrary = fmap ZipList . liftArbitrary liftShrink shr = map ZipList . liftShrink shr . getZipList instance Arbitrary a => Arbitrary (ZipList a) where arbitrary = arbitrary1 shrink = shrink1 #ifndef NO_TRANSFORMERS -- Arbitrary instance for transformers' Functors instance Arbitrary1 Identity where liftArbitrary = fmap Identity liftShrink shr = map Identity . shr . runIdentity instance Arbitrary a => Arbitrary (Identity a) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary2 Constant where liftArbitrary2 arbA _ = fmap Constant arbA liftShrink2 shrA _ = fmap Constant . shrA . getConstant instance Arbitrary a => Arbitrary1 (Constant a) where liftArbitrary = liftArbitrary2 arbitrary liftShrink = liftShrink2 shrink -- Have to be defined explicitly, as Constant is kind polymorphic instance Arbitrary a => Arbitrary (Constant a b) where arbitrary = fmap Constant arbitrary shrink = map Constant . shrink . getConstant instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) liftShrink shr (Pair f g) = [ Pair f' g | f' <- liftShrink shr f ] ++ [ Pair f g' | g' <- liftShrink shr g ] instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where arbitrary = arbitrary1 shrink = shrink1 instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where arbitrary = arbitrary1 shrink = shrink1 #endif -- Arbitrary instance for Const instance Arbitrary2 Const where liftArbitrary2 arbA _ = fmap Const arbA liftShrink2 shrA _ = fmap Const . shrA . getConst instance Arbitrary a => Arbitrary1 (Const a) where liftArbitrary = liftArbitrary2 arbitrary liftShrink = liftShrink2 shrink -- Have to be defined explicitly, as Const is kind polymorphic instance Arbitrary a => Arbitrary (Const a b) where arbitrary = fmap Const arbitrary shrink = map Const . shrink . getConst instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where arbitrary = WrapMonad <$> arbitrary shrink (WrapMonad a) = map WrapMonad (shrink a) instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where arbitrary = WrapArrow <$> arbitrary shrink (WrapArrow a) = map WrapArrow (shrink a) -- 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' ] instance Arbitrary QCGen where arbitrary = MkGen (\g _ -> g) instance Arbitrary ExitCode where arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] shrink _ = [] -- ** Helper functions for implementing arbitrary -- | Apply a binary function to random arguments. applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r applyArbitrary2 f = liftA2 f arbitrary arbitrary -- | Apply a ternary function to random arguments. applyArbitrary3 :: (Arbitrary a, Arbitrary b, Arbitrary c) => (a -> b -> c -> r) -> Gen r applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary -- | Apply a function of arity 4 to random arguments. applyArbitrary4 :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => (a -> b -> c -> d -> r) -> Gen r applyArbitrary4 f = applyArbitrary3 (uncurry f) -- | 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 b <- choose (1, precision) a <- choose ((-n') * b, n' * b) 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 = (toInteger s*(bits mn `max` bits mx `max` 40) `div` 80) -- computes x `min` (2^k), but avoids computing 2^k -- if it is too large x `minexp` k | bits x < k = x | otherwise = x `min` (2^k) -- x `max` (-2^k) x `maxexpneg` k = -((-x) `minexp` k) n <- choose (toInteger mn `maxexpneg` k, toInteger mx `minexp` k) return (fromInteger n) -- ** Generators for various kinds of character -- | Generates any Unicode character (but not a surrogate) arbitraryUnicodeChar :: Gen Char arbitraryUnicodeChar = arbitraryBoundedEnum `suchThat` (not . isSurrogate) where isSurrogate c = generalCategory c == Surrogate -- | Generates a random ASCII character (0-127). arbitraryASCIIChar :: Gen Char arbitraryASCIIChar = choose ('\0', '\127') -- | Generates a printable Unicode character. arbitraryPrintableChar :: Gen Char arbitraryPrintableChar = arbitrary `suchThat` isPrint -- ** Helper functions for implementing shrink -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] -- | Map a shrink function to another domain. This is handy if your data type -- has special invariants, but is /almost/ isomorphic to some other type. -- -- @ -- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] -- shrinkOrderedList = shrinkMap sort id -- -- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] -- shrinkSet = shrinkMap fromList toList -- @ shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] shrinkMap f g = shrinkMapBy f g shrink -- | Non-overloaded version of `shrinkMap`. shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] shrinkMapBy f g shr = map f . shr . g -- | 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, preferring numbers with smaller -- numerators or denominators. See also 'shrinkDecimal'. shrinkRealFrac :: RealFrac a => a -> [a] shrinkRealFrac x | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN | not (2*x+1>x) = 0 : takeWhile ( abs y < abs x) $ -- Try shrinking to an integer first map fromInteger (shrink (truncate x) ++ [truncate x]) ++ -- Shrink the numerator [fromRational (num' % denom) | num' <- shrink num] ++ -- Shrink the denominator, and keep the fraction as close -- to the original as possible, rounding towards zero [fromRational (truncate (num * denom' % denom) % denom') | denom' <- shrink denom, denom' /= 0 ] where num = numerator (toRational x) denom = denominator (toRational x) -- | Shrink a real number, preferring numbers with shorter -- decimal representations. See also 'shrinkRealFrac'. shrinkDecimal :: RealFrac a => a -> [a] shrinkDecimal x | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN | not (2*x+1>x) = 0 : takeWhile ( instance CoArbitrary MyType -- -- You should only use 'genericCoarbitrary' for data types where -- equality is structural, i.e. if you can't have two different -- representations of the same value. An example where it's not -- safe is sets implemented using binary search trees: the same -- set can be represented as several different trees. -- Here you would have to explicitly define -- @coarbitrary s = coarbitrary (toList s)@. #else -- | Used for random generation of functions. #endif class CoArbitrary a where -- | Used to generate a function of type @a -> b@. -- The first argument is a value, the second a generator. -- You should use 'variant' to perturb the random generator; -- the goal is that different values for the first argument will -- lead to different calls to 'variant'. An example will help: -- -- @ -- instance CoArbitrary a => CoArbitrary [a] where -- coarbitrary [] = 'variant' 0 -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) -- @ coarbitrary :: a -> Gen b -> Gen b #ifndef NO_GENERICS default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b coarbitrary = genericCoarbitrary -- | Generic CoArbitrary implementation. genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b genericCoarbitrary = gCoarbitrary . from class GCoArbitrary f where gCoarbitrary :: f a -> Gen b -> Gen b instance GCoArbitrary U1 where gCoarbitrary U1 = id instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where -- Like the instance for tuples. gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where -- Like the instance for Either. gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x instance GCoArbitrary f => GCoArbitrary (M1 i c f) where gCoarbitrary (M1 x) = gCoarbitrary x instance CoArbitrary a => GCoArbitrary (K1 i a) where gCoarbitrary (K1 x) = coarbitrary x #endif {-# DEPRECATED (><) "Use ordinary function composition instead" #-} -- | Combine two generator perturbing functions, for example the -- results of calls to 'variant' or 'coarbitrary'. (><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) (><) = (.) instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where coarbitrary f gen = do xs <- arbitrary coarbitrary (map f xs) gen instance CoArbitrary () where coarbitrary _ = id instance CoArbitrary Bool where coarbitrary False = variant 0 coarbitrary True = variant 1 instance CoArbitrary Ordering where coarbitrary GT = variant 0 coarbitrary EQ = variant 1 coarbitrary LT = variant 2 instance CoArbitrary a => CoArbitrary (Maybe a) where coarbitrary Nothing = variant 0 coarbitrary (Just x) = variant 1 . coarbitrary x instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where coarbitrary (Left x) = variant 0 . coarbitrary x coarbitrary (Right y) = variant 1 . coarbitrary y instance CoArbitrary a => CoArbitrary [a] where coarbitrary [] = variant 0 coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where coarbitrary r = coarbitrary (numerator r,denominator r) #ifndef NO_FIXED instance HasResolution a => CoArbitrary (Fixed a) where coarbitrary = coarbitraryReal #endif instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where coarbitrary (x :+ y) = coarbitrary x . coarbitrary y instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a,b) where coarbitrary (x,y) = coarbitrary x . coarbitrary y instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a,b,c) where coarbitrary (x,y,z) = coarbitrary x . coarbitrary y . coarbitrary z instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a,b,c,d) where coarbitrary (x,y,z,v) = coarbitrary x . coarbitrary y . coarbitrary z . coarbitrary v instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) => CoArbitrary (a,b,c,d,e) where coarbitrary (x,y,z,v,w) = coarbitrary x . coarbitrary y . coarbitrary z . coarbitrary v . coarbitrary w -- typical instance for primitive (numerical) types instance CoArbitrary Integer where coarbitrary = coarbitraryIntegral 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 -- | Generates an infinite list. infiniteList :: Arbitrary a => Gen [a] infiniteList = infiniteListOf arbitrary -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/Gen.hs0000644000000000000000000001742613506212053016004 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif -- | Test case generation. -- -- __Note__: the contents of this module (except for the definition of -- 'Gen') are re-exported by "Test.QuickCheck". You probably do not -- need to import it directly. module Test.QuickCheck.Gen where -------------------------------------------------------------------------- -- imports import System.Random ( Random , random , randomR , split ) import Control.Monad ( ap , replicateM , filterM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Applicative ( Applicative(..) ) import Test.QuickCheck.Random import Data.List import Data.Ord import Data.Maybe -------------------------------------------------------------------------- -- ** Generator type -- | A generator for values of type @a@. -- -- The third-party packages -- -- and -- -- provide monad transformer versions of @Gen@. 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 gf <*> gx = gf >>= \f -> fmap f gx instance Monad Gen where return x = MkGen (\_ _ -> x) MkGen m >>= k = MkGen (\r n -> case split r of (r1, r2) -> let MkGen m' = k (m r1 n) in m' r2 n ) instance MonadFix Gen where mfix f = MkGen $ \r n -> let a = unGen (f a) r n in a -------------------------------------------------------------------------- -- ** Primitive generator combinators -- | Modifies a generator using an integer seed. variant :: Integral n => n -> Gen a -> Gen a variant k (MkGen g) = MkGen (\r n -> g (integerVariant (toInteger k) $! r) n) -- | Used to construct generators that depend on the size parameter. -- -- For example, 'listOf', which uses the size parameter as an upper bound on -- length of lists it generates, can be defined like this: -- -- > listOf :: Gen a -> Gen [a] -- > listOf gen = sized $ \n -> -- > do k <- choose (0,n) -- > vectorOf k gen -- -- You can also do this using 'getSize'. sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) -- | Returns the size parameter. Used to construct generators that depend on -- the size parameter. -- -- For example, 'listOf', which uses the size parameter as an upper bound on -- length of lists it generates, can be defined like this: -- -- > listOf :: Gen a -> Gen [a] -- > listOf gen = do -- > n <- getSize -- > k <- choose (0,n) -- > vectorOf k gen -- -- You can also do this using 'sized'. getSize :: Gen Int getSize = sized pure -- | 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)) -- | Generates a value for which the given function returns a 'Just', and then -- applies the function. suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b gen `suchThatMap` f = fmap fromJust $ fmap f gen `suchThat` isJust -- | Tries to generate a value that satisfies a predicate. -- If it fails to do so after enough attempts, returns @Nothing@. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) gen `suchThatMaybe` p = sized (\n -> try n (2*n)) where try m n | m > n = return Nothing | otherwise = do x <- resize m gen if p x then return (Just x) else try (m+1) n -- | Randomly uses one of the given generators. The input list -- must be non-empty. 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 xs | any (< 0) (map fst xs) = error "QuickCheck.frequency: negative weight" | all (== 0) (map fst xs) = error "QuickCheck.frequency: all weights were zero" 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.13.2/Test/QuickCheck/Monadic.hs0000644000000000000000000001611213506212053016634 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL #if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) {-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Safe #-} #endif #endif #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 #ifndef NO_MONADFAIL import qualified Control.Monad.Fail as Fail #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) } bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) fail_ :: Monad m => String -> PropertyM m a fail_ s = stop (failed { reason = s }) instance Functor (PropertyM m) where fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) instance Applicative (PropertyM m) where pure x = MkPropertyM (\k -> k x) mf <*> mx = mf `bind` \f -> mx `bind` \x -> pure (f x) instance Monad m => Monad (PropertyM m) where return = pure (>>=) = bind #if !MIN_VERSION_base(4,13,0) fail = fail_ #endif #ifndef NO_MONADFAIL instance Monad m => Fail.MonadFail (PropertyM m) where fail = fail_ #endif #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'. -- __Note__: values generated by 'pick' do not shrink. pick :: (Monad m, Show a) => Gen a -> PropertyM m a pick gen = MkPropertyM $ \k -> do a <- gen 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 -- | Quantification in monadic properties to 'pick', with a notation similar to -- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k -- | 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 :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property monadic runner m = property (fmap runner (monadic' m)) monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) -- | 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 :: Testable a => 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 :: Testable a => (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.13.2/Test/QuickCheck/Modifiers.hs0000644000000000000000000003574313506212053017216 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 #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-} #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. -- -- __Note__: the contents of this module are re-exported by -- "Test.QuickCheck". You do not need to import it directly. -- -- 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(..) , InfiniteList(..) , SortedList(..) , Positive(..) , Negative(..) , NonZero(..) , NonNegative(..) , NonPositive(..) , Large(..) , Small(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) #endif , ASCIIString(..) , UnicodeString(..) , PrintableString(..) ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Exception import Data.List ( sort ) import Data.Ix (Ix) #ifndef NO_TYPEABLE import Data.Typeable (Typeable) #endif -------------------------------------------------------------------------- -- | @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 #ifndef NO_TYPEABLE , Typeable #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 #ifndef NO_TYPEABLE , Typeable #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 #ifndef NO_TYPEABLE , Typeable #endif ) 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 #ifndef NO_TYPEABLE , Typeable #endif ) 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') ] ---------------------------------------------------------------------- -- | @InfiniteList xs _@: guarantees that xs is an infinite list. -- When a counterexample is found, only prints the prefix of xs -- that was used by the program. -- -- Here is a contrived example property: -- -- > prop_take_10 :: InfiniteList Char -> Bool -- > prop_take_10 (InfiniteList xs _) = -- > or [ x == 'a' | x <- take 10 xs ] -- -- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but -- the remaining (infinite) part can contain anything: -- -- >>> quickCheck prop_take_10 -- *** Failed! Falsified (after 1 test and 14 shrinks): -- "bbbbbbbbbb" ++ ... data InfiniteList a = InfiniteList { getInfiniteList :: [a], infiniteListInternalData :: InfiniteListInternalData a } -- Uses a similar trick to Test.QuickCheck.Function: -- the Arbitrary instance generates an infinite list, which is -- reduced to a finite prefix by shrinking. We use discard to -- check that nothing coming after the finite prefix is used -- (see infiniteListFromData). data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a infiniteListFromData info@(Infinite xs) = InfiniteList xs info infiniteListFromData info@(FinitePrefix xs) = InfiniteList (xs ++ discard) info instance Show a => Show (InfiniteList a) where showsPrec _ (InfiniteList _ (Infinite _)) = ("" ++) showsPrec n (InfiniteList _ (FinitePrefix xs)) = (if n > 10 then ('(':) else id) . showsPrec 0 xs . (" ++ ..." ++) . (if n > 10 then (')':) else id) instance Arbitrary a => Arbitrary (InfiniteList a) where arbitrary = fmap infiniteListFromData arbitrary shrink (InfiniteList _ info) = map infiniteListFromData (shrink info) instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where arbitrary = fmap Infinite infiniteList shrink (Infinite xs) = [FinitePrefix (take n xs) | n <- map (2^) [0..]] shrink (FinitePrefix xs) = map FinitePrefix (shrink xs) -------------------------------------------------------------------------- -- | @Sorted xs@: guarantees that xs is sorted. newtype SortedList a = Sorted {getSorted :: [a]} deriving ( Eq, Ord, Show, Read #ifndef NO_TYPEABLE , Typeable #endif ) instance Functor SortedList where fmap f (Sorted x) = Sorted (map f x) instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where arbitrary = fmap (Sorted . sort) arbitrary shrink (Sorted xs) = [ Sorted xs' | xs' <- map sort (shrink xs) ] -------------------------------------------------------------------------- -- | @Positive x@: guarantees that @x \> 0@. newtype Positive a = Positive {getPositive :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Enum #endif #ifndef NO_TYPEABLE , Typeable #endif ) instance Functor Positive where fmap f (Positive x) = Positive (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] -------------------------------------------------------------------------- -- | @Negative x@: guarantees that @x \< 0@. newtype Negative a = Negative {getNegative :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Enum #endif #ifndef NO_TYPEABLE , Typeable #endif ) instance Functor Negative where fmap f (Negative x) = Negative (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) shrink (Negative x) = [ Negative 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 #ifndef NO_TYPEABLE , Typeable #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 #ifndef NO_TYPEABLE , Typeable #endif ) instance Functor NonNegative where fmap f (NonNegative x) = NonNegative (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0)) shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] -------------------------------------------------------------------------- -- | @NonPositive x@: guarantees that @x \<= 0@. newtype NonPositive a = NonPositive {getNonPositive :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Enum #endif #ifndef NO_TYPEABLE , Typeable #endif ) instance Functor NonPositive where fmap f (NonPositive x) = NonPositive (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0)) shrink (NonPositive x) = [ NonPositive 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, Ix #endif #ifndef NO_TYPEABLE , Typeable #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, Ix #endif #ifndef NO_TYPEABLE , Typeable #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 #ifndef NO_TYPEABLE , Typeable #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 */ -------------------------------------------------------------------------- -- | @ASCIIString@: generates an ASCII string. newtype ASCIIString = ASCIIString {getASCIIString :: String} deriving ( Eq, Ord, Show, Read #ifndef NO_TYPEABLE , Typeable #endif ) instance Arbitrary ASCIIString where arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs -------------------------------------------------------------------------- -- | @UnicodeString@: generates a unicode String. -- The string will not contain surrogate pairs. newtype UnicodeString = UnicodeString {getUnicodeString :: String} deriving ( Eq, Ord, Show, Read #ifndef NO_TYPEABLE , Typeable #endif ) instance Arbitrary UnicodeString where arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs -------------------------------------------------------------------------- -- | @PrintableString@: generates a printable unicode String. -- The string will not contain surrogate pairs. newtype PrintableString = PrintableString {getPrintableString :: String} deriving ( Eq, Ord, Show, Read #ifndef NO_TYPEABLE , Typeable #endif ) instance Arbitrary PrintableString where arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar shrink (PrintableString xs) = PrintableString `fmap` shrink xs -- the end. QuickCheck-2.13.2/Test/QuickCheck/Property.hs0000644000000000000000000010443113506212053017110 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Combinators for constructing properties. {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-} #endif #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( isOneLine, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State( State(terminal), Confidence(..) ) #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) #ifndef NO_DEEPSEQ import Control.DeepSeq #endif #ifndef NO_TYPEABLE import Data.Typeable (Typeable) #endif import Data.Maybe -------------------------------------------------------------------------- -- 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 } #ifndef NO_TYPEABLE deriving (Typeable) #endif -- | The class of properties, i.e., types which QuickCheck knows how to test. -- Typically a property will be a function returning 'Bool' or 'Property'. -- -- If a property does no quantification, i.e. has no -- parameters and doesn't use 'forAll', it will only be tested once. -- This may not be what you want if your property is an @IO Bool@. -- You can change this behaviour using the 'again' combinator. class Testable prop where -- | Convert the thing to a property. property :: prop -> Property -- | Optional; used internally in order to improve shrinking. -- Tests a property but also quantifies over an extra value -- (with a custom shrink and show function). -- The 'Testable' instance for functions defines -- @propertyForAllShrinkShow@ in a way that improves shrinking. propertyForAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property propertyForAllShrinkShow gen shr shw f = forAllShrinkBlind gen shr $ \x -> foldr counterexample (property (f x)) (shw x) -- | If a property returns 'Discard', the current test case is discarded, -- the same as if a precondition was false. -- -- An example is the definition of '==>': -- -- > (==>) :: Testable prop => Bool -> prop -> Property -- > False ==> _ = property Discard -- > True ==> p = property p data Discard = Discard instance Testable Discard where property _ = property rejected -- This instance is here to make it easier to turn IO () into a Property. instance Testable () where property = property . liftUnit where -- N.B. the unit gets forced only inside 'property', -- so that we turn exceptions into test failures liftUnit () = succeeded instance Testable prop => Testable (Maybe prop) where property = property . liftMaybe where -- See comment for liftUnit above liftMaybe Nothing = property Discard liftMaybe (Just prop) = property prop instance Testable Bool where property = property . liftBool instance Testable Result where property = MkProperty . return . MkProp . protectResults . return instance Testable Prop where property p = MkProperty . return . protectProp $ p instance Testable prop => Testable (Gen prop) where property mp = MkProperty $ do p <- mp; unProperty (again p) instance Testable Property where property (MkProperty mp) = MkProperty (fmap protectProp mp) -- | Do I/O inside a property. {-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} morallyDubiousIOProperty :: Testable prop => IO prop -> Property morallyDubiousIOProperty = ioProperty -- | Do I/O inside a property. -- -- Warning: any random values generated inside of the argument to @ioProperty@ -- will not currently be shrunk. For best results, generate all random values -- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. -- -- Note: if your property does no quantification, it will only be tested once. -- To test it repeatedly, use 'again'. ioProperty :: Testable prop => IO prop -> Property ioProperty prop = idempotentIOProperty (fmap noShrinking prop) -- | Do I/O inside a property. -- -- Warning: during shrinking, the I/O may not always be re-executed. -- Instead, the I/O may be executed once and then its result retained. -- If this is not acceptable, use 'ioProperty' instead. idempotentIOProperty :: Testable prop => IO prop -> Property idempotentIOProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property) instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where property f = propertyForAllShrinkShow arbitrary shrink (return . show) f propertyForAllShrinkShow gen shr shw f = -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop -- Idea: Generate and shrink (b, a) as a pair propertyForAllShrinkShow (liftM2 (,) gen arbitrary) (liftShrink2 shr shrink) (\(x, y) -> shw x ++ [show y]) (uncurry 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 the top level of a 'Prop' in an exception handler. protectProp :: Prop -> Prop protectProp (MkProp r) = MkProp (IORose . protectRose . return $ r) -- | 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 , maybeNumTests :: Maybe Int -- ^ stop after this many tests , maybeCheckCoverage :: Maybe Confidence -- ^ required coverage confidence , labels :: [String] -- ^ test case labels , classes :: [String] -- ^ test case classes , tables :: [(String, String)] -- ^ test case tables , requiredCoverage :: [(Maybe String, String, Double)] -- ^ required coverage , callbacks :: [Callback] -- ^ the callbacks for this test case , testCase :: [String] -- ^ the generated test case } exception :: String -> AnException -> Result 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 , maybeNumTests = Nothing , maybeCheckCoverage = Nothing , labels = [] , classes = [] , tables = [] , requiredCoverage = [] , callbacks = [] , testCase = [] } -------------------------------------------------------------------------- -- ** Lifting and mapping functions liftBool :: Bool -> Result liftBool True = succeeded liftBool False = failed { reason = "Falsified" } 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 -- | Adjust the test case size for a property, by transforming it with the given -- function. mapSize :: Testable prop => (Int -> Int) -> prop -> Property mapSize f = property . scale f . unProperty . property -- | Shrinks the argument to a property if it fails. Shrinking is done -- automatically for most types. This function is only needed when you want to -- 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. -- Only quantification /inside/ the call to 'noShrinking' is affected. 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 if the property fails. counterexample :: Testable prop => String -> prop -> Property counterexample s = mapTotalResult (\res -> res{ testCase = s:testCase res }) . callback (PostFinalFailure Counterexample $ \st _res -> do s <- showCounterexample s putLine (terminal st) s) showCounterexample :: String -> IO String showCounterexample s = do let force [] = return () force (x:xs) = x `seq` force xs res <- tryEvaluateIO (force s) return $ case res of Left err -> formatException "Exception thrown while showing test case" err Right () -> s -- | Adds the given string to the counterexample if the property fails. {-# 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 = newCallback (callbacks res):callbacks res }) where newCallback cbs = PostTest Counterexample $ \st res -> do putLine (terminal st) (status res ++ ":") sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] putLine (terminal st) "" status MkResult{ok = Just True} = "Passed" status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" -- | Prints out the generated testcase every time the property fails, including during shrinking. -- Only variables quantified over /inside/ the 'verboseShrinking' are printed. verboseShrinking :: Testable prop => prop -> Property verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) where newCallback cbs = PostTest Counterexample $ \st res -> when (ok res == Just False) $ do putLine (terminal st) "Failed:" sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] putLine (terminal st) "" -- | Indicates that a property is supposed to fail. -- QuickCheck will report an error if it does not fail. expectFailure :: Testable prop => prop -> Property expectFailure = mapTotalResult (\res -> res{ expect = False }) -- | Modifies a property so that it only will be tested once. -- Opposite of 'again'. once :: Testable prop => prop -> Property once = mapTotalResult (\res -> res{ abort = True }) -- | Modifies a property so that it will be tested repeatedly. -- Opposite of 'once'. again :: Testable prop => prop -> Property again = mapTotalResult (\res -> res{ abort = False }) -- | Configures how many times a property will be tested. -- -- For example, -- -- > quickCheck (withMaxSuccess 1000 p) -- -- will test @p@ up to 1000 times. withMaxSuccess :: Testable prop => Int -> prop -> Property withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) -- | Check that all coverage requirements defined by 'cover' and 'coverTable' -- are met, using a statistically sound test, and fail if they are not met. -- -- Ordinarily, a failed coverage check does not cause the property to fail. -- This is because the coverage requirement is not tested in a statistically -- sound way. If you use 'cover' to express that a certain value must appear 20% -- of the time, QuickCheck will warn you if the value only appears in 19 out of -- 100 test cases - but since the coverage varies randomly, you may have just -- been unlucky, and there may not be any real problem with your test -- generation. -- -- When you use 'checkCoverage', QuickCheck uses a statistical test to account -- for the role of luck in coverage failures. It will run as many tests as -- needed until it is sure about whether the coverage requirements are met. If a -- coverage requirement is not met, the property fails. -- -- Example: -- -- > quickCheck (checkCoverage prop_foo) checkCoverage :: Testable prop => prop -> Property checkCoverage = checkCoverageWith stdConfidence -- | Check coverage requirements using a custom confidence level. -- See 'stdConfidence'. -- -- An example of making the statistical test less stringent in order to improve -- performance: -- -- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo) checkCoverageWith :: Testable prop => Confidence -> prop -> Property checkCoverageWith confidence = certainty confidence `seq` tolerance confidence `seq` mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence }) -- | The standard parameters used by 'checkCoverage': @certainty = 10^9@, -- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters. stdConfidence :: Confidence stdConfidence = Confidence { certainty = 10^9, tolerance = 0.9 } -- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- For example: -- -- > prop_reverse_reverse :: [Int] -> Property -- > prop_reverse_reverse xs = -- > label ("length of input is " ++ show (length xs)) $ -- > reverse (reverse xs) === xs -- -- >>> quickCheck prop_reverse_reverse -- +++ OK, passed 100 tests: -- 7% length of input is 7 -- 6% length of input is 3 -- 5% length of input is 4 -- 4% length of input is 6 -- ... -- -- Each use of 'label' in your property results in a separate -- table of test case distribution in the output. If this is -- not what you want, use 'tabulate'. label :: Testable prop => String -> prop -> Property label s = #ifndef NO_DEEPSEQ s `deepseq` #endif mapTotalResult $ \res -> res { labels = s:labels res } -- | Attaches a label to a test case. This is used for reporting -- test case distribution. -- -- > collect x = label (show x) -- -- For example: -- -- > prop_reverse_reverse :: [Int] -> Property -- > prop_reverse_reverse xs = -- > collect (length xs) $ -- > reverse (reverse xs) === xs -- -- >>> quickCheck prop_reverse_reverse -- +++ OK, passed 100 tests: -- 7% 7 -- 6% 3 -- 5% 4 -- 4% 6 -- ... -- -- Each use of 'collect' in your property results in a separate -- table of test case distribution in the output. If this is -- not what you want, use 'tabulate'. collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) -- | Reports how many test cases satisfy a given condition. -- -- For example: -- -- > prop_sorted_sort :: [Int] -> Property -- > prop_sorted_sort xs = -- > sorted xs ==> -- > classify (length xs > 1) "non-trivial" $ -- > sort xs === xs -- -- >>> quickCheck prop_sorted_sort -- +++ OK, passed 100 tests (22% non-trivial). classify :: Testable prop => Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property classify False _ = property classify True s = #ifndef NO_DEEPSEQ s `deepseq` #endif mapTotalResult $ \res -> res { classes = s:classes res } -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage. -- -- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but -- the property does /not/ fail. To make the property fail, use 'checkCoverage'. -- -- For example: -- -- > prop_sorted_sort :: [Int] -> Property -- > prop_sorted_sort xs = -- > sorted xs ==> -- > cover 50 (length xs > 1) "non-trivial" $ -- > sort xs === xs -- -- >>> quickCheck prop_sorted_sort -- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). -- -- Only 26% non-trivial, but expected 50% cover :: Testable prop => Double -- ^ The required percentage (0-100) of test cases. -> Bool -- ^ @True@ if the test case belongs to the class. -> String -- ^ Label for the test case class. -> prop -> Property cover p x s = mapTotalResult f . classify x s where f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res } -- | Collects information about test case distribution into a table. -- The arguments to 'tabulate' are the table's name and a list of values -- associated with the current test case. After testing, QuickCheck prints the -- frequency of all collected values. The frequencies are expressed as a -- percentage of the total number of values collected. -- -- You should prefer 'tabulate' to 'label' when each test case is associated -- with a varying number of values. Here is a (not terribly useful) example, -- where the test data is a list of integers and we record all values that -- occur in the list: -- -- > prop_sorted_sort :: [Int] -> Property -- > prop_sorted_sort xs = -- > sorted xs ==> -- > tabulate "List elements" (map show xs) $ -- > sort xs === xs -- -- >>> quickCheck prop_sorted_sort -- +++ OK, passed 100 tests; 1684 discarded. -- -- List elements (109 in total): -- 3.7% 0 -- 3.7% 17 -- 3.7% 2 -- 3.7% 6 -- 2.8% -6 -- 2.8% -7 -- -- Here is a more useful example. We are testing a chatroom, where the user can -- log in, log out, or send a message: -- -- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) -- > instance Arbitrary Command where ... -- -- There are some restrictions on command sequences; for example, the user must -- log in before doing anything else. The function @valid :: [Command] -> Bool@ -- checks that a command sequence is allowed. Our property then has the form: -- -- > prop_chatroom :: [Command] -> Property -- > prop_chatroom cmds = -- > valid cmds ==> -- > ... -- -- The use of '==>' may skew test case distribution. We use 'collect' to see the -- length of the command sequences, and 'tabulate' to get the frequencies of the -- individual commands: -- -- > prop_chatroom :: [Command] -> Property -- > prop_chatroom cmds = -- > wellFormed cmds LoggedOut ==> -- > 'collect' (length cmds) $ -- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ -- > ... -- -- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom -- +++ OK, passed 100 tests; 2775 discarded: -- 60% 0 -- 20% 1 -- 15% 2 -- 3% 3 -- 1% 4 -- 1% 5 -- -- Commands (68 in total): -- 62% LogIn -- 22% SendMessage -- 16% LogOut tabulate :: Testable prop => String -> [String] -> prop -> Property tabulate key values = #ifndef NO_DEEPSEQ key `deepseq` values `deepseq` #endif mapTotalResult $ \res -> res { tables = [(key, value) | value <- values] ++ tables res } -- | Checks that the values in a given 'table' appear a certain proportion of -- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts -- that of the values in @table@, @x1@ should appear at least @p1@ percent of -- the time, @x2@ at least @p2@ percent of the time, and so on. -- -- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but -- the property does /not/ fail. To make the property fail, use 'checkCoverage'. -- -- Continuing the example from the 'tabular' combinator... -- -- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) -- > prop_chatroom :: [Command] -> Property -- > prop_chatroom cmds = -- > wellFormed cmds LoggedOut ==> -- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ -- > ... -- -- ...we can add a coverage requirement as follows, which checks that @LogIn@, -- @LogOut@ and @SendMessage@ each occur at least 25% of the time: -- -- > prop_chatroom :: [Command] -> Property -- > prop_chatroom cmds = -- > wellFormed cmds LoggedOut ==> -- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ -- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ -- > ... property goes here ... -- -- >>> quickCheck prop_chatroom -- +++ OK, passed 100 tests; 2909 discarded: -- 56% 0 -- 17% 1 -- 10% 2 -- 6% 3 -- 5% 4 -- 3% 5 -- 3% 7 -- -- Commands (111 in total): -- 51.4% LogIn -- 30.6% SendMessage -- 18.0% LogOut -- -- Table 'Commands' had only 18.0% LogOut, but expected 25.0% coverTable :: Testable prop => String -> [(String, Double)] -> prop -> Property coverTable table xs = #ifndef NO_DEEPSEQ table `deepseq` xs `deepseq` #endif mapTotalResult $ \res -> res { requiredCoverage = ys ++ requiredCoverage res } where ys = [(Just table, x, p/100) | (x, p) <- xs] -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded), -- or if the given property holds. Note that using implication carelessly can -- severely skew test case distribution: consider using 'cover' to make sure -- that your test data is still good quality. (==>) :: Testable prop => Bool -> prop -> Property False ==> _ = property Discard True ==> p = property p -- | Considers a property failed if it does not complete within -- the given number of microseconds. -- -- Note: if the property times out, variables quantified inside the -- `within` will not be printed. Therefore, you should use `within` -- only in the body of your property. -- -- Good: @prop_foo a b c = within 1000000 ...@ -- -- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@ -- -- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@ within :: Testable prop => Int -> prop -> Property within n = mapRoseResult f where f rose = ioRose $ do let m `orError` x = fmap (fromMaybe x) m MkRose res roses <- timeout n (reduceRose rose) `orError` return timeoutResult res' <- timeout n (protectResult (return res)) `orError` timeoutResult return (MkRose res' (map f roses)) timeoutResult = failed { reason = "Timeout" } #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 with an explicitly given show function. forAllShow :: Testable prop => Gen a -> (a -> String) -> (a -> prop) -> Property forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf -- | Like 'forAll', but without printing the generated value. forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop) => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrink gen shrinker = forAllShrinkShow gen shrinker show -- | Like 'forAllShrink', but with an explicitly given show function. forAllShrinkShow :: Testable prop => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property forAllShrinkShow gen shrinker shower pf = forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x)) -- | Like 'forAllShrink', but without printing the generated value. forAllShrinkBlind :: Testable prop => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrinkBlind gen shrinker pf = again $ MkProperty $ gen >>= \x -> unProperty $ shrinking shrinker x pf -- | 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 . addCallbacksAndCoverage result . k) ps) Just False -> return rose Nothing -> do rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage 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 addCallbacksAndCoverage result r = r { callbacks = callbacks result ++ callbacks r, requiredCoverage = requiredCoverage result ++ requiredCoverage r } addLabels result r = r { labels = labels result ++ labels r, classes = classes result ++ classes r, tables = tables result ++ tables r } -- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property 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 False -> do result2 <- q return $ case ok result2 of _ | not (expect result2) -> expectFailureError Just True -> addCoverage result1 result2 Just False -> MkResult { ok = Just False, expect = True, reason = sep (reason result1) (reason result2), theException = theException result1 `mplus` theException result2, -- The following few fields are not important because the -- test case has failed anyway abort = False, maybeNumTests = Nothing, maybeCheckCoverage = Nothing, labels = [], classes = [], tables = [], requiredCoverage = [], callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ callbacks result2, testCase = testCase result1 ++ testCase result2 } Nothing -> result2 -- The "obvious" semantics of .||. has: -- discard .||. true = true -- discard .||. discard = discard -- but this implementation gives discard .||. true = discard. -- This is reasonable because evaluating result2 in the case -- that result1 discards is just busy-work - it won't ever -- cause the property to fail. On the other hand, discarding -- instead of returning true causes us to execute one more -- test case - but assuming that preconditions are cheap to -- evaluate, this is no more work than evaluating result2 -- would be, while (unlike evaluating result2) it might catch -- a bug. _ -> return result1 expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } sep [] s = s sep s [] = s sep s s' = s ++ ", " ++ s' addCoverage result r = r { requiredCoverage = requiredCoverage result ++ requiredCoverage r } -- | Like '==', but prints a counterexample when it fails. infix 4 === (===) :: (Eq a, Show a) => a -> a -> Property x === y = counterexample (show x ++ interpret res ++ show y) res where res = x == y interpret True = " == " interpret False = " /= " -- | Like '/=', but prints a counterexample when it fails. infix 4 =/= (=/=) :: (Eq a, Show a) => a -> a -> Property x =/= y = counterexample (show x ++ interpret res ++ show y) res where res = x /= y interpret True = " /= " interpret False = " == " #ifndef NO_DEEPSEQ -- | Checks that a value is total, i.e., doesn't crash when evaluated. total :: NFData a => a -> Property total x = property (rnf x) #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/Test.hs0000644000000000000000000006121513506212053016205 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | The main test loop. {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif module Test.QuickCheck.Test where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) 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.Set(Set) import Data.Map(Map) import Data.Char ( isSpace ) import Data.List ( sort , sortBy , group , intersperse ) import Data.Maybe(fromMaybe, isNothing, catMaybes) import Data.Ord(comparing) import Text.Printf(printf) import Control.Monad import Data.Bits #ifndef NO_TYPEABLE import Data.Typeable (Typeable) #endif -------------------------------------------------------------------------- -- 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. Testing stops -- at the first failure. If all tests are passing and you want to run more tests, -- increase this number. , 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 , maxShrinks :: Int -- ^ Maximum number of shrinks to before giving up. Setting this to zero -- turns shrinking off. } deriving ( Show, Read #ifndef NO_TYPEABLE , Typeable #endif ) -- | Result represents the test result data Result -- | A successful test run = Success { numTests :: Int -- ^ Number of tests performed , numDiscarded :: Int -- ^ Number of tests skipped , labels :: !(Map [String] Int) -- ^ The number of test cases having each combination of labels (see 'label') , classes :: !(Map String Int) -- ^ The number of test cases having each class (see 'classify') , tables :: !(Map String (Map String Int)) -- ^ Data collected by 'tabulate' , output :: String -- ^ Printed output } -- | Given up | GaveUp { numTests :: Int , numDiscarded :: Int -- ^ Number of tests skipped , labels :: !(Map [String] Int) , classes :: !(Map String Int) , tables :: !(Map String (Map String Int)) , output :: String } -- | A failed test run | Failure { numTests :: Int , numDiscarded :: Int -- ^ Number of tests skipped , numShrinks :: Int -- ^ Number of successful shrinking steps performed , numShrinkTries :: Int -- ^ Number of unsuccessful shrinking steps performed , numShrinkFinal :: Int -- ^ Number of unsuccessful shrinking steps performed since last successful shrink , usedSeed :: QCGen -- ^ What seed was used , usedSize :: Int -- ^ What was the test size , reason :: String -- ^ Why did the property fail , theException :: Maybe AnException -- ^ The exception the property threw, if any , output :: String , failingTestCase :: [String] -- ^ The test case which provoked the failure , failingLabels :: [String] -- ^ The test case's labels (see 'label') , failingClasses :: Set String -- ^ The test case's classes (see 'classify') } -- | A property that should have failed did not | NoExpectedFailure { numTests :: Int , numDiscarded :: Int -- ^ Number of tests skipped , labels :: !(Map [String] Int) , classes :: !(Map String Int) , tables :: !(Map String (Map String Int)) , output :: String } 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 , maxShrinks = maxBound } -- | Tests a property and prints the results to 'stdout'. -- -- By default up to 100 tests are performed, which may not be enough -- to find all bugs. To run more tests, use 'withMaxSuccess'. -- -- If you want to get the counterexample as a Haskell value, -- rather than just printing it, try the -- -- package. 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 = withState a (\s -> test s (property p)) withState :: Args -> (State -> IO a) -> IO a withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of Nothing -> newQCGen Just (rnd,_) -> return rnd test MkState{ terminal = tm , maxSuccessTests = maxSuccess a , coverageConfidence = Nothing , maxDiscardedRatio = maxDiscardRatio a , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s , numTotMaxShrinks = maxShrinks a , numSuccessTests = 0 , numDiscardedTests = 0 , numRecentlyDiscardedTests = 0 , S.labels = Map.empty , S.classes = Map.empty , S.tables = Map.empty , S.requiredCoverage = Map.empty , expected = True , randomSeed = rnd , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 } 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 -> Property -> IO Result test st f | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = doneTesting st f | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = giveUp st f | otherwise = runATest st f doneTesting :: State -> Property -> IO Result doneTesting st _f | expected st == False = do putPart (terminal st) ( bold ("*** Failed!") ++ " Passed " ++ showTestCount st ++ " (expected failure)" ) finished NoExpectedFailure | otherwise = do putPart (terminal st) ( "+++ OK, passed " ++ showTestCount st ) finished Success where finished k = do success st theOutput <- terminalOutput (terminal st) return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) giveUp :: State -> Property -> IO Result giveUp st _f = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") ++ " Passed only " ++ showTestCount st ++ " tests" ) success st theOutput <- terminalOutput (terminal st) return GaveUp{ numTests = numSuccessTests st , numDiscarded = numDiscardedTests st , labels = S.labels st , classes = S.classes st , tables = S.tables st , output = theOutput } showTestCount :: State -> String showTestCount st = number (numSuccessTests st) "test" ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" | numDiscardedTests st > 0 ] runATest :: State -> Property -> IO Result runATest st f = do -- CALLBACK before_test putTemp (terminal st) ( "(" ++ showTestCount st ++ ")" ) let powerOfTwo n = n .&. (n - 1) == 0 let f_or_cov = case coverageConfidence st of Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> addCoverageCheck confidence st f _ -> f let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) res <- callbackPostTest st res let continue break st' | abort res = break st' | otherwise = test st' let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) , S.tables = foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) (S.tables st) (P.tables res) , S.requiredCoverage = foldr (\(key, value, p) -> Map.insertWith max (key, value) p) (S.requiredCoverage st) (P.requiredCoverage res) , expected = expect res } case res of MkResult{ok = Just True} -> -- successful test do continue doneTesting st'{ numSuccessTests = numSuccessTests st' + 1 , numRecentlyDiscardedTests = 0 , randomSeed = rnd2 } f MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test do continue giveUp -- Don't add coverage info from this test st{ numDiscardedTests = numDiscardedTests st' + 1 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 , randomSeed = rnd2 } f MkResult{ok = Just False} -> -- failed test do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts theOutput <- terminalOutput (terminal st') if not (expect res) then return Success{ labels = S.labels st', classes = S.classes st', tables = S.tables st', numTests = numSuccessTests st'+1, numDiscarded = numDiscardedTests st', output = theOutput } else do testCase <- mapM showCounterexample (P.testCase res) return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) , usedSize = size , numTests = numSuccessTests st'+1 , numDiscarded = numDiscardedTests st' , numShrinks = numShrinks , numShrinkTries = totFailed , numShrinkFinal = lastFailed , output = theOutput , reason = P.reason res , theException = P.theException res , failingTestCase = testCase , failingLabels = P.labels res , failingClasses = Set.fromList (P.classes res) } where (rnd1,rnd2) = split (randomSeed st) failureSummary :: State -> P.Result -> String failureSummary st res = fst (failureSummaryAndReason st res) failureReason :: State -> P.Result -> [String] failureReason st res = snd (failureSummaryAndReason st res) failureSummaryAndReason :: State -> P.Result -> (String, [String]) failureSummaryAndReason st res = (summary, full) where summary = header ++ short 26 (oneLine theReason ++ " ") ++ count True ++ "..." full = (header ++ (if isOneLine theReason then theReason ++ " " else "") ++ count False ++ ":"): if isOneLine theReason then [] else lines theReason theReason = P.reason res header = if expect res then bold "*** Failed! " else "+++ OK, failed as expected. " count full = "(after " ++ number (numSuccessTests st+1) "test" ++ concat [ " and " ++ show (numSuccessShrinks st) ++ concat [ "." ++ show (numTryShrinks st) | showNumTryShrinks ] ++ " shrink" ++ (if numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s") | numSuccessShrinks st > 0 || showNumTryShrinks ] ++ ")" where showNumTryShrinks = full && numTryShrinks st > 0 success :: State -> IO () success st = do mapM_ (putLine $ terminal st) (paragraphs [short, long]) where (short, long) = case labelsAndTables st of ([msg], long) -> ([" (" ++ dropWhile isSpace msg ++ ")."], long) ([], long) -> (["."], long) (short, long) -> (":":short, long) labelsAndTables :: State -> ([String], [String]) labelsAndTables st = (theLabels, theTables) where theLabels :: [String] theLabels = paragraphs $ [ showTable (numSuccessTests st) Nothing m | m <- S.classes st:Map.elems numberedLabels ] numberedLabels :: Map Int (Map String Int) numberedLabels = Map.fromListWith (Map.unionWith (+)) $ [ (i, Map.singleton l n) | (labels, n) <- Map.toList (S.labels st), (i, l) <- zip [0..] labels ] theTables :: [String] theTables = paragraphs $ [ showTable (sum (Map.elems m)) (Just table) m | (table, m) <- Map.toList (S.tables st) ] ++ [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ") ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot | (mtable, label, tot, n, p) <- allCoverage st, insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] showTable :: Int -> Maybe String -> Map String Int -> [String] showTable k mtable m = [table ++ " " ++ total ++ ":" | Just table <- [mtable]] ++ (map format . -- Descending order of occurrences reverse . sortBy (comparing snd) . -- If #occurences the same, sort in increasing order of key -- (note: works because sortBy is stable) reverse . sortBy (comparing fst) $ Map.toList m) where format (key, v) = rpercent v k ++ " " ++ key total = printf "(%d in total)" k -------------------------------------------------------------------------- -- main shrinking loop foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) foundFailure st res ts = do localMin st{ numTryShrinks = 0 } res ts localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) -- Don't try to shrink for too long localMin st res ts | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = localMinFound st res localMin st res ts = do r <- tryEvaluateIO $ putTemp (terminal st) (failureSummary st res) 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, P.Result) 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' ts' else localMin st{ numTryShrinks = numTryShrinks st + 1, numTotTryShrinks = numTotTryShrinks st + 1 } res ts localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res = do sequence_ [ putLine (terminal st) msg | msg <- failureReason st 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, res) -------------------------------------------------------------------------- -- 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 () ---------------------------------------------------------------------- -- computing coverage sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool sufficientlyCovered confidence n k p = -- Accept the coverage if, with high confidence, the actual probability is -- at least 0.9 times the required one. wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p where err = certainty confidence tol = tolerance confidence insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool insufficientlyCovered Nothing n k p = fromIntegral k < p * fromIntegral n insufficientlyCovered (Just err) n k p = wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p -- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval -- Note: -- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf -- suggests we should use a instead of a/2 for a one-sided test. Look -- into this. wilson :: Integer -> Integer -> Double -> Double wilson k n z = (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf) where nf = fromIntegral n p = fromIntegral k / fromIntegral n wilsonLow :: Integer -> Integer -> Double -> Double wilsonLow k n a = wilson k n (invnormcdf (a/2)) wilsonHigh :: Integer -> Integer -> Double -> Double wilsonHigh k n a = wilson k n (invnormcdf (1-a/2)) -- Algorithm taken from -- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/ -- Accurate to about one part in 10^9. -- -- The 'erf' package uses the same algorithm, but with an extra step -- to get a fully accurate result, which we skip because it requires -- the 'erfc' function. invnormcdf :: Double -> Double invnormcdf p | p < 0 = 0/0 | p > 1 = 0/0 | p == 0 = -1/0 | p == 1 = 1/0 | p < p_low = let q = sqrt(-2*log(p)) in (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / ((((d1*q+d2)*q+d3)*q+d4)*q+1) | p <= p_high = let q = p - 0.5 r = q*q in (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q / (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1) | otherwise = let q = sqrt(-2*log(1-p)) in -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / ((((d1*q+d2)*q+d3)*q+d4)*q+1) where a1 = -3.969683028665376e+01 a2 = 2.209460984245205e+02 a3 = -2.759285104469687e+02 a4 = 1.383577518672690e+02 a5 = -3.066479806614716e+01 a6 = 2.506628277459239e+00 b1 = -5.447609879822406e+01 b2 = 1.615858368580409e+02 b3 = -1.556989798598866e+02 b4 = 6.680131188771972e+01 b5 = -1.328068155288572e+01 c1 = -7.784894002430293e-03 c2 = -3.223964580411365e-01 c3 = -2.400758277161838e+00 c4 = -2.549732539343734e+00 c5 = 4.374664141464968e+00 c6 = 2.938163982698783e+00 d1 = 7.784695709041462e-03 d2 = 3.224671290700398e-01 d3 = 2.445134137142996e+00 d4 = 3.754408661907416e+00 p_low = 0.02425 p_high = 1 - p_low addCoverageCheck :: Confidence -> State -> Property -> Property addCoverageCheck confidence st prop | and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ] = -- Note: run prop once more so that we get labels for this test case run once prop | or [ insufficientlyCovered (Just (certainty confidence)) tot n p | (_, _, tot, n, p) <- allCoverage st ] = let (theLabels, theTables) = labelsAndTables st in foldr counterexample (property failed{P.reason = "Insufficient coverage"}) (paragraphs [theLabels, theTables]) | otherwise = prop allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] allCoverage st = [ (key, value, tot, n, p) | ((key, value), p) <- Map.toList (S.requiredCoverage st), let tot = case key of Just key -> Map.findWithDefault 0 key totals Nothing -> numSuccessTests st, let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ] where combinedCounts :: Map (Maybe String) (Map String Int) combinedCounts = Map.insert Nothing (S.classes st) (Map.mapKeys Just (S.tables st)) totals :: Map String Int totals = fmap (sum . Map.elems) (S.tables st) -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/Text.hs0000644000000000000000000001351413506212053016211 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Terminal control and text helper functions. Internal QuickCheck module. module Test.QuickCheck.Text ( Str(..) , ranges , number , short , showErr , oneLine , isOneLine , bold , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage , drawTable, Cell(..) , paragraphs , newTerminal , withStdioTerminal , withHandleTerminal , withNullTerminal , terminalOutput , handle , Terminal , putTemp , putPart , putLine ) where -------------------------------------------------------------------------- -- imports import System.IO ( hFlush , hPutStr , stdout , stderr , Handle , BufferMode (..) , hGetBuffering , hSetBuffering , hIsTerminalDevice ) import Data.IORef import Data.List import Text.Printf 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 ljust n xs = xs ++ replicate (n - length xs) ' ' rjust n xs = replicate (n - length xs) ' ' ++ xs centre n xs = ljust n $ replicate ((n - length xs) `div` 2) ' ' ++ xs lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String lpercent n k = lpercentage (fromIntegral n / fromIntegral k) k rpercent n k = rpercentage (fromIntegral n / fromIntegral k) k lpercentage, rpercentage :: Integral a => Double -> a -> String lpercentage p n = printf "%.*f" places (100*p) ++ "%" where -- Show no decimal places if k <= 100, -- one decimal place if k <= 1000, -- two decimal places if k <= 10000, and so on. places :: Integer places = ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 rpercentage p n = padding ++ lpercentage p n where padding = if p < 0.1 then " " else "" data Cell = LJust String | RJust String | Centred String deriving Show text :: Cell -> String text (LJust xs) = xs text (RJust xs) = xs text (Centred xs) = xs -- Flatten a table into a list of rows flattenRows :: [[Cell]] -> [String] flattenRows rows = map row rows where cols = transpose rows widths = map (maximum . map (length . text)) cols row cells = concat (intersperse " " (zipWith cell widths cells)) cell n (LJust xs) = ljust n xs cell n (RJust xs) = rjust n xs cell n (Centred xs) = centre n xs -- Draw a table given a header and contents drawTable :: [String] -> [[Cell]] -> [String] drawTable headers table = [line] ++ [border '|' ' ' header | header <- headers] ++ [line | not (null headers) && not (null rows)] ++ [border '|' ' ' row | row <- rows] ++ [line] where rows = flattenRows table headerwidth = maximum (0:map length headers) bodywidth = maximum (0:map length rows) width = max headerwidth bodywidth line = border '+' '-' $ replicate width '-' border x y xs = [x, y] ++ centre width xs ++ [y, x] paragraphs :: [[String]] -> [String] paragraphs = concat . intersperse [""] . filter (not . null) bold :: String -> String -- not portable: --bold s = "\ESC[1m" ++ s ++ "\ESC[0m" bold s = s -- for now -------------------------------------------------------------------------- -- putting strings data Terminal = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal newTerminal out err = do res <- newIORef (showString "") 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 withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a withHandleTerminal outh merrh action = do let err = case merrh of Nothing -> const (return ()) Just errh -> handle errh newTerminal (handle outh) err >>= action withStdioTerminal :: (Terminal -> IO a) -> IO a withStdioTerminal action = do isatty <- hIsTerminalDevice stderr if isatty then withBuffering (withHandleTerminal stdout (Just stderr) action) else withBuffering (withHandleTerminal stdout Nothing action) withNullTerminal :: (Terminal -> IO a) -> IO a withNullTerminal action = newTerminal (const (return ())) (const (return ())) >>= action terminalOutput :: Terminal -> IO String terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) handle :: Handle -> String -> IO () handle h s = do hPutStr h s hFlush h putPart, putTemp, putLine :: Terminal -> String -> IO () putPart tm@(MkTerminal res _ out _) s = do putTemp tm "" force s out s modifyIORef res (. showString 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 n <- readIORef tmp err $ replicate n ' ' ++ replicate n '\b' ++ s ++ [ '\b' | _ <- s ] writeIORef tmp (length s) -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/Poly.hs0000644000000000000000000001041413506212053016204 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #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 ) liftOrdA :: (Integer -> Integer) -> OrdA -> OrdA liftOrdA f (OrdA x) = OrdA (f x) liftOrdA2 :: (Integer -> Integer -> Integer) -> OrdA -> OrdA -> OrdA liftOrdA2 f (OrdA x) (OrdA y) = OrdA (f x y) instance Num OrdA where (+) = liftOrdA2 (+) (*) = liftOrdA2 (*) (-) = liftOrdA2 (-) negate = liftOrdA negate abs = liftOrdA abs signum = liftOrdA signum fromInteger = OrdA . fromInteger 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 ) liftOrdB :: (Integer -> Integer) -> OrdB -> OrdB liftOrdB f (OrdB x) = OrdB (f x) liftOrdB2 :: (Integer -> Integer -> Integer) -> OrdB -> OrdB -> OrdB liftOrdB2 f (OrdB x) (OrdB y) = OrdB (f x y) instance Num OrdB where (+) = liftOrdB2 (+) (*) = liftOrdB2 (*) (-) = liftOrdB2 (-) negate = liftOrdB negate abs = liftOrdB abs signum = liftOrdB signum fromInteger = OrdB . fromInteger 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 ) liftOrdC :: (Integer -> Integer) -> OrdC -> OrdC liftOrdC f (OrdC x) = OrdC (f x) liftOrdC2 :: (Integer -> Integer -> Integer) -> OrdC -> OrdC -> OrdC liftOrdC2 f (OrdC x) (OrdC y) = OrdC (f x y) instance Num OrdC where (+) = liftOrdC2 (+) (*) = liftOrdC2 (*) (-) = liftOrdC2 (-) negate = liftOrdC negate abs = liftOrdC abs signum = liftOrdC signum fromInteger = OrdC . fromInteger 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.13.2/Test/QuickCheck/State.hs0000644000000000000000000000730713506212053016350 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | QuickCheck's internal state. Internal QuickCheck module. module Test.QuickCheck.State where import Test.QuickCheck.Text import Test.QuickCheck.Random import Data.Map(Map) -------------------------------------------------------------------------- -- 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 , maxDiscardedRatio :: Int -- ^ maximum number of discarded tests per successful test , coverageConfidence :: Maybe Confidence -- ^ required coverage confidence , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests , numTotMaxShrinks :: !Int -- ^ How many shrinks to try before giving up -- dynamic , numSuccessTests :: !Int -- ^ the current number of tests that have succeeded , numDiscardedTests :: !Int -- ^ the current number of discarded tests , numRecentlyDiscardedTests :: !Int -- ^ the number of discarded tests since the last successful test , labels :: !(Map [String] Int) -- ^ counts for each combination of labels (label/collect) , classes :: !(Map String Int) -- ^ counts for each class of test case (classify/cover) , tables :: !(Map String (Map String Int)) -- ^ tables collected using tabulate , requiredCoverage :: !(Map (Maybe String, String) Double) -- ^ coverage requirements , expected :: !Bool -- ^ indicates the expected result of the property , randomSeed :: !QCGen -- ^ the current random seed -- shrinking , numSuccessShrinks :: !Int -- ^ number of successful shrinking steps so far , numTryShrinks :: !Int -- ^ number of failed shrinking steps since the last successful shrink , numTotTryShrinks :: !Int -- ^ total number of failed shrinking steps } -- | The statistical parameters used by 'checkCoverage'. data Confidence = Confidence { certainty :: Integer, -- ^ How certain 'checkCoverage' must be before the property fails. -- If the coverage requirement is met, and the certainty parameter is @n@, -- then you should get a false positive at most one in @n@ runs of QuickCheck. -- The default value is @10^9@. -- -- Lower values will speed up 'checkCoverage' at the cost of false -- positives. -- -- If you are using 'checkCoverage' as part of a test suite, you should -- be careful not to set @certainty@ too low. If you want, say, a 1% chance -- of a false positive during a project's lifetime, then @certainty@ should -- be set to at least @100 * m * n@, where @m@ is the number of uses of -- 'cover' in the test suite, and @n@ is the number of times you expect the -- test suite to be run during the project's lifetime. The default value -- is chosen to be big enough for most projects. tolerance :: Double -- ^ For statistical reasons, 'checkCoverage' will not reject coverage -- levels that are only slightly below the required levels. -- If the required level is @p@ then an actual level of @tolerance * p@ -- will be accepted. The default value is @0.9@. -- -- Lower values will speed up 'checkCoverage' at the cost of not detecting -- minor coverage violations. } deriving Show -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/Random.hs0000644000000000000000000000461113506212053016503 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | 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 import System.Random #ifndef NO_SPLITMIX import System.Random.SplitMix #endif import Data.Bits -- | The "standard" QuickCheck random number generator. -- A wrapper around either 'SMGen' on GHC, or 'StdGen' -- on other Haskell systems. #ifdef NO_SPLITMIX newtype QCGen = QCGen StdGen #else newtype QCGen = QCGen SMGen #endif instance Show QCGen where showsPrec n (QCGen g) s = showsPrec n g s 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 #ifdef NO_SPLITMIX newQCGen = fmap QCGen newStdGen #else newQCGen = fmap QCGen newSMGen #endif mkQCGen :: Int -> QCGen #ifdef NO_SPLITMIX mkQCGen n = QCGen (mkStdGen n) #else mkQCGen n = QCGen (mkSMGen (fromIntegral n)) #endif -- Parameterised in order to make this code testable. class Splittable a where left, right :: a -> a instance Splittable QCGen where left = fst . split right = snd . split -- The logic behind 'variant'. Given a random number seed, and an integer, uses -- splitting to transform the seed according to the integer. We use a -- prefix-free code so that calls to integerVariant n g for different values of -- n are guaranteed to return independent seeds. {-# INLINE integerVariant #-} integerVariant :: Splittable a => Integer -> a -> a integerVariant n g -- Use one bit to encode the sign, then use Elias gamma coding -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest. -- Actually, the first bit encodes whether n >= 1 or not; -- this has the advantage that both 0 and 1 get short codes. | n >= 1 = gamma n $! left g | otherwise = gamma (1-n) $! right g where gamma n = encode k . zeroes k where k = ilog2 n encode (-1) g = g encode k g | testBit n k = encode (k-1) $! right g | otherwise = encode (k-1) $! left g zeroes 0 g = g zeroes k g = zeroes (k-1) $! left g ilog2 1 = 0 ilog2 n = 1 + ilog2 (n `div` 2) QuickCheck-2.13.2/Test/QuickCheck/Exception.hs0000644000000000000000000000577013506212053017230 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. {-# OPTIONS_HADDOCK hide #-} {-# 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.tryJust notAsync (m >>= E.evaluate) where notAsync :: AnException -> Maybe AnException #if MIN_VERSION_base(4,7,0) notAsync e = case E.fromException e of Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e #elif !defined(OLD_EXCEPTIONS) notAsync e = case E.fromException e :: Maybe E.AsyncException of Just _ -> Nothing Nothing -> Just e #else notAsync e = Just e #endif --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 error value. If a property evaluates 'discard', it -- causes QuickCheck to discard the current test case. -- This can be useful if you want to discard the current test case, -- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a -- generator. discard :: a isDiscard :: AnException -> Bool (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.13.2/Test/QuickCheck/Features.hs0000644000000000000000000000717013506212053017044 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Test.QuickCheck.Features where import Test.QuickCheck.Property hiding (Result, reason) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Test import Test.QuickCheck.Gen import Test.QuickCheck.State import Test.QuickCheck.Text import qualified Data.Set as Set import Data.Set(Set) import Data.List import Data.IORef import Data.Maybe features :: [String] -> Set String -> Set String features labels classes = Set.fromList labels `Set.union` classes prop_noNewFeatures :: Testable prop => Set String -> prop -> Property prop_noNewFeatures feats prop = mapResult f prop where f res = case ok res of Just True | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) -> res{ok = Just False, P.reason = "New feature found"} _ -> res -- | Given a property, which must use 'label', 'collect', 'classify' or 'cover' -- to associate labels with test cases, find an example test case for each possible label. -- The example test cases are minimised using shrinking. -- -- For example, suppose we test @'Data.List.delete' x xs@ and record the number -- of times that @x@ occurs in @xs@: -- -- > prop_delete :: Int -> [Int] -> Property -- > prop_delete x xs = -- > classify (count x xs == 0) "count x xs == 0" $ -- > classify (count x xs == 1) "count x xs == 1" $ -- > classify (count x xs >= 2) "count x xs >= 2" $ -- > counterexample (show (delete x xs)) $ -- > count x (delete x xs) == max 0 (count x xs-1) -- > where count x xs = length (filter (== x) xs) -- -- 'labelledExamples' generates three example test cases, one for each label: -- -- >>> labelledExamples prop_delete -- *** Found example of count x xs == 0 -- 0 -- [] -- [] -- -- *** Found example of count x xs == 1 -- 0 -- [0] -- [] -- -- *** Found example of count x xs >= 2 -- 5 -- [5,5] -- [5] -- -- +++ OK, passed 100 tests: -- 78% count x xs == 0 -- 21% count x xs == 1 -- 1% count x xs >= 2 labelledExamples :: Testable prop => prop -> IO () labelledExamples prop = labelledExamplesWith stdArgs prop -- | A variant of 'labelledExamples' that takes test arguments. labelledExamplesWith :: Testable prop => Args -> prop -> IO () labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return () -- | A variant of 'labelledExamples' that returns a result. labelledExamplesResult :: Testable prop => prop -> IO Result labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop -- | A variant of 'labelledExamples' that takes test arguments and returns a result. labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result labelledExamplesWithResult args prop = withState args $ \state -> do let loop :: Set String -> State -> IO Result loop feats state = withNullTerminal $ \nullterm -> do res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) let feats' = features (failingLabels res) (failingClasses res) case res of Failure{reason = "New feature found"} -> do putLine (terminal state) $ "*** Found example of " ++ concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) mapM_ (putLine (terminal state)) (failingTestCase res) putStrLn "" loop (Set.union feats feats') state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} _ -> do out <- terminalOutput nullterm putStr out return res at0 f s 0 0 = s at0 f s n d = f n d loop Set.empty state QuickCheck-2.13.2/Test/QuickCheck/Function.hs0000644000000000000000000004250213506212053017051 0ustar0000000000000000{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms, ViewPatterns #-} #endif #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts #-} #endif #ifndef NO_POLYKINDS {-# LANGUAGE PolyKinds #-} #endif -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. -- -- __Note__: most of the contents of this module are re-exported by -- "Test.QuickCheck". You probably do not need to import it directly. -- -- Example of use: -- -- >>> :{ -- >>> let prop :: Fun String Integer -> Bool -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" -- >>> :} -- >>> quickCheck prop -- *** Failed! Falsified (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(..) , applyFun , apply , applyFun2 , applyFun3 , (:->) , Function(..) , functionMap , functionShow , functionIntegral , functionRealFrac , functionBoundedEnum , functionVoid #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 , pattern Fn , pattern Fn2 , pattern Fn3 #endif ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly import Control.Applicative import Data.Char import Data.Word import Data.List( intersperse ) import Data.Ratio 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.Complex import Data.Foldable(toList) import Data.Functor.Identity import qualified Data.Monoid as Monoid #ifndef NO_FIXED import Data.Fixed #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 -- | The class @Function a@ is used for random generation of showable -- functions of type @a -> b@. -- -- There is a default implementation for 'function', which you can use -- if your type has structural equality. Otherwise, you can normally -- use 'functionMap' or 'functionShow'. 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 -- | Provides a 'Function' instance for types isomorphic to 'Data.Void.Void'. -- -- An actual @'Function' 'Data.Void.Void'@ instance is defined in -- @quickcheck-instances@. functionVoid :: (forall b. void -> b) -> void :-> c functionVoid _ = Nil -- | 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 (Const a b) where function = functionMap getConst Const instance Function a => Function (Identity a) where function = functionMap runIdentity Identity instance (Function a, Function b) => Function (a,b) where function = functionPairWith function function 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 Word 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 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 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 -- instances for Data.Monoid newtypes instance Function a => Function (Monoid.Dual a) where function = functionMap Monoid.getDual Monoid.Dual instance Function Monoid.All where function = functionMap Monoid.getAll Monoid.All instance Function Monoid.Any where function = functionMap Monoid.getAny Monoid.Any instance Function a => Function (Monoid.Sum a) where function = functionMap Monoid.getSum Monoid.Sum instance Function a => Function (Monoid.Product a) where function = functionMap Monoid.getProduct Monoid.Product instance Function a => Function (Monoid.First a) where function = functionMap Monoid.getFirst Monoid.First instance Function a => Function (Monoid.Last a) where function = functionMap Monoid.getLast Monoid.Last #if MIN_VERSION_base(4,8,0) instance Function (f a) => Function (Monoid.Alt f a) where function = functionMap Monoid.getAlt Monoid.Alt #endif -- poly instances instance Function A where 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 -- | Generation of random shrinkable, showable functions. -- -- To generate random values of type @'Fun' a b@, -- you must have an instance @'Function' a@. -- -- See also 'applyFun', and 'Fn' with GHC >= 7.8. data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) data Shrunk = Shrunk | NotShrunk deriving Eq instance Functor (Fun a) where fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -- | A modifier for testing functions. -- -- > prop :: Fun String Integer -> Bool -- > prop (Fn f) = f "banana" == f "monkey" -- > || f "banana" == f "elephant" #if __GLASGOW_HASKELL__ >= 800 pattern Fn :: (a -> b) -> Fun a b #endif pattern Fn f <- (applyFun -> f) -- | A modifier for testing binary functions. -- -- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool -- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] #if __GLASGOW_HASKELL__ >= 800 pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c #endif pattern Fn2 f <- (applyFun2 -> f) -- | A modifier for testing ternary functions. #if __GLASGOW_HASKELL__ >= 800 pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d #endif pattern Fn3 f <- (applyFun3 -> f) #endif mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p, d, NotShrunk) (abstract p d) -- | Alias to 'applyFun'. apply :: Fun a b -> (a -> b) apply = applyFun -- | Extracts the value of a function. -- -- 'Fn' is the pattern equivalent of this function. -- -- > prop :: Fun String Integer -> Bool -- > prop f = applyFun f "banana" == applyFun f "monkey" -- > || applyFun f "banana" == applyFun f "elephant" applyFun :: Fun a b -> (a -> b) applyFun (Fun _ f) = f -- | Extracts the value of a binary function. -- -- 'Fn2' is the pattern equivalent of this function. -- -- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool -- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] -- applyFun2 :: Fun (a, b) c -> (a -> b -> c) applyFun2 (Fun _ f) a b = f (a, b) -- | Extracts the value of a ternary function. 'Fn3' is the -- pattern equivalent of this function. applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) applyFun3 (Fun _ f) a b c = f (a, b, c) instance (Show a, Show b) => Show (Fun a b) where show (Fun (_, _, NotShrunk) _) = "" show (Fun (p, d, Shrunk) _) = 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, s) f) = [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ [ Fun (p, d, Shrunk) f | s == NotShrunk ] -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/Test/QuickCheck/All.hs0000644000000000000000000002013113506212053015766 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif -- | __Note__: the contents of this module are re-exported by -- "Test.QuickCheck". You do not need to import it directly. -- -- Test all properties in the current module, using Template Haskell. -- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in -- your module for any of these to work. module Test.QuickCheck.All( -- ** Testing all properties in a module quickCheckAll, verboseCheckAll, forAllProperties, allProperties, -- ** 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 = [| runQuickCheckAll $allProperties |] -- | List all properties in the current module. -- -- @$'allProperties'@ has type @[('String', 'Property')]@. -- -- 'allProperties' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. allProperties :: Q Exp allProperties = 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 [] [| $(fmap (ListE . concat) (mapM quickCheckOne idents)) :: [(String, Property)] |] 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 and later; 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 QuickCheck-2.13.2/Test/QuickCheck/Gen/0000755000000000000000000000000013506212053015436 5ustar0000000000000000QuickCheck-2.13.2/Test/QuickCheck/Gen/Unsafe.hs0000644000000000000000000000352013506212053017213 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif #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.13.2/tests/0000755000000000000000000000000013506212053013136 5ustar0000000000000000QuickCheck-2.13.2/tests/Misc.hs0000644000000000000000000000152513506212053014370 0ustar0000000000000000-- Miscellaneous tests. {-# LANGUAGE TemplateHaskell #-} import Test.QuickCheck import Test.QuickCheck.Random prop_verbose :: Blind (Int -> Int -> Bool) -> Property prop_verbose (Blind p) = forAll (mkQCGen <$> arbitrary) $ \g -> ioProperty $ do res1 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} p res2 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} (verbose p) return $ numTests res1 === numTests res2 .&&. failingTestCase res1 === failingTestCase res2 prop_failingTestCase :: Blind (Int -> Int -> Int -> Bool) -> Property prop_failingTestCase (Blind p) = ioProperty $ do res <- quickCheckWithResult stdArgs{chatty = False} p let [x, y, z] = failingTestCase res return (not (p (read x) (read y) (read z))) return [] main = do True <- $quickCheckAll return () QuickCheck-2.13.2/tests/Split.hs0000644000000000000000000000177113506212053014573 0ustar0000000000000000import Test.QuickCheck import Test.QuickCheck.Random import Data.List -- This type allows us to run integerVariant and get a list of bits out. newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show) instance Splittable Splits where left (Splits xs) = Splits (xs ++ [False]) right (Splits xs) = Splits (xs ++ [True]) -- Check that integerVariant gives a prefix-free code, -- i.e., if m /= n then integerVariant m is not a prefix of integerVariant n. prop_split_prefix :: Property prop_split_prefix = once $ forAllShrink (return [-10000..10000]) shrink $ \ns -> map head (group (sort ns)) == sort ns ==> -- no duplicates let codes :: [Splits] codes = sort [integerVariant n (Splits []) | n <- ns] ok (Splits xs) (Splits ys) = not (xs `isPrefixOf` ys) in -- After sorting, any prefix will end up immediately before -- one of its suffixes and (zipWith ok codes (drop 1 codes)) main = do Success{} <- quickCheckResult prop_split_prefix; return () QuickCheck-2.13.2/tests/MonadFix.hs0000644000000000000000000000126613506212053015204 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, RecursiveDo #-} import Test.QuickCheck import Control.Monad.Fix -- A simple (not complete) test for the MonadFix instance. cyclicList :: Gen [Int] cyclicList = do rec xs <- fmap (:ys) arbitrary ys <- fmap (:xs) arbitrary return xs prop_cyclic :: Property prop_cyclic = forAll (Blind <$> cyclicList) $ \(Blind xs) -> -- repeats with period 2 and $ take 100 $ zipWith (==) xs (drop 2 xs) prop_period2 :: Property prop_period2 = expectFailure $ forAll (Blind <$> cyclicList) $ \(Blind xs) -> -- does not always repeat with period 1 and $ take 100 $ zipWith (==) xs (drop 1 xs) return [] main = do True <- $quickCheckAll; return () QuickCheck-2.13.2/tests/Terminal.hs0000644000000000000000000000571413506212053015254 0ustar0000000000000000-- Check that the terminal output works correctly. {-# LANGUAGE TemplateHaskell, DeriveGeneric #-} import Test.QuickCheck import Test.QuickCheck.Text import System.Process import System.IO import Control.Exception import GHC.Generics import Control.DeepSeq data Command = PutPart String | PutLine String | PutTemp String deriving (Eq, Ord, Show, Generic) instance Arbitrary Command where arbitrary = oneof [ PutPart <$> line, PutLine <$> line, PutTemp <$> line] where line = filter (/= '\n') <$> arbitrary shrink = genericShrink exec :: Terminal -> Command -> IO () exec tm (PutPart xs) = putPart tm xs exec tm (PutLine xs) = putLine tm xs exec tm (PutTemp xs) = putTemp tm xs eval :: [Command] -> String eval = concatMap eval1 where eval1 (PutPart xs) = xs eval1 (PutLine xs) = xs ++ "\n" -- PutTemp only has an effect on stderr eval1 (PutTemp xs) = "" -- Evaluate the result of printing a given string, taking backspace -- characters into account. format :: String -> String format xs = format1 [] [] xs where -- Arguments: text before the cursor (in reverse order), -- text after the cursor, text to print format1 xs ys [] = line xs ys -- \n emits a new line format1 xs ys ('\n':zs) = line xs ys ++ "\n" ++ format1 [] [] zs -- \b moves the cursor to the left format1 (x:xs) ys ('\b':zs) = format1 xs (x:xs) zs -- beginning of line: \b ignored format1 [] ys ('\b':zs) = format1 [] ys zs -- Normal printing puts the character before the cursor, -- and overwrites the next character after the cursor format1 xs ys (z:zs) = format1 (z:xs) (drop 1 ys) zs line xs ys = reverse xs ++ ys -- Check that the terminal satisfies the following properties: -- * The text written to stdout matches what's returned by terminalOutput -- * The output agrees with the model implementation 'eval' -- * Anything written to stderr (presumably by putTemp) is erased prop_terminal :: [Command] -> Property prop_terminal cmds = withMaxSuccess 1000 $ ioProperty $ withPipe $ \stdout_read stdout_write -> withPipe $ \stderr_read stderr_write -> do out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do mapM_ (exec tm) (cmds ++ [PutPart ""]) terminalOutput tm stdout <- stdout_read stderr <- stderr_read return $ conjoin [ counterexample "output == terminalOutput" $ stdout === out, counterexample "output == model" $ out === eval cmds, counterexample "putTemp erased" $ all (== ' ') (format stderr) ] where withPipe :: (IO String -> Handle -> IO a) -> IO a withPipe action = do (readh, writeh) <- createPipe hSetEncoding readh utf8 hSetEncoding writeh utf8 let read = do hClose writeh contents <- hGetContents readh return $!! contents action read writeh `finally` do hClose readh hClose writeh return [] main = do True <- $quickCheckAll; return () QuickCheck-2.13.2/tests/GShrinkExample.hs0000644000000000000000000000057213506212053016357 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-} module Main where import GHC.Generics (Generic) import Test.QuickCheck data Nat = Z | S Nat deriving (Eq, Show, Generic) instance Arbitrary Nat prop_shrink = genericShrink (S (S Z)) === [S Z] .&&. genericShrink [0::Int] === [[]] return [] main :: IO () main = do True <- $quickCheckAll; return () QuickCheck-2.13.2/tests/Generators.hs0000644000000000000000000002004213506212053015601 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 import System.Exit import Data.Complex 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 100 x) where pathFrom n x = fmap (x:) $ case shrink x of [] -> return [] _ | n == 0 -> return [] ys -> oneof [pathFrom (n-1) y | y <- ys] 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 . withMaxSuccess 1000 . 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))) => Bool -> (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property pathInt word 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" (not word .||. path ((p :: Word -> Bool) . getExtremal . f)), counterexample "Word8" (not word .||. path ((p :: Word8 -> Bool) . getExtremal . f)), counterexample "Word16" (not word .||. path ((p :: Word16 -> Bool) . getExtremal . f)), counterexample "Word32" (not word .||. path ((p :: Word32 -> Bool) . getExtremal . f)), counterexample "Word64" (not word .||. path ((p :: Word64 -> Bool) . getExtremal . f))] somePathInt word f p = expectFailure (pathInt word f (not . p)) prop_positive = pathInt True getPositive (> 0) prop_positive_bound = somePathInt True getPositive (== 1) prop_nonzero = pathInt True getNonZero (/= 0) prop_nonzero_bound_1 = somePathInt True getNonZero (== 1) prop_nonzero_bound_2 = somePathInt True getNonZero (== -1) prop_nonnegative = pathInt True getNonNegative (>= 0) prop_nonnegative_bound = somePathInt True getNonNegative (== 0) prop_negative = pathInt False getNegative (< 0) prop_negative_bound = somePathInt False getNegative (== -1) prop_nonpositive = pathInt True getNonPositive (<= 0) prop_nonpositive_bound = somePathInt True getNonPositive (== 0) reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property prop_reachesBound_Int32 = reachesBound :: Int32 -> Property prop_reachesBound_Int64 = reachesBound :: Int64 -> Property prop_reachesBound_Word8 = reachesBound :: Word8 -> Property prop_reachesBound_Word16 = reachesBound :: Word16 -> Property prop_reachesBound_Word32 = reachesBound :: Word32 -> Property prop_reachesBound_Word64 = reachesBound :: Word64 -> Property -- Shrinking should not loop. noShrinkingLoop :: (Eq a, Arbitrary a) => Path a -> Bool noShrinkingLoop (Path (x:xs)) = x `notElem` xs prop_no_shrinking_loop_Unit = noShrinkingLoop :: Path () -> Bool prop_no_shrinking_loop_Bool = noShrinkingLoop :: Path Bool -> Bool prop_no_shrinking_loop_Ordering = noShrinkingLoop :: Path Ordering -> Bool prop_no_shrinking_loop_Maybe = noShrinkingLoop :: Path (Maybe Int) -> Bool prop_no_shrinking_loop_Either = noShrinkingLoop :: Path (Either Int Int) -> Bool prop_no_shrinking_loop_List = noShrinkingLoop :: Path [Int] -> Bool prop_no_shrinking_loop_Ratio = noShrinkingLoop :: Path Rational -> Bool prop_no_shrinking_loop_Complex = noShrinkingLoop :: Path (Complex Double) -> Bool prop_no_shrinking_loop_Fixed = noShrinkingLoop :: Path (Fixed Int) -> Bool prop_no_shrinking_loop_Pair = noShrinkingLoop :: Path (Int, Int) -> Bool prop_no_shrinking_loop_Triple = noShrinkingLoop :: Path (Int, Int, Int) -> Bool prop_no_shrinking_loop_Integer = noShrinkingLoop :: Path Integer -> Bool prop_no_shrinking_loop_Int = noShrinkingLoop :: Path Int -> Bool prop_no_shrinking_loop_Int8 = noShrinkingLoop :: Path Int8 -> Bool prop_no_shrinking_loop_Int16 = noShrinkingLoop :: Path Int16 -> Bool prop_no_shrinking_loop_Int32 = noShrinkingLoop :: Path Int32 -> Bool prop_no_shrinking_loop_Int64 = noShrinkingLoop :: Path Int64 -> Bool prop_no_shrinking_loop_Word = noShrinkingLoop :: Path Word -> Bool prop_no_shrinking_loop_Word8 = noShrinkingLoop :: Path Word8 -> Bool prop_no_shrinking_loop_Word16 = noShrinkingLoop :: Path Word16 -> Bool prop_no_shrinking_loop_Word32 = noShrinkingLoop :: Path Word32 -> Bool prop_no_shrinking_loop_Word64 = noShrinkingLoop :: Path Word64 -> Bool prop_no_shrinking_loop_Char = noShrinkingLoop :: Path Char -> Bool prop_no_shrinking_loop_Float = noShrinkingLoop :: Path Float -> Bool prop_no_shrinking_loop_Double = noShrinkingLoop :: Path Double -> Bool prop_no_shrinking_loop_Version = noShrinkingLoop :: Path Version -> Bool prop_no_shrinking_loop_ExitCode = noShrinkingLoop :: Path ExitCode -> Bool -- Bad shrink: infinite list -- -- remove unexpectedFailure in prop_B1, shrinking should not loop forever. data B1 = B1 Int deriving (Eq, Show) instance Arbitrary B1 where arbitrary = fmap B1 arbitrary shrink x = x : shrink x prop_B1 :: B1 -> Property prop_B1 (B1 n) = expectFailure $ n === n + 1 return [] main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return () QuickCheck-2.13.2/tests/GCoArbitraryExample.hs0000644000000000000000000000106013506212053017333 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-} 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 prop_coarbitrary (Fun _ f) = expectFailure $ withMaxSuccess 1000 $ f (C1 (2::Int)) `elem` [0, 1 :: Int] return [] main = do True <- $quickCheckAll; return () QuickCheck-2.13.2/examples/0000755000000000000000000000000013506212053013612 5ustar0000000000000000QuickCheck-2.13.2/examples/Heap.hs0000644000000000000000000001000013506212053015012 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck 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 80 (size h > 1) "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 -} QuickCheck-2.13.2/examples/Heap_Program.hs0000644000000000000000000001150113506212053016510 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck import Test.QuickCheck.Poly import Data.List ( sort , (\\) ) import Control.Monad ( liftM , liftM2 ) -------------------------------------------------------------------------- -- skew heaps data Heap a = Node a (Heap a) (Heap a) | Nil deriving ( Eq, Ord, Show ) empty :: Heap a empty = Nil isEmpty :: Heap a -> Bool isEmpty Nil = True isEmpty _ = False unit :: a -> Heap a unit x = Node x empty empty size :: Heap a -> Int size Nil = 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 Nil = Nothing removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) merge :: Ord a => Heap a -> Heap a -> Heap a h1 `merge` Nil = h1 Nil `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' (Nil : hs) = toList' hs toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) toSortedList :: Ord a => Heap a -> [a] toSortedList Nil = [] toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) -------------------------------------------------------------------------- -- heap programs data HeapP a = Empty | Unit a | Insert a (HeapP a) | SafeRemoveMin (HeapP a) | Merge (HeapP a) (HeapP a) | FromList [a] deriving (Show) heap :: Ord a => HeapP a -> Heap a heap Empty = empty heap (Unit x) = unit x heap (Insert x p) = insert x (heap p) heap (SafeRemoveMin p) = case removeMin (heap p) of Nothing -> empty -- arbitrary choice Just (_,h) -> h heap (Merge p q) = heap p `merge` heap q heap (FromList xs) = fromList xs instance Arbitrary a => Arbitrary (HeapP a) where arbitrary = sized arbHeapP where arbHeapP s = frequency [ (1, do return Empty) , (1, do x <- arbitrary return (Unit x)) , (s, do x <- arbitrary p <- arbHeapP s1 return (Insert x p)) , (s, do p <- arbHeapP s1 return (SafeRemoveMin p)) , (s, do p <- arbHeapP s2 q <- arbHeapP s2 return (Merge p q)) , (1, do xs <- arbitrary return (FromList xs)) ] where s1 = s-1 s2 = s`div`2 shrink (Unit x) = [ Unit x' | x' <- shrink x ] shrink (FromList xs) = [ Unit x | x <- xs ] ++ [ FromList xs' | xs' <- shrink xs ] shrink (Insert x p) = [ p ] ++ [ Insert x p' | p' <- shrink p ] ++ [ Insert x' p | x' <- shrink x ] shrink (SafeRemoveMin p) = [ p ] ++ [ SafeRemoveMin p' | p' <- shrink p ] shrink (Merge p q) = [ p, q ] ++ [ Merge p' q | p' <- shrink p ] ++ [ Merge p q' | q' <- shrink q ] shrink _ = [] data HeapPP a = HeapPP (HeapP a) (Heap a) deriving (Show) instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where arbitrary = do p <- arbitrary return (HeapPP p (heap p)) shrink (HeapPP p _) = [ HeapPP p' (heap p') | p' <- shrink p ] -------------------------------------------------------------------------- -- properties (==?) :: Heap OrdA -> [OrdA] -> Bool h ==? xs = sort (toList h) == sort xs prop_Empty = empty ==? [] prop_IsEmpty (HeapPP _ h) = isEmpty h == null (toList h) prop_Unit x = unit x ==? [x] prop_Size (HeapPP _ h) = size h == length (toList h) prop_Insert x (HeapPP _ h) = insert x h ==? (x : toList h) prop_RemoveMin (HeapPP _ h) = cover 80 (size h > 1) "non-trivial" $ case removeMin h of Nothing -> h ==? [] Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) prop_Merge (HeapPP _ h1) (HeapPP _ h2) = (h1 `merge` h2) ==? (toList h1 ++ toList h2) prop_FromList xs = fromList xs ==? xs prop_ToSortedList (HeapPP _ h) = h ==? xs && xs == sort xs where xs = toSortedList h -------------------------------------------------------------------------- -- main return [] main = $(quickCheckAll) -------------------------------------------------------------------------- -- the end. -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) QuickCheck-2.13.2/examples/Heap_ProgramAlgebraic.hs0000644000000000000000000001464413506212053020315 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck import Test.QuickCheck.Poly import Data.List ( sort , nub , (\\) ) import Data.Maybe ( fromJust ) import Control.Monad ( liftM , liftM2 ) -------------------------------------------------------------------------- -- skew heaps data Heap a = Node a (Heap a) (Heap a) | Nil deriving ( Eq, Ord, Show ) empty :: Heap a empty = Nil isEmpty :: Heap a -> Bool isEmpty Nil = True isEmpty _ = False unit :: a -> Heap a unit x = Node x empty empty size :: Heap a -> Int size Nil = 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 Nil = Nothing removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) merge :: Ord a => Heap a -> Heap a -> Heap a h1 `merge` Nil = h1 Nil `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 [p] [] = p merging (p:q:ps) qs = merging ps ((p`merge`q):qs) merging ps qs = merging (ps ++ reverse qs) [] toList :: Heap a -> [a] toList h = toList' [h] where toList' [] = [] toList' (Nil : hs) = toList' hs toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) toSortedList :: Ord a => Heap a -> [a] toSortedList Nil = [] toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -------------------------------------------------------------------------- -- heap programs data HeapP a = Empty | Unit a | Insert a (HeapP a) | SafeRemoveMin (HeapP a) | Merge (HeapP a) (HeapP a) | FromList [a] deriving (Show) safeRemoveMin :: Ord a => Heap a -> Heap a safeRemoveMin h = case removeMin h of Nothing -> empty -- arbitrary choice Just (_,h) -> h heap :: Ord a => HeapP a -> Heap a heap Empty = empty heap (Unit x) = unit x heap (Insert x p) = insert x (heap p) heap (SafeRemoveMin p) = safeRemoveMin (heap p) heap (Merge p q) = heap p `merge` heap q heap (FromList xs) = fromList xs instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where arbitrary = sized arbHeapP where arbHeapP s = frequency [ (1, do return Empty) , (1, do x <- arbitrary return (Unit x)) , (s, do x <- arbitrary p <- arbHeapP s1 return (Insert x p)) , (s, do p <- arbHeapP s1 return (SafeRemoveMin p)) , (s, do p <- arbHeapP s2 q <- arbHeapP s2 return (Merge p q)) , (1, do xs <- arbitrary return (FromList xs)) ] where s1 = s-1 s2 = s`div`2 shrink Empty = [] shrink (Unit x) = [ Unit x' | x' <- shrink x ] shrink (FromList xs) = [ Unit x | x <- xs ] ++ [ FromList xs' | xs' <- shrink xs ] shrink p = [ FromList (toList (heap p)) ] ++ case p of Insert x p -> [ p ] ++ [ Insert x p' | p' <- shrink p ] ++ [ Insert x' p | x' <- shrink x ] SafeRemoveMin p -> [ p ] ++ [ SafeRemoveMin p' | p' <- shrink p ] Merge p q -> [ p, q ] ++ [ Merge p' q | p' <- shrink p ] ++ [ Merge p q' | q' <- shrink q ] data HeapPP a = HeapPP (HeapP a) (Heap a) deriving (Show) instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where arbitrary = do p <- arbitrary return (HeapPP p (heap p)) shrink (HeapPP p _) = [ HeapPP p' (heap p') | p' <- shrink p ] -------------------------------------------------------------------------- -- properties data Context a where Context :: Eq b => (Heap a -> b) -> Context a instance (Ord a, Arbitrary a) => Arbitrary (Context a) where arbitrary = do f <- sized arbContext let vec h = (size h, toSortedList h, isEmpty h) return (Context (vec . f)) where arbContext s = frequency [ (1, do return id) , (s, do x <- arbitrary f <- arbContext (s-1) return (insert x . f)) , (s, do f <- arbContext (s-1) return (safeRemoveMin . f)) , (s, do HeapPP _ h <- arbitrary f <- arbContext (s`div`2) elements [ (h `merge`) . f, (`merge` h) . f ]) ] instance Show (Context a) where show _ = "*" (=~) :: Heap Char -> Heap Char -> Property --h1 =~ h2 = sort (toList h1) == sort (toList h2) --h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug! h1 =~ h2 = property (\(Context c) -> c h1 == c h2) {- The normal form is: insert x1 (insert x2 (... empty)...) where x1 <= x2 <= ... -} -- heap creating operations prop_Unit x = unit x =~ insert x empty prop_RemoveMin_Empty = removeMin (empty :: Heap OrdA) == Nothing prop_RemoveMin_Insert1 x = removeMin (insert x empty :: Heap OrdA) == Just (x, empty) prop_RemoveMin_Insert2 x y (HeapPP _ h) = removeMin (insert x (insert y h)) ==~ (insert (max x y) `maph` removeMin (insert (min x y) h)) where f `maph` Just (x,h) = Just (x, f h) f `maph` Nothing = Nothing Nothing ==~ Nothing = property True Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2 prop_InsertSwap x y (HeapPP _ h) = insert x (insert y h) =~ insert y (insert x h) prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) = (insert x h1 `merge` h2) =~ insert x (h1 `merge` h2) prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) = (h1 `merge` insert x h2) =~ insert x (h1 `merge` h2) -- heap observing operations prop_Size_Empty = size empty == 0 prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) = size (insert x h) == 1 + size h prop_ToList_Empty = toList empty == ([] :: [OrdA]) prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) = sort (toList (insert x h)) == sort (x : toList h) prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) = toSortedList h == sort (toList h) -------------------------------------------------------------------------- -- main return [] main = $(quickCheckAll) -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/examples/Lambda.hs0000644000000000000000000002153413506212053015333 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck import Control.Monad ( liftM , liftM2 ) import Data.Char ( toUpper ) import Data.Set (Set) import qualified Data.Set as Set -------------------------------------------------------------------------- -- types for lambda expressions -- variables newtype Var = MkVar String deriving ( Eq, Ord ) instance Show Var where show (MkVar s) = s varList :: [Var] varList = [ MkVar s | let vs = [ c:v | v <- "" : vs, c <- ['a'..'z'] ] , s <- vs ] instance Arbitrary Var where arbitrary = growingElements [ MkVar [c] | c <- ['a'..'z'] ] -- constants newtype Con = MkCon String deriving ( Eq, Ord ) instance Show Con where show (MkCon s) = s instance Arbitrary Con where arbitrary = growingElements [ MkCon [c] | c <- ['A'..'Z'] ] -- expressions data Exp = Lam Var Exp | App Exp Exp | Var Var | Con Con deriving ( Eq, Ord ) instance Show Exp where showsPrec n (Lam x t) = showParen (n>0) (showString "\\" . shows x . showString "." . shows t) showsPrec n (App s t) = showParen (n>1) (showsPrec 1 s . showString " " . showsPrec 2 t) showsPrec _ (Var x) = shows x showsPrec _ (Con c) = shows c instance Arbitrary Exp where arbitrary = sized arbExp where arbExp n = frequency $ [ (2, liftM Var arbitrary) , (1, liftM Con arbitrary) ] ++ concat [ [ (5, liftM2 Lam arbitrary arbExp1) , (5, liftM2 App arbExp2 arbExp2) ] | n > 0 ] where arbExp1 = arbExp (n-1) arbExp2 = arbExp (n `div` 2) shrink (Lam x a) = [ a ] ++ [ Lam x a' | a' <- shrink a ] shrink (App a b) = [ a, b ] ++ [ ab | Lam x a' <- [a] , let ab = subst x b a' , length (show ab) < length (show (App a b)) ] ++ [ App a' b | a' <- shrink a ] ++ [ App a b' | b' <- shrink b ] shrink (Var x) = [Con (MkCon (map toUpper (show x)))] shrink _ = [] -------------------------------------------------------------------------- -- functions for lambda expressions free :: Exp -> Set Var free (Lam x a) = Set.delete x (free a) free (App a b) = free a `Set.union` free b free (Var x) = Set.singleton x free (Con _) = Set.empty subst :: Var -> Exp -> Exp -> Exp subst x c (Var y) | x == y = c subst x b (Lam y a) | x /= y = Lam y (subst x b a) subst x c (App a b) = App (subst x c a) (subst x c b) subst x c a = a fresh :: Var -> Set Var -> Var fresh x ys = head (filter (`Set.notMember` ys) (x:varList)) rename :: Var -> Var -> Exp -> Exp rename x y a | x == y = a | otherwise = subst x (Var y) a -- different bugs: --subst x b (Lam y a) | x /= y = Lam y (subst x b a) -- bug 1 --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y':_ = (y:varList) \\ free b -- bug 2 --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = (y:varList) \\ (x:free b) -- bug 3 --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = fresh y (x:free b) -- bug 4 --subst x c (Lam y a) | x /= y = Lam y' (subst x c (rename y y' a)) where y' = fresh y (x `insert` delete y (free a) `union` free c) -------------------------------------------------------------------------- -- properties for substitutions showResult :: (Show a, Testable prop) => a -> (a -> prop) -> Property showResult x f = whenFail (putStrLn ("Result: " ++ show x)) $ f x prop_SubstFreeNoVarCapture a x b = showResult (subst x b a) $ \subst_x_b_a -> x `Set.member` free_a ==> free subst_x_b_a == (Set.delete x free_a `Set.union` free b) where free_a = free a prop_SubstNotFreeSame a x b = showResult (subst x b a) $ \subst_x_b_a -> x `Set.notMember` free a ==> subst_x_b_a == a prop_SubstNotFreeSameVars a x b = showResult (subst x b a) $ \subst_x_b_a -> x `Set.notMember` free a ==> free subst_x_b_a == free a main1 = do quickCheck prop_SubstFreeNoVarCapture quickCheck prop_SubstNotFreeSame quickCheck prop_SubstNotFreeSameVars --expectFailure $ -------------------------------------------------------------------------- -- eval eval :: Exp -> Exp eval (Var x) = error "eval: free variable" eval (App a b) = case eval a of Lam x a' -> eval (subst x b a') a' -> App a' (eval b) eval a = a -------------------------------------------------------------------------- -- closed lambda expressions newtype ClosedExp = Closed Exp deriving ( Show ) instance Arbitrary ClosedExp where arbitrary = Closed `fmap` sized (arbExp []) where arbExp xs n = frequency $ [ (8, liftM Var (elements xs)) | not (null xs) ] ++ [ (2, liftM Con arbitrary) ] ++ [ (20, do x <- arbitrary t <- arbExp (x:xs) n' return (Lam x t)) | n > 0 || null xs ] ++ [ (20, liftM2 App (arbExp xs n2) (arbExp xs n2)) | n > 0 ] where n' = n-1 n2 = n `div` 2 shrink (Closed a) = [ Closed a' | a' <- shrink a, Set.null (free a') ] -------------------------------------------------------------------------- -- properties for closed lambda expressions isValue :: Exp -> Bool isValue (Var _) = False isValue (App (Lam _ _) _) = False isValue (App a b) = isValue a && isValue b isValue _ = True prop_ClosedExpIsClosed (Closed a) = Set.null (free a) prop_EvalProducesValue (Closed a) = within 1000 $ isValue (eval a) main2 = do quickCheck prop_ClosedExpIsClosed quickCheck prop_EvalProducesValue -- expectFailure $ -------------------------------------------------------------------------- -- main main = do main1 main2 -------------------------------------------------------------------------- -- the end. {- instance Arbitrary Exp where arbitrary = sized (arbExp []) where arbitrary = repair [] `fmap` sized arbExp where arbExp n = frequency $ [ (1, liftM Var arbitrary) ] ++ concat [ [ (3, liftM2 Lam arbitrary (arbExp n')) , (4, liftM2 App (arbExp n2) (arbExp n2)) ] | n > 0 ] where n' = n-1 n2 = n `div` 2 repair xs (Var x) | x `elem` xs = Var x | null xs = Lam x (Var x) | otherwise = Var (xs !! (ord (last (show x)) `mod` length xs)) repair xs (App a b) = App (repair xs a) (repair xs b) repair xs (Lam x a) = Lam x (repair (x:xs) a) -- lots of clever shrinking added shrinkRec (Lam x a) = [ a | x `notElem` free a ] shrinkRec (App a b) = [ a, b ] ++ [ red | Lam x a' <- [a] , let red = subst x b a' , length (show red) < length (show (App a b)) ] shrinkRec (Var x) = [Con (MkCon (map toUpper (show x)))] shrinkRec _ = [] -- types data Type = Base Con | Type :-> Type deriving ( Eq, Show ) instance Arbitrary Type where arbitrary = sized arbType where arbType n = frequency $ [ (1, liftM Base arbitrary) ] ++ [ (4, liftM2 (:->) arbType2 arbType2) | n > 0 ] where arbType2 = arbType (n `div` 2) newtype WellTypedExp = WellTyped Exp deriving ( Eq, Show ) arbExpWithType n env t = frequency $ [ (2, liftM Var (elements xs)) | let xs = [ x | (x,t') <- env, t == t' ] , not (null xs) ] ++ [ (1, return (Con b)) | Base b <- [t] ] ++ [ (if n > 0 then 5 else 1 , do x <- arbitrary b <- arbExpWithType n1 ((x,ta):[ xt | xt <- env, fst xt /= x ]) tb return (Lam x b)) | ta :-> tb <- [t] ] ++ [ (5, do tb <- arbitrary a <- arbExpWithType n2 env (tb :-> t) b <- arbExpWithType n2 env tb return (App a b)) | n > 0 ] where n1 = n-1 n2 = n `div` 2 instance Arbitrary WellTypedExp where arbitrary = do t <- arbitrary e <- sized (\n -> arbExpWithType n [] t) return (WellTyped e) shrink _ = [] newtype OpenExp = Open Exp deriving ( Eq, Show ) instance Arbitrary OpenExp where arbitrary = Open `fmap` sized arbExp where arbExp n = frequency $ [ (2, liftM Var arbitrary) , (1, liftM Con arbitrary) ] ++ concat [ [ (5, liftM2 Lam arbitrary arbExp1) , (5, liftM2 App arbExp2 arbExp2) ] | n > 0 ] where arbExp1 = arbExp (n-1) arbExp2 = arbExp (n `div` 2) shrink (Open a) = map Open (shrink a) prop_EvalProducesValueWT (WellTyped a) = isValue (eval a) -} x = MkVar "x" y = MkVar "y" QuickCheck-2.13.2/examples/Merge.hs0000644000000000000000000000367013506212053015213 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck import Data.List ( sort ) -------------------------------------------------------------------------- -- merge sort msort :: Ord a => [a] -> [a] msort xs = merging [ [x] | x <- xs ] merging :: Ord a => [[a]] -> [a] merging [] = [] merging [xs] = xs merging xss = merging (sweep xss) sweep :: Ord a => [[a]] -> [[a]] sweep [] = [] sweep [xs] = [xs] sweep (xs:ys:xss) = merge xs ys : sweep xss merge :: Ord a => [a] -> [a] -> [a] merge xs [] = xs merge [] ys = ys merge (x:xs) (y:ys) | x <= y = x : merge xs (y:ys) | otherwise = y : merge (x:xs) ys -------------------------------------------------------------------------- -- example properties ordered :: Ord a => [a] -> Bool ordered [] = True ordered [x] = True ordered (x:y:xs) = x <= y && ordered (y:xs) prop_Merge xs (ys :: [Int]) = ordered xs && ordered ys ==> collect (length xs + length ys) $ ordered (xs `merge` ys) -- collect (sort [length xs, length ys]) $ -------------------------------------------------------------------------- -- quantificiation --prop_Merge (Ordered xs) (Ordered (ys :: [Int])) = -- ordered (xs `merge` ys) -- classify (length xs `min` length ys >= 5) "not trivial" $ -- cover (length xs `min` length ys >= 5) 70 "not trivial" $ {- shrink (Ordered xs) = [ Ordered xs' | xs' <- shrink xs , ordered xs' ] -} -------------------------------------------------------------------------- -- merging prop_Merging (xss :: [OrderedList Int]) = ordered (merging [ xs | Ordered xs <- xss ]) -- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> return [] main = $quickCheckAll -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/examples/Set.hs0000644000000000000000000001247713506212053014714 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck import Text.Show.Functions import Data.List ( sort , group , nub , (\\) ) import Control.Monad ( liftM , liftM2 ) import Data.Maybe --import Text.Show.Functions -------------------------------------------------------------------------- -- binary search trees data Set a = Node a (Set a) (Set a) | Empty deriving ( Eq, Ord, Show ) empty :: Set a empty = Empty isEmpty :: Set a -> Bool isEmpty Empty = True isEmpty _ = False unit :: a -> Set a unit x = Node x empty empty size :: Set a -> Int size Empty = 0 size (Node _ s1 s2) = 1 + size s1 + size s2 insert :: Ord a => a -> Set a -> Set a insert x s = s `union` unit x merge :: Set a -> Set a -> Set a s `merge` Empty = s s `merge` Node x Empty s2 = Node x s s2 s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2) delete :: Ord a => a -> Set a -> Set a delete x Empty = Empty delete x (Node x' s1 s2) = case x `compare` x' of LT -> Node x' (delete x s1) s2 EQ -> s1 `merge` s2 GT -> Node x' s1 (delete x s2) union :: Ord a => Set a -> Set a -> Set a {- s1 `union` Empty = s1 Empty `union` s2 = s2 s1@(Node x s11 s12) `union` s2@(Node y s21 s22) = case x `compare` y of LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 EQ -> Node x (s11 `union` s21) (s12 `union` s22) --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 -} s1 `union` Empty = s1 Empty `union` s2 = s2 Node x s11 s12 `union` s2 = Node x (s11 `union` s21) (s12 `union` s22) where (s21,s22) = split x s2 split :: Ord a => a -> Set a -> (Set a, Set a) split x Empty = (Empty, Empty) split x (Node y s1 s2) = case x `compare` y of LT -> (s11, Node y s12 s2) EQ -> (s1, s2) GT -> (Node y s1 s21, s22) where (s11,s12) = split x s1 (s21,s22) = split x s2 mapp :: (a -> b) -> Set a -> Set b mapp f Empty = Empty mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) fromList :: Ord a => [a] -> Set a --fromList xs = build [ (empty,x) | x <- sort xs ] fromList xs = build [ (empty,head x) | x <- group (sort xs) ] where build [] = empty build [(s,x)] = attach x s build sxs = build (sweep sxs) sweep [] = [] sweep [sx] = [sx] sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs attach x Empty = unit x attach x (Node y s1 s2) = Node y s1 (attach x s2) toList :: Set a -> [a] toList s = toSortedList s toSortedList :: Set a -> [a] toSortedList s = toList' s [] where toList' Empty xs = xs toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs) -------------------------------------------------------------------------- -- generators instance (Ord a, Arbitrary a) => Arbitrary (Set a) where arbitrary = sized (arbSet Nothing Nothing) where arbSet mx my n = frequency $ [ (1, return Empty) ] ++ [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my) case mz of Nothing -> return Empty Just z -> liftM2 (Node z) (arbSet mx mz n2) (arbSet mz my n2) where n2 = n `div` 2) | n > 0 ] isOK mx my z = maybe True ( ShrinkSub (Set a) -------------------------------------------------------------------------- -- properties (.<) :: Ord a => Set a -> a -> Bool Empty .< x = True Node y _ s .< x = y < x && s .< x (<.) :: Ord a => a -> Set a -> Bool x <. Empty = True x <. Node y _ s = x < y && x <. s (==?) :: Ord a => Set a -> [a] -> Bool s ==? xs = invariant s && sort (toList s) == nub (sort xs) invariant :: Ord a => Set a -> Bool invariant Empty = True invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2 prop_Invariant (s :: Set Int) = invariant s prop_Empty = empty ==? ([] :: [Int]) prop_Unit (x :: Int) = unit x ==? [x] prop_Size (s :: Set Int) = cover 60 (size s >= 15) "large" $ size s == length (toList s) prop_Insert x (s :: Set Int) = insert x s ==? (x : toList s) prop_Delete x (s :: Set Int) = delete x s ==? (toList s \\ [x]) prop_Union s1 (s2 :: Set Int) = (s1 `union` s2) ==? (toList s1 ++ toList s2) prop_Mapp (f :: Int -> Int) (s :: Set Int) = expectFailure $ whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $ mapp f s ==? map f (toList s) prop_FromList (xs :: [Int]) = fromList xs ==? xs prop_ToSortedList (s :: Set Int) = s ==? xs && xs == sort xs where xs = toSortedList s -- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ prop_FromList' (xs :: [Int]) = shrinking shrink xs $ \xs' -> fromList xs ==? xs -------------------------------------------------------------------------- -- main return [] main = $quickCheckAll -------------------------------------------------------------------------- -- the end. QuickCheck-2.13.2/examples/Simple.hs0000644000000000000000000000237213506212053015403 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where -------------------------------------------------------------------------- -- imports import Test.QuickCheck -------------------------------------------------------------------------- -- example 1 allEqual x y z = x == y && y == z allEqual' x y z = 2*x == y + z prop_SimonThompson x y (z :: Int) = allEqual x y z == allEqual' x y z -------------------------------------------------------------------------- -- example 2 prop_ReverseReverse :: Eq a => [a] -> Bool prop_ReverseReverse xs = reverse (reverse xs) == xs prop_Reverse xs = reverse xs == xs -------------------------------------------------------------------------- -- example 3 prop_Error (x,y) = 2*x <= 5*y -------------------------------------------------------------------------- -- main return [] prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&. counterexample "reverse" $(monomorphic 'prop_Reverse) prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) return [] main = $quickCheckAll -------------------------------------------------------------------------- -- the end.