QuickCheck 2.14 → 2.14.1
raw patch · 39 files changed
+6413/−6297 lines, 39 filesdep ~basedep ~randomdep ~splitmixPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, random, splitmix, template-haskell
API changes (from Hackage documentation)
Files
- QuickCheck.cabal +45/−19
- Test/QuickCheck.hs +0/−326
- Test/QuickCheck/All.hs +0/−213
- Test/QuickCheck/Arbitrary.hs +0/−1454
- Test/QuickCheck/Exception.hs +0/−117
- Test/QuickCheck/Features.hs +0/−106
- Test/QuickCheck/Function.hs +0/−588
- Test/QuickCheck/Gen.hs +0/−352
- Test/QuickCheck/Gen/Unsafe.hs +0/−54
- Test/QuickCheck/Modifiers.hs +0/−531
- Test/QuickCheck/Monadic.hs +0/−279
- Test/QuickCheck/Poly.hs +0/−179
- Test/QuickCheck/Property.hs +0/−973
- Test/QuickCheck/Random.hs +0/−90
- Test/QuickCheck/State.hs +0/−91
- Test/QuickCheck/Test.hs +0/−683
- Test/QuickCheck/Text.hs +0/−232
- changelog +5/−2
- examples/Heap.hs +3/−1
- make-hugs +14/−5
- src/Test/QuickCheck.hs +326/−0
- src/Test/QuickCheck/All.hs +213/−0
- src/Test/QuickCheck/Arbitrary.hs +1454/−0
- src/Test/QuickCheck/Exception.hs +117/−0
- src/Test/QuickCheck/Features.hs +106/−0
- src/Test/QuickCheck/Function.hs +588/−0
- src/Test/QuickCheck/Gen.hs +352/−0
- src/Test/QuickCheck/Gen/Unsafe.hs +54/−0
- src/Test/QuickCheck/Modifiers.hs +531/−0
- src/Test/QuickCheck/Monadic.hs +279/−0
- src/Test/QuickCheck/Poly.hs +179/−0
- src/Test/QuickCheck/Property.hs +981/−0
- src/Test/QuickCheck/Random.hs +116/−0
- src/Test/QuickCheck/State.hs +91/−0
- src/Test/QuickCheck/Test.hs +699/−0
- src/Test/QuickCheck/Text.hs +232/−0
- test-hugs +26/−0
- tests/GCoArbitraryExample.hs +1/−1
- tests/GShrinkExample.hs +1/−1
QuickCheck.cabal view
@@ -1,6 +1,6 @@ Name: QuickCheck-Version: 2.14-Cabal-Version: >= 1.8+Version: 2.14.1+Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE@@ -8,7 +8,7 @@ Author: Koen Claessen <koen@chalmers.se> Maintainer: Nick Smallbone <nick@smallbone.se> Bug-reports: https://github.com/nick8325/quickcheck/issues-Tested-with: GHC >= 7.0+Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs@@ -48,6 +48,7 @@ examples/Set.hs examples/Simple.hs make-hugs+ test-hugs source-repository head type: git@@ -56,23 +57,37 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck- tag: 2.14+ tag: 2.14.1 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True +flag old-random+ Description: Build against a pre-1.2.0 version of the random package.+ Default: False+ library- Build-depends: base >=4.3 && <5, random >=1.0.0.3 && <1.2, containers+ Hs-source-dirs: src+ Build-depends: base >=4.3 && <5, containers+ Default-language: Haskell2010 - -- 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+ -- New vs old random.+ if flag(old-random)+ Build-depends: random >= 1.0.0.3 && < 1.2.0+ cpp-options: -DOLD_RANDOM+ else+ Build-depends: random >= 1.2.0 && < 1.3 + -- We always use splitmix directly rather than going through StdGen+ -- (it's somewhat more efficient).+ -- However, Hugs traps overflow on Word64, so we have to stick+ -- with StdGen there.+ if impl(hugs)+ cpp-options: -DNO_SPLITMIX+ else+ Build-depends: splitmix >= 0.1 && <0.2+ -- Modules that are always built. Exposed-Modules: Test.QuickCheck,@@ -118,11 +133,12 @@ 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.4- else- cpp-options: -DNO_SPLITMIX+ -- random is explicitly Trustworthy since 1.0.1.0+ -- similar constraint for containers+ if impl(ghc >= 7.2)+ Build-depends: random >=1.0.1.0+ if impl(ghc >= 7.4)+ Build-depends: containers >=0.4.2.1 if !impl(ghc >= 7.6) cpp-options: -DNO_POLYKINDS@@ -134,13 +150,15 @@ 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 -DNO_EXTRA_METHODS_IN_APPLICATIVE+ cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS+ -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS+ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM 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+ Default-Extensions: CPP if impl(uhc) -- Cabal under UHC needs pointing out all the dependencies of the@@ -151,6 +169,7 @@ Test-Suite test-quickcheck type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: examples main-is: Heap.hs@@ -160,6 +179,7 @@ Test-Suite test-quickcheck-gcoarbitrary type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck@@ -170,6 +190,7 @@ Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: Generators.hs build-depends: base, QuickCheck@@ -178,6 +199,7 @@ Test-Suite test-quickcheck-gshrink type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: GShrinkExample.hs build-depends: base, QuickCheck@@ -188,6 +210,7 @@ Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: Terminal.hs build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck@@ -196,6 +219,7 @@ Test-Suite test-quickcheck-monadfix type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: MonadFix.hs build-depends: base, QuickCheck@@ -204,12 +228,14 @@ Test-Suite test-quickcheck-split type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: Split.hs build-depends: base, QuickCheck Test-Suite test-quickcheck-misc type: exitcode-stdio-1.0+ Default-language: Haskell2010 hs-source-dirs: tests main-is: Misc.hs build-depends: base, QuickCheck
− Test/QuickCheck.hs
@@ -1,326 +0,0 @@-{-|-The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>-gives detailed information about using QuickCheck effectively.-You can also try <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,-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-<http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> 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- , chooseInt- , chooseInteger- , chooseBoundedIntegral- , chooseEnum- , chooseAny- , 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.
− Test/QuickCheck/All.hs
@@ -1,213 +0,0 @@-{-# 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 == "<interactive>") $ 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
− Test/QuickCheck/Arbitrary.hs
@@ -1,1454 +0,0 @@--- | 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- , RecursivelyShrink- , GSubterms- , 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 Data.Bits--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--- <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>--- 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- -- <http://hackage.haskell.org/package/testing-feat testing-feat> or- -- <http://hackage.haskell.org/package/generic-random generic-random> packages.- --- -- The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>- -- 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 = chooseEnum (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--#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0)-instance Arbitrary a => Arbitrary (Complex a) where-#else-instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where-#endif- 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 = arbitrarySizedNatural- 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 <- chooseInt (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 fromIntegral (chooseInt (-n, n))---- | Generates a natural number. The number's maximum value depends on--- the size parameter.-arbitrarySizedNatural :: Integral a => Gen a-arbitrarySizedNatural =- sized $ \n ->- inBounds fromIntegral (chooseInt (0, n))--inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a-inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi 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 <- chooseInteger (1, precision)- a <- chooseInteger ((-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.-{-# INLINE withBounds #-}-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 = chooseBoundedIntegral (minBound, maxBound)---- | 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 = chooseEnum (minBound, maxBound)---- | 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--- INLINEABLE so that this combinator gets specialised at each type,--- which means that the constant 'bits' in the let-block below will--- only be computed once.-{-# INLINEABLE arbitrarySizedBoundedIntegral #-}-arbitrarySizedBoundedIntegral =- withBounds $ \mn mx ->- let ilog2 1 = 0- ilog2 n | n > 0 = 1 + ilog2 (n `div` 2)-- -- How many bits are needed to represent this type?- -- (This number is an upper bound, not exact.)- bits = ilog2 (toInteger mx - toInteger mn + 1) in- sized $ \k ->- let- -- Reach maximum size by k=80, or quicker for small integer types- power = ((bits `max` 40) * k) `div` 80-- -- Bounds should be 2^power, but:- -- * clamp the result to minBound/maxBound- -- * clamp power to 'bits', in case k is a huge number- lo = toInteger mn `max` (-1 `shiftL` (power `min` bits))- hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in- fmap fromInteger (chooseInteger (lo, hi))---- ** Generators for various kinds of character---- | Generates any Unicode character (but not a surrogate)-arbitraryUnicodeChar :: Gen Char-arbitraryUnicodeChar =- arbitraryBoundedEnum `suchThat` isValidUnicode- where- isValidUnicode c = case generalCategory c of- Surrogate -> False- NotAssigned -> False- _ -> True---- | Generates a random ASCII character (0-127).-arbitraryASCIIChar :: Gen Char-arbitraryASCIIChar = chooseEnum ('\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 (<x) (iterate (*2) 0) -- infinity- | x < 0 = negate x:map negate (shrinkRealFrac (negate x))- | otherwise =- -- To ensure termination- filter (\y -> 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*abs x+1>abs x) = 0 : takeWhile (<x) (iterate (*2) 0) -- infinity- | otherwise =- -- e.g. shrink pi =- -- shrink 3 ++ map (/ 10) (shrink 31) ++- -- map (/ 100) (shrink 314) + ...,- -- where the inner calls to shrink use integer shrinking.- [ y- | precision <- take 6 (iterate (*10) 1),- let m = round (toRational x * precision),- precision == 1 || m `mod` 10 /= 0, -- don't allow shrinking to increase digits- n <- m:shrink m,- let y = fromRational (fromInteger n / precision),- abs y < abs x ]------------------------------------------------------------------------------- ** CoArbitrary--#ifndef NO_GENERICS--- | Used for random generation of functions.--- You should consider using 'Test.QuickCheck.Fun' instead, which--- can show the generated functions as strings.------ If you are using a recent GHC, there is a default definition of--- 'coarbitrary' using 'genericCoarbitrary', so if your type has a--- 'Generic' instance it's enough to say------ > instance CoArbitrary MyType------ You should only use 'genericCoarbitrary' for data types where--- equality is structural, i.e. if you can't have two different--- representations of the same value. An example where it's not--- safe is sets implemented using binary search trees: the same--- set can be represented as several different trees.--- Here you would have to explicitly define--- @coarbitrary s = coarbitrary (toList s)@.-#else--- | Used for random generation of functions.-#endif-class CoArbitrary a where- -- | Used to generate a function of type @a -> b@.- -- The first argument is a value, the second a generator.- -- You should use 'variant' to perturb the random generator;- -- the goal is that different values for the first argument will- -- lead to different calls to 'variant'. An example will help:- --- -- @- -- instance CoArbitrary a => CoArbitrary [a] where- -- coarbitrary [] = 'variant' 0- -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs)- -- @- coarbitrary :: a -> Gen b -> Gen b-#ifndef NO_GENERICS- default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b- coarbitrary = genericCoarbitrary---- | Generic CoArbitrary implementation.-genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b-genericCoarbitrary = gCoarbitrary . from--class GCoArbitrary f where- gCoarbitrary :: f a -> Gen b -> Gen b--instance GCoArbitrary U1 where- gCoarbitrary U1 = id--instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where- -- Like the instance for tuples.- gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r--instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where- -- Like the instance for Either.- gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x- gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x--instance GCoArbitrary f => GCoArbitrary (M1 i c f) where- gCoarbitrary (M1 x) = gCoarbitrary x--instance CoArbitrary a => GCoArbitrary (K1 i a) where- gCoarbitrary (K1 x) = coarbitrary x-#endif--{-# DEPRECATED (><) "Use ordinary function composition instead" #-}--- | Combine two generator perturbing functions, for example the--- results of calls to 'variant' or 'coarbitrary'.-(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a)-(><) = (.)--instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where- coarbitrary f gen =- do xs <- arbitrary- coarbitrary (map f xs) gen--instance CoArbitrary () where- coarbitrary _ = id--instance CoArbitrary Bool where- coarbitrary False = variant 0- coarbitrary True = variant 1--instance CoArbitrary Ordering where- coarbitrary GT = variant 0- coarbitrary EQ = variant 1- coarbitrary LT = variant 2--instance CoArbitrary a => CoArbitrary (Maybe a) where- coarbitrary Nothing = variant 0- coarbitrary (Just x) = variant 1 . coarbitrary x--instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where- coarbitrary (Left x) = variant 0 . coarbitrary x- coarbitrary (Right y) = variant 1 . coarbitrary y--instance CoArbitrary a => CoArbitrary [a] where- coarbitrary [] = variant 0- coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs)--instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where- coarbitrary r = coarbitrary (numerator r,denominator r)--#ifndef NO_FIXED-instance HasResolution a => CoArbitrary (Fixed a) where- coarbitrary = coarbitraryReal-#endif--#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0)-instance CoArbitrary a => CoArbitrary (Complex a) where-#else-instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where-#endif- 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.
− Test/QuickCheck/Exception.hs
@@ -1,117 +0,0 @@--- | 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.
− Test/QuickCheck/Features.hs
@@ -1,106 +0,0 @@-{-# 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--- []--- []--- <BLANKLINE>--- *** Found example of count x xs == 1--- 0--- [0]--- []--- <BLANKLINE>--- *** Found example of count x xs >= 2--- 5--- [5,5]--- [5]--- <BLANKLINE>--- +++ 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
− Test/QuickCheck/Function.hs
@@ -1,588 +0,0 @@-{-# 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- , functionMapWith- , functionEitherWith- , functionPairWith-#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---- | @since 2.13.3-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---- | @since 2.13.3-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---- | @since 2.13.3-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) _) = "<fun>"- 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.
− Test/QuickCheck/Gen.hs
@@ -1,352 +0,0 @@-{-# 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-#ifndef NO_SPLITMIX-import System.Random.SplitMix(bitmaskWithRejection64', SMGen)-#endif-import Data.Word-import Data.Int-import Data.Bits-import Control.Applicative------------------------------------------------------------------------------- ** Generator type---- | A generator for values of type @a@.------ The third-party packages--- <http://hackage.haskell.org/package/QuickCheck-GenT QuickCheck-GenT>--- and--- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer>--- 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 x =- MkGen (\_ _ -> x)- (<*>) = ap--#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE- -- We don't need to split the seed for these.- _ *> m = m- m <* _ = m-#endif--instance Monad Gen where- return = pure-- 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.--- For integral and enumerated types, the specialised variants of--- 'choose' below run much quicker.-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)---- | A fast implementation of 'choose' for enumerated types.-chooseEnum :: Enum a => (a, a) -> Gen a-chooseEnum (lo, hi) =- fmap toEnum (chooseInt (fromEnum lo, fromEnum hi))---- | A fast implementation of 'choose' for 'Int'.-chooseInt :: (Int, Int) -> Gen Int-chooseInt = chooseBoundedIntegral---- Note about INLINEABLE: we specialise chooseBoundedIntegral--- for each concrete type, so that all the bounds checks get--- simplified away.-{-# INLINEABLE chooseBoundedIntegral #-}--- | A fast implementation of 'choose' for bounded integral types.-chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a-chooseBoundedIntegral (lo, hi)-#ifndef NO_SPLITMIX- | toInteger mn >= toInteger (minBound :: Int64) &&- toInteger mx <= toInteger (maxBound :: Int64) =- fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi))- | toInteger mn >= toInteger (minBound :: Word64) &&- toInteger mx <= toInteger (maxBound :: Word64) =- fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi))-#endif- | otherwise =- fmap fromInteger (chooseInteger (toInteger lo, toInteger hi))-#ifndef NO_SPLITMIX- where- mn = minBound `asTypeOf` lo- mx = maxBound `asTypeOf` hi-#endif---- | A fast implementation of 'choose' for 'Integer'.-chooseInteger :: (Integer, Integer) -> Gen Integer-#ifdef NO_SPLITMIX-chooseInteger = choose-#else-chooseInteger (lo, hi)- | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) &&- hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) =- fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi))- | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) &&- hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) =- fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi))- | otherwise = choose (lo, hi)--chooseWord64 :: (Word64, Word64) -> Gen Word64-chooseWord64 (lo, hi)- | lo <= hi = chooseWord64' (lo, hi)- | otherwise = chooseWord64' (hi, lo)- where- chooseWord64' :: (Word64, Word64) -> Gen Word64- chooseWord64' (lo, hi) =- fmap (+ lo) (chooseUpTo (hi - lo))--chooseInt64 :: (Int64, Int64) -> Gen Int64-chooseInt64 (lo, hi)- | lo <= hi = chooseInt64' (lo, hi)- | otherwise = chooseInt64' (hi, lo)- where- chooseInt64' :: (Int64, Int64) -> Gen Int64- chooseInt64' (lo, hi) = do- w <- chooseUpTo (fromIntegral hi - fromIntegral lo)- return (fromIntegral (w + fromIntegral lo))--chooseUpTo :: Word64 -> Gen Word64-chooseUpTo n =- MkGen $ \(QCGen g) _ ->- fst (bitmaskWithRejection64' n g)-#endif---- | 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 = chooseInt (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 = chooseInt (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` chooseInt (0, length xs - 1)---- | Generates a random subsequence of the given list.-sublistOf :: [a] -> Gen [a]-sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs---- | Generates a random permutation of the given list.-shuffle :: [a] -> Gen [a]-shuffle xs = do- ns <- vectorOf (length xs) (chooseInt (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 <- chooseInt (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 <- chooseInt (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.
− Test/QuickCheck/Gen/Unsafe.hs
@@ -1,54 +0,0 @@-{-# 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
− Test/QuickCheck/Modifiers.hs
@@ -1,531 +0,0 @@-{-# 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 _)) =- ("<infinite list>" ++)- 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.
− Test/QuickCheck/Monadic.hs
@@ -1,279 +0,0 @@-{-# 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 \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".--}-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 <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>------ > {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 <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>------ > 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.
− Test/QuickCheck/Poly.hs
@@ -1,179 +0,0 @@-{-# 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.
− Test/QuickCheck/Property.hs
@@ -1,973 +0,0 @@-{-# 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).--- <BLANKLINE>--- 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.--- <BLANKLINE>--- 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--- <BLANKLINE>--- 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--- <BLANKLINE>--- Commands (111 in total):--- 51.4% LogIn--- 30.6% SendMessage--- 18.0% LogOut--- <BLANKLINE>--- 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 of " ++ show n ++ " microseconds exceeded." }-#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.
− Test/QuickCheck/Random.hs
@@ -1,90 +0,0 @@-{-# 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)
− Test/QuickCheck/State.hs
@@ -1,91 +0,0 @@-{-# 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.
− Test/QuickCheck/Test.hs
@@ -1,683 +0,0 @@-{-# 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--- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples>--- 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.
− Test/QuickCheck/Text.hs
@@ -1,232 +0,0 @@-{-# 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.
changelog view
@@ -1,4 +1,7 @@-QuickCheck 2.14 (release 2020-03-28)+QuickCheck 2.14.1 (release 2020-07-05)+ * Compatibility with random >= 1.2.++QuickCheck 2.14 (released 2020-03-28) * QuickCheck is now much faster at generating test data! As a result, many properties can now be tested a lot faster; the examples distributed with QuickCheck run about twice as@@ -31,7 +34,7 @@ - When a call to 'within' fails, include the duration of the timeout in the failure report (thanks to William Rusnack). - In Gen, avoid splitting the seed in the implementation of- >>, *> and <- (thanks to David Feuer).+ >>, *> and <* (thanks to David Feuer). - Fix a couple of bugs with shrinking of floating-point numbers. - Export functionMapWith, functionEitherWith and
examples/Heap.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where +import Data.Int+ -------------------------------------------------------------------------- -- imports @@ -144,7 +146,7 @@ -- main return []-main = $quickCheckAll+main = $forAllProperties (quickCheckWithResult stdArgs{maxSuccess = 10000}) -------------------------------------------------------------------------- -- the end.
make-hugs view
@@ -1,16 +1,25 @@ #!/bin/bash-cd $(dirname $0)-for i in $(find Test -name '*.hs'); do- mkdir -p quickcheck-hugs/$(dirname $i)++set -e++TOPDIR=$(dirname "$0")+TARGETDIR=$TOPDIR/quickcheck-hugs++find "$TOPDIR/src" -name '*.hs' | while read -r src; do+ tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'//')"++ echo "Processing $src -> $tgt"++ mkdir -p "$(dirname "$tgt")" # 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 \+ cpphs --noline -DOLD_RANDOM -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 -DNO_EXTRA_METHODS_IN_APPLICATIVE \- $i > quickcheck-hugs/$i+ "$src" > "$tgt" done echo "A Hugs-compatible version of QuickCheck is now"
+ src/Test/QuickCheck.hs view
@@ -0,0 +1,326 @@+{-|+The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+gives detailed information about using QuickCheck effectively.+You can also try <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,+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+<http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> 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+ , chooseInt+ , chooseInteger+ , chooseBoundedIntegral+ , chooseEnum+ , chooseAny+ , 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.
+ src/Test/QuickCheck/All.hs view
@@ -0,0 +1,213 @@+{-# 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 == "<interactive>") $ 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
+ src/Test/QuickCheck/Arbitrary.hs view
@@ -0,0 +1,1454 @@+-- | 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+ , RecursivelyShrink+ , GSubterms+ , 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 Data.Bits++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+-- <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>+-- 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+ -- <http://hackage.haskell.org/package/testing-feat testing-feat> or+ -- <http://hackage.haskell.org/package/generic-random generic-random> packages.+ --+ -- The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+ -- 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 = chooseEnum (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++#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0)+instance Arbitrary a => Arbitrary (Complex a) where+#else+instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where+#endif+ 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 = arbitrarySizedNatural+ 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 <- chooseInt (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 fromIntegral (chooseInt (-n, n))++-- | Generates a natural number. The number's maximum value depends on+-- the size parameter.+arbitrarySizedNatural :: Integral a => Gen a+arbitrarySizedNatural =+ sized $ \n ->+ inBounds fromIntegral (chooseInt (0, n))++inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a+inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi 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 <- chooseInteger (1, precision)+ a <- chooseInteger ((-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.+{-# INLINE withBounds #-}+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 = chooseBoundedIntegral (minBound, maxBound)++-- | 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 = chooseEnum (minBound, maxBound)++-- | 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+-- INLINEABLE so that this combinator gets specialised at each type,+-- which means that the constant 'bits' in the let-block below will+-- only be computed once.+{-# INLINEABLE arbitrarySizedBoundedIntegral #-}+arbitrarySizedBoundedIntegral =+ withBounds $ \mn mx ->+ let ilog2 1 = 0+ ilog2 n | n > 0 = 1 + ilog2 (n `div` 2)++ -- How many bits are needed to represent this type?+ -- (This number is an upper bound, not exact.)+ bits = ilog2 (toInteger mx - toInteger mn + 1) in+ sized $ \k ->+ let+ -- Reach maximum size by k=80, or quicker for small integer types+ power = ((bits `max` 40) * k) `div` 80++ -- Bounds should be 2^power, but:+ -- * clamp the result to minBound/maxBound+ -- * clamp power to 'bits', in case k is a huge number+ lo = toInteger mn `max` (-1 `shiftL` (power `min` bits))+ hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in+ fmap fromInteger (chooseInteger (lo, hi))++-- ** Generators for various kinds of character++-- | Generates any Unicode character (but not a surrogate)+arbitraryUnicodeChar :: Gen Char+arbitraryUnicodeChar =+ arbitraryBoundedEnum `suchThat` isValidUnicode+ where+ isValidUnicode c = case generalCategory c of+ Surrogate -> False+ NotAssigned -> False+ _ -> True++-- | Generates a random ASCII character (0-127).+arbitraryASCIIChar :: Gen Char+arbitraryASCIIChar = chooseEnum ('\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 (<x) (iterate (*2) 0) -- infinity+ | x < 0 = negate x:map negate (shrinkRealFrac (negate x))+ | otherwise =+ -- To ensure termination+ filter (\y -> 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*abs x+1>abs x) = 0 : takeWhile (<x) (iterate (*2) 0) -- infinity+ | otherwise =+ -- e.g. shrink pi =+ -- shrink 3 ++ map (/ 10) (shrink 31) +++ -- map (/ 100) (shrink 314) + ...,+ -- where the inner calls to shrink use integer shrinking.+ [ y+ | precision <- take 6 (iterate (*10) 1),+ let m = round (toRational x * precision),+ precision == 1 || m `mod` 10 /= 0, -- don't allow shrinking to increase digits+ n <- m:shrink m,+ let y = fromRational (fromInteger n / precision),+ abs y < abs x ]++--------------------------------------------------------------------------+-- ** CoArbitrary++#ifndef NO_GENERICS+-- | Used for random generation of functions.+-- You should consider using 'Test.QuickCheck.Fun' instead, which+-- can show the generated functions as strings.+--+-- If you are using a recent GHC, there is a default definition of+-- 'coarbitrary' using 'genericCoarbitrary', so if your type has a+-- 'Generic' instance it's enough to say+--+-- > instance CoArbitrary MyType+--+-- You should only use 'genericCoarbitrary' for data types where+-- equality is structural, i.e. if you can't have two different+-- representations of the same value. An example where it's not+-- safe is sets implemented using binary search trees: the same+-- set can be represented as several different trees.+-- Here you would have to explicitly define+-- @coarbitrary s = coarbitrary (toList s)@.+#else+-- | Used for random generation of functions.+#endif+class CoArbitrary a where+ -- | Used to generate a function of type @a -> b@.+ -- The first argument is a value, the second a generator.+ -- You should use 'variant' to perturb the random generator;+ -- the goal is that different values for the first argument will+ -- lead to different calls to 'variant'. An example will help:+ --+ -- @+ -- instance CoArbitrary a => CoArbitrary [a] where+ -- coarbitrary [] = 'variant' 0+ -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs)+ -- @+ coarbitrary :: a -> Gen b -> Gen b+#ifndef NO_GENERICS+ default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b+ coarbitrary = genericCoarbitrary++-- | Generic CoArbitrary implementation.+genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b+genericCoarbitrary = gCoarbitrary . from++class GCoArbitrary f where+ gCoarbitrary :: f a -> Gen b -> Gen b++instance GCoArbitrary U1 where+ gCoarbitrary U1 = id++instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where+ -- Like the instance for tuples.+ gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r++instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where+ -- Like the instance for Either.+ gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x+ gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x++instance GCoArbitrary f => GCoArbitrary (M1 i c f) where+ gCoarbitrary (M1 x) = gCoarbitrary x++instance CoArbitrary a => GCoArbitrary (K1 i a) where+ gCoarbitrary (K1 x) = coarbitrary x+#endif++{-# DEPRECATED (><) "Use ordinary function composition instead" #-}+-- | Combine two generator perturbing functions, for example the+-- results of calls to 'variant' or 'coarbitrary'.+(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a)+(><) = (.)++instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where+ coarbitrary f gen =+ do xs <- arbitrary+ coarbitrary (map f xs) gen++instance CoArbitrary () where+ coarbitrary _ = id++instance CoArbitrary Bool where+ coarbitrary False = variant 0+ coarbitrary True = variant 1++instance CoArbitrary Ordering where+ coarbitrary GT = variant 0+ coarbitrary EQ = variant 1+ coarbitrary LT = variant 2++instance CoArbitrary a => CoArbitrary (Maybe a) where+ coarbitrary Nothing = variant 0+ coarbitrary (Just x) = variant 1 . coarbitrary x++instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where+ coarbitrary (Left x) = variant 0 . coarbitrary x+ coarbitrary (Right y) = variant 1 . coarbitrary y++instance CoArbitrary a => CoArbitrary [a] where+ coarbitrary [] = variant 0+ coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs)++instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where+ coarbitrary r = coarbitrary (numerator r,denominator r)++#ifndef NO_FIXED+instance HasResolution a => CoArbitrary (Fixed a) where+ coarbitrary = coarbitraryReal+#endif++#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0)+instance CoArbitrary a => CoArbitrary (Complex a) where+#else+instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where+#endif+ 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.
+ src/Test/QuickCheck/Exception.hs view
@@ -0,0 +1,117 @@+-- | 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.
+ src/Test/QuickCheck/Features.hs view
@@ -0,0 +1,106 @@+{-# 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+-- []+-- []+-- <BLANKLINE>+-- *** Found example of count x xs == 1+-- 0+-- [0]+-- []+-- <BLANKLINE>+-- *** Found example of count x xs >= 2+-- 5+-- [5,5]+-- [5]+-- <BLANKLINE>+-- +++ 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
+ src/Test/QuickCheck/Function.hs view
@@ -0,0 +1,588 @@+{-# 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+ , functionMapWith+ , functionEitherWith+ , functionPairWith+#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++-- | @since 2.13.3+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++-- | @since 2.13.3+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++-- | @since 2.13.3+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) _) = "<fun>"+ 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.
+ src/Test/QuickCheck/Gen.hs view
@@ -0,0 +1,352 @@+{-# 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+#ifndef NO_SPLITMIX+import System.Random.SplitMix(bitmaskWithRejection64', SMGen, nextInteger)+#endif+import Data.Word+import Data.Int+import Data.Bits+import Control.Applicative++--------------------------------------------------------------------------+-- ** Generator type++-- | A generator for values of type @a@.+--+-- The third-party packages+-- <http://hackage.haskell.org/package/QuickCheck-GenT QuickCheck-GenT>+-- and+-- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer>+-- 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 x =+ MkGen (\_ _ -> x)+ (<*>) = ap++#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE+ -- We don't need to split the seed for these.+ _ *> m = m+ m <* _ = m+#endif++instance Monad Gen where+ return = pure++ 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.+-- For integral and enumerated types, the specialised variants of+-- 'choose' below run much quicker.+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)++-- | A fast implementation of 'choose' for enumerated types.+chooseEnum :: Enum a => (a, a) -> Gen a+chooseEnum (lo, hi) =+ fmap toEnum (chooseInt (fromEnum lo, fromEnum hi))++-- | A fast implementation of 'choose' for 'Int'.+chooseInt :: (Int, Int) -> Gen Int+chooseInt = chooseBoundedIntegral++-- Note about INLINEABLE: we specialise chooseBoundedIntegral+-- for each concrete type, so that all the bounds checks get+-- simplified away.+{-# INLINEABLE chooseBoundedIntegral #-}+-- | A fast implementation of 'choose' for bounded integral types.+chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a+chooseBoundedIntegral (lo, hi)+#ifndef NO_SPLITMIX+ | toInteger mn >= toInteger (minBound :: Int64) &&+ toInteger mx <= toInteger (maxBound :: Int64) =+ fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi))+ | toInteger mn >= toInteger (minBound :: Word64) &&+ toInteger mx <= toInteger (maxBound :: Word64) =+ fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi))+#endif+ | otherwise =+ fmap fromInteger (chooseInteger (toInteger lo, toInteger hi))+#ifndef NO_SPLITMIX+ where+ mn = minBound `asTypeOf` lo+ mx = maxBound `asTypeOf` hi+#endif++-- | A fast implementation of 'choose' for 'Integer'.+chooseInteger :: (Integer, Integer) -> Gen Integer+#ifdef NO_SPLITMIX+chooseInteger = choose+#else+chooseInteger (lo, hi)+ | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) &&+ hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) =+ fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi))+ | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) &&+ hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) =+ fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi))+ | otherwise = MkGen $ \(QCGen g) _ -> fst (nextInteger lo hi g)++chooseWord64 :: (Word64, Word64) -> Gen Word64+chooseWord64 (lo, hi)+ | lo <= hi = chooseWord64' (lo, hi)+ | otherwise = chooseWord64' (hi, lo)+ where+ chooseWord64' :: (Word64, Word64) -> Gen Word64+ chooseWord64' (lo, hi) =+ fmap (+ lo) (chooseUpTo (hi - lo))++chooseInt64 :: (Int64, Int64) -> Gen Int64+chooseInt64 (lo, hi)+ | lo <= hi = chooseInt64' (lo, hi)+ | otherwise = chooseInt64' (hi, lo)+ where+ chooseInt64' :: (Int64, Int64) -> Gen Int64+ chooseInt64' (lo, hi) = do+ w <- chooseUpTo (fromIntegral hi - fromIntegral lo)+ return (fromIntegral (w + fromIntegral lo))++chooseUpTo :: Word64 -> Gen Word64+chooseUpTo n =+ MkGen $ \(QCGen g) _ ->+ fst (bitmaskWithRejection64' n g)+#endif++-- | 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 = chooseInt (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 = chooseInt (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` chooseInt (0, length xs - 1)++-- | Generates a random subsequence of the given list.+sublistOf :: [a] -> Gen [a]+sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs++-- | Generates a random permutation of the given list.+shuffle :: [a] -> Gen [a]+shuffle xs = do+ ns <- vectorOf (length xs) (chooseInt (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 <- chooseInt (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 <- chooseInt (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.
+ src/Test/QuickCheck/Gen/Unsafe.hs view
@@ -0,0 +1,54 @@+{-# 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
+ src/Test/QuickCheck/Modifiers.hs view
@@ -0,0 +1,531 @@+{-# 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 _)) =+ ("<infinite list>" ++)+ 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.
+ src/Test/QuickCheck/Monadic.hs view
@@ -0,0 +1,279 @@+{-# 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 \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".+-}+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 <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>+--+-- > {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 <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>+--+-- > 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.
+ src/Test/QuickCheck/Poly.hs view
@@ -0,0 +1,179 @@+{-# 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.
+ src/Test/QuickCheck/Property.hs view
@@ -0,0 +1,981 @@+{-# 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 test case every time the property is tested.+-- Only variables quantified over /inside/ the 'verbose' are printed.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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 test case every time the property fails, including during shrinking.+-- Only variables quantified over /inside/ the 'verboseShrinking' are printed.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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).+-- <BLANKLINE>+-- 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.+-- <BLANKLINE>+-- 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+-- <BLANKLINE>+-- 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+-- <BLANKLINE>+-- Commands (111 in total):+-- 51.4% LogIn+-- 30.6% SendMessage+-- 18.0% LogOut+-- <BLANKLINE>+-- 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 of " ++ show n ++ " microseconds exceeded." }+#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.
+ src/Test/QuickCheck/Random.hs view
@@ -0,0 +1,116 @@+{-# 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+#ifdef NO_SPLITMIX+ split (QCGen g) =+ case split g of+ (g1, g2) -> (QCGen g1, QCGen g2)+ genRange (QCGen g) = genRange g+ next = wrapQCGen next+#else+ split (QCGen g) =+ case splitSMGen g of+ (g1, g2) -> (QCGen g1, QCGen g2)+ genRange _ = (minBound, maxBound)+ next = wrapQCGen nextInt++#ifndef OLD_RANDOM+ genWord8 = wrapQCGen genWord8+ genWord16 = wrapQCGen genWord16+ genWord32 = wrapQCGen genWord32+ genWord64 = wrapQCGen genWord64+ genWord32R r = wrapQCGen (genWord32R r)+ genWord64R r = wrapQCGen (genWord64R r)+ genShortByteString n = wrapQCGen (genShortByteString n)+#endif+#endif++{-# INLINE wrapQCGen #-}+#ifdef NO_SPLITMIX+wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen))+#else+wrapQCGen :: (SMGen -> (a, SMGen)) -> (QCGen -> (a, QCGen))+#endif+wrapQCGen f (QCGen g) =+ case f 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)
+ src/Test/QuickCheck/State.hs view
@@ -0,0 +1,91 @@+{-# 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.
+ src/Test/QuickCheck/Test.hs view
@@ -0,0 +1,699 @@+{-# 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+-- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples>+-- 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'@.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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.
+ src/Test/QuickCheck/Text.hs view
@@ -0,0 +1,232 @@+{-# 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.
+ test-hugs view
@@ -0,0 +1,26 @@+#!/bin/sh++set -e++CABAL=${CABAL:-cabal}+HC=${HC:-ghc}++# Install cpphs if it is not in path+command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs++# Regenerate quickcheck-hugs+sh make-hugs+find quickcheck-hugs++die() {+ echo "TEST FAILED"+ exit 1+}++dotest() {+ echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output+ grep "$3" hugs.output || die+}++# Simple tests+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests."
tests/GCoArbitraryExample.hs view
@@ -9,7 +9,7 @@ data D a = C1 a | C2 deriving (Eq, Show, Read, Generic) -instance Arbitrary a => Arbitrary (D a)+instance Arbitrary a => Arbitrary (D a) where arbitrary = error "not implemented" instance CoArbitrary a => CoArbitrary (D a) instance (Show a, Read a) => Function (D a) where
tests/GShrinkExample.hs view
@@ -8,7 +8,7 @@ data Nat = Z | S Nat deriving (Eq, Show, Generic) -instance Arbitrary Nat+instance Arbitrary Nat where arbitrary = error "not implemented" prop_shrink = genericShrink (S (S Z)) === [S Z] .&&.