diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,8 @@ (The following is the 3-clause BSD license.) -Copyright (c) 2000-2018, Koen Claessen +Copyright (c) 2000-2019, Koen Claessen Copyright (c) 2006-2008, Björn Bringert -Copyright (c) 2009-2018, Nick Smallbone +Copyright (c) 2009-2019, Nick Smallbone Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,14 +1,14 @@ Name: QuickCheck -Version: 2.12.6.1 -Cabal-Version: >= 1.8 +Version: 2.18.0.0 +Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE -Copyright: 2000-2018 Koen Claessen, 2006-2008 Björn Bringert, 2009-2018 Nick Smallbone +Copyright: 2000-2019 Koen Claessen, 2006-2008 Björn Bringert, 2009-2019 Nick Smallbone Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC >= 7.0 +Tested-with: GHC >= 8.10 && < 9.15, hugs Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -33,13 +33,13 @@ * , a detailed tutorial written by a user of QuickCheck. . - The + The companion package provides instances for types in Haskell Platform packages at the cost of additional dependencies. extra-source-files: README - changelog + changelog.md examples/Heap.hs examples/Heap_Program.hs examples/Heap_ProgramAlgebraic.hs @@ -47,6 +47,9 @@ examples/Merge.hs examples/Set.hs examples/Simple.hs + make-hugs + test-hugs + test-mhs source-repository head type: git @@ -55,22 +58,51 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.12.6.1 + tag: 2.18 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True + Manual: True +flag old-random + Description: Build against a pre-1.2.0 version of the random package. + Default: False + Manual: False + library - Build-depends: base >=4.3 && <5, random, containers, erf >= 2 + Hs-source-dirs: src + Build-depends: base >=4.14 && <5, containers + Default-language: Haskell2010 + -- 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.4 + + -- 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 && <0.2 + + if impl(hugs) + cpp-options: -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS + -- Modules that are always built. Exposed-Modules: Test.QuickCheck, + Test.QuickCheck.Compat, Test.QuickCheck.Arbitrary, Test.QuickCheck.Gen, Test.QuickCheck.Gen.Unsafe, Test.QuickCheck.Monadic, + Test.QuickCheck.Monoids, Test.QuickCheck.Modifiers, Test.QuickCheck.Property, Test.QuickCheck.Test, @@ -82,66 +114,60 @@ Test.QuickCheck.Features -- GHC-specific modules. - if impl(ghc) + if impl(ghc) || impl(mhs) Exposed-Modules: Test.QuickCheck.Function - Build-depends: transformers >= 0.3, deepseq - else - cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ + Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 - Other-Extensions: TemplateHaskell + Other-Extensions: TemplateHaskellQuotes Exposed-Modules: Test.QuickCheck.All else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 7.4) - cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS - - -- The new generics appeared in GHC 7.2... - if impl(ghc < 7.2) - cpp-options: -DNO_GENERICS - -- ...but in 7.2-7.4 it lives in the ghc-prim package. - if impl(ghc >= 7.2) && impl(ghc < 7.6) - Build-depends: ghc-prim - - -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. - if impl (ghc < 7.4) - cpp-options: -DNO_SAFE_HASKELL + if !impl(ghc) && !impl(mhs) + cpp-options: -DNO_CALLSTACK + -DNO_SEMIGROUP + -DNO_CTYPES_CONSTRUCTORS + -DNO_FOREIGN_C_USECONDS + -DNO_POLYKINDS + -DNO_MONADFAIL + -DNO_TRANSFORMERS + -DNO_DEEPSEQ - -- Use tf-random on newer GHCs. + -- random is explicitly Trustworthy since 1.0.1.0 + -- similar constraint for containers if impl(ghc) - Build-depends: tf-random >= 0.4 - else - cpp-options: -DNO_TF_RANDOM + Build-depends: random >=1.0.1.0 + , containers >=0.4.2.1 - if !impl(ghc >= 7.6) - cpp-options: -DNO_POLYKINDS + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial - if !impl(ghc >= 8.0) - cpp-options: -DNO_MONADFAIL + if impl(ghc < 9.4) + Build-depends: data-array-byte -- Switch off most optional features on non-GHC systems. - if !impl(ghc) + if !impl(ghc) && !impl(mhs) -- 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 + 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 -DNO_CALLSTACK if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES + if impl(mhs) + cpp-options: -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_CTYPES_CONSTRUCTORS + -DNO_EXISTENTIAL_FIELD_SELECTORS + -- LANGUAGE pragmas don't have any effect in Hugs. if impl(hugs) - Extensions: CPP - - if impl(uhc) - -- Cabal under UHC needs pointing out all the dependencies of the - -- random package. - Build-depends: old-time, old-locale - -- Plus some bits of the standard library are missing. - cpp-options: -DNO_FIXED -DNO_EXCEPTIONS + Default-Extensions: CPP Test-Suite test-quickcheck type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: examples main-is: Heap.hs @@ -151,16 +177,16 @@ 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 - if !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Generators.hs build-depends: base, QuickCheck @@ -169,26 +195,92 @@ 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 - if !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Terminal.hs - build-depends: base, process, deepseq, QuickCheck - if !impl(ghc >= 7.10) + build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck + if !flag(templateHaskell) buildable: False 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 - if !impl(ghc >= 7.10) + if !flag(templateHaskell) + buildable: False + +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 + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + +Test-Suite test-quickcheck-strictness + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Strictness.hs + build-depends: base, QuickCheck, containers + if !flag(templateHaskell) + buildable: False + +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, containers + if !flag(templateHaskell) + buildable: False + +Test-Suite test-quickcheck-discard + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: DiscardRatio.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-monoids + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Monoids.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-withprogress + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: WithProgress.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-instances + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + other-modules: CollectDataTypes + main-is: RunCollectDataTypes.hs + build-depends: + base, + QuickCheck, + transformers, + split, + process, + template-haskell, + hint + if !flag(templateHaskell) || impl(ghc <= 8.10) buildable: False diff --git a/README b/README --- a/README +++ b/README @@ -1,10 +1,11 @@ This is QuickCheck 2, a library for random testing of program properties. -Install it in the usual way: - -$ cabal install +Add `QuickCheck` to your package dependencies to use it in tests or REPL. The quickcheck-instances [1] companion package provides instances for types in Haskell Platform packages at the cost of additional dependencies. + +The make-hugs script makes a Hugs-compatible version of QuickCheck. +It may also be useful for other non-GHC implementations. [1]: http://hackage.haskell.org/package/quickcheck-instances diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs deleted file mode 100644 --- a/Test/QuickCheck.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-| -The -gives detailed information about using QuickCheck effectively. -You can also try , -a tutorial written by a user of QuickCheck. - -To start using QuickCheck, write down your property as a function returning @Bool@. -For example, to check that reversing a list twice gives back the same list you can write: - -@ -import Test.QuickCheck - -prop_reverse :: [Int] -> Bool -prop_reverse xs = reverse (reverse xs) == xs -@ - -You can then use QuickCheck to test @prop_reverse@ on 100 random lists: - ->>> quickCheck prop_reverse -+++ OK, passed 100 tests. - -To run more tests you can use the 'withMaxSuccess' combinator: - ->>> quickCheck (withMaxSuccess 10000 prop_reverse) -+++ OK, passed 10000 tests. - -To use QuickCheck on your own data types you will need to write 'Arbitrary' -instances for those types. See the - for -details about how to do that. --} -{-# LANGUAGE CPP #-} -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE PatternSynonyms #-} -#endif -module Test.QuickCheck - ( - -- * Running tests - quickCheck - , Args(..), Result(..) - , stdArgs - , quickCheckWith - , quickCheckWithResult - , quickCheckResult - , isSuccess - -- ** Running tests verbosely - , verboseCheck - , verboseCheckWith - , verboseCheckWithResult - , verboseCheckResult -#ifndef NO_TEMPLATE_HASKELL - -- ** Testing all properties in a module - - -- | These functions test all properties in the current module, using - -- Template Haskell. You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ - -- pragma in your module for any of these to work. - , quickCheckAll - , verboseCheckAll - , forAllProperties - , allProperties - -- ** Testing polymorphic properties - , polyQuickCheck - , polyVerboseCheck - , monomorphic -#endif - - -- * The 'Arbitrary' typeclass: generation of random values - , Arbitrary(..) - -- ** Helper functions for implementing 'shrink' -#ifndef NO_GENERICS - , genericShrink - , subterms - , recursivelyShrink -#endif - , shrinkNothing - , shrinkList - , shrinkMap - , shrinkMapBy - , shrinkIntegral - , shrinkRealFrac - , shrinkDecimal - - -- ** Lifting of 'Arbitrary' to unary and binary type constructors - , Arbitrary1(..) - , arbitrary1 - , shrink1 - , Arbitrary2(..) - , arbitrary2 - , shrink2 - - -- * The 'Gen' monad: combinators for building random generators - , Gen - -- ** Generator combinators - , choose - , oneof - , frequency - , elements - , growingElements - , sized - , getSize - , resize - , scale - , suchThat - , suchThatMap - , suchThatMaybe - , applyArbitrary2 - , applyArbitrary3 - , applyArbitrary4 - -- ** Generators for lists - , listOf - , listOf1 - , vectorOf - , vector - , infiniteListOf - , infiniteList - , shuffle - , sublistOf - , orderedList - -- ** Generators for particular types - , arbitrarySizedIntegral - , arbitrarySizedNatural - , arbitrarySizedFractional - , arbitrarySizedBoundedIntegral - , arbitraryBoundedIntegral - , arbitraryBoundedRandom - , arbitraryBoundedEnum - , arbitraryUnicodeChar - , arbitraryASCIIChar - , arbitraryPrintableChar - -- ** Running generators - , generate - -- ** Debugging generators - , sample - , sample' - - -- * 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! Falsifiable (after 3 tests and 134 shrinks): - -- {"elephant"->1, "monkey"->1, _->0} - -- - -- To generate random values of type @'Fun' a b@, - -- you must have an instance @'Function' a@. - -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, - -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. - -- See the @'Function' [a]@ instance for an example of the latter. - -- - -- 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 - - -- * 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(..) - , NonZero(..) - , NonNegative(..) - , 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 -import Test.QuickCheck.Function -import Test.QuickCheck.Features -import Test.QuickCheck.State -#ifndef NO_TEMPLATE_HASKELL -import Test.QuickCheck.All -#endif - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs deleted file mode 100644 --- a/Test/QuickCheck/All.hs +++ /dev/null @@ -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 == "") $ 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 diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs deleted file mode 100644 --- a/Test/QuickCheck/Arbitrary.hs +++ /dev/null @@ -1,1437 +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 - , genericShrink -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] - , subterms -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] - , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] - , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b -#endif - , shrinkNothing -- :: a -> [a] - , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] - , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] - , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] - , shrinkIntegral -- :: Integral a => a -> [a] - , shrinkRealFrac -- :: RealFrac a => a -> [a] - , shrinkDecimal -- :: RealFrac a => a -> [a] - -- ** Helper functions for implementing coarbitrary - , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b - , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b - , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b - , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b - , (><) - - -- ** Generators which use arbitrary - , vector -- :: Arbitrary a => Int -> Gen [a] - , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] - , infiniteList -- :: Arbitrary a => Gen [a] - ) - where - --------------------------------------------------------------------------- --- imports - -import Control.Applicative -import Data.Foldable(toList) -import System.Random(Random) -import Test.QuickCheck.Gen -import Test.QuickCheck.Random -import Test.QuickCheck.Gen.Unsafe - -{- -import Data.Generics - ( (:*:)(..) - , (:+:)(..) - , Unit(..) - ) --} - -import Data.Char - ( ord - , isLower - , isUpper - , toLower - , isDigit - , isSpace - , isPrint - , generalCategory - , GeneralCategory(..) - ) - -#ifndef NO_FIXED -import Data.Fixed - ( Fixed - , HasResolution - ) -#endif - -import Data.Ratio - ( Ratio - , (%) - , numerator - , denominator - ) - -import Data.Complex - ( Complex((:+)) ) - -import Data.List - ( sort - , nub - ) - -import Data.Version (Version (..)) - -import Control.Monad - ( liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - ) - -import Data.Int(Int8, Int16, Int32, Int64) -import Data.Word(Word, Word8, Word16, Word32, Word64) -import System.Exit (ExitCode(..)) -import Foreign.C.Types - -#ifndef NO_GENERICS -import GHC.Generics -#endif - -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntSet as IntSet -import qualified Data.IntMap as IntMap -import qualified Data.Sequence as Sequence - -import qualified Data.Monoid as Monoid - -#ifndef NO_TRANSFORMERS -import Data.Functor.Identity -import Data.Functor.Constant -import Data.Functor.Compose -import Data.Functor.Product -#endif - --------------------------------------------------------------------------- --- ** class Arbitrary - --- | Random generation and shrinking of values. --- --- QuickCheck provides @Arbitrary@ instances for most types in @base@, --- except those which incur extra dependencies. --- For a wider range of @Arbitrary@ instances see the --- --- package. -class Arbitrary a where - -- | A generator for values of the given type. - -- - -- It is worth spending time thinking about what sort of test data - -- you want - good generators are often the difference between - -- finding bugs and not finding them. You can use 'sample', - -- 'label' and 'classify' to check the quality of your test data. - -- - -- There is no generic @arbitrary@ implementation included because we don't - -- know how to make a high-quality one. If you want one, consider using the - -- or - -- packages. - -- - -- The - -- goes into detail on how to write good generators. Make sure to look at it, - -- especially if your type is recursive! - arbitrary :: Gen a - - -- | Produces a (possibly) empty list of all the possible - -- immediate shrinks of the given value. - -- - -- The default implementation returns the empty list, so will not try to - -- shrink the value. If your data type has no special invariants, you can - -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising - -- the behaviour of @shrink@ you can often get simpler counterexamples. - -- - -- Most implementations of 'shrink' should try at least three things: - -- - -- 1. Shrink a term to any of its immediate subterms. - -- You can use 'subterms' to do this. - -- - -- 2. Recursively apply 'shrink' to all immediate subterms. - -- You can use 'recursivelyShrink' to do this. - -- - -- 3. Type-specific shrinkings such as replacing a constructor by a - -- simpler constructor. - -- - -- For example, suppose we have the following implementation of binary trees: - -- - -- > data Tree a = Nil | Branch a (Tree a) (Tree a) - -- - -- We can then define 'shrink' as follows: - -- - -- > shrink Nil = [] - -- > shrink (Branch x l r) = - -- > -- shrink Branch to Nil - -- > [Nil] ++ - -- > -- shrink to subterms - -- > [l, r] ++ - -- > -- recursively shrink subterms - -- > [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] - -- - -- There are a couple of subtleties here: - -- - -- * QuickCheck tries the shrinking candidates in the order they - -- appear in the list, so we put more aggressive shrinking steps - -- (such as replacing the whole tree by @Nil@) before smaller - -- ones (such as recursively shrinking the subtrees). - -- - -- * It is tempting to write the last line as - -- @[Branch x' l' r' | x' <- shrink x, l' <- shrink l, r' <- shrink r]@ - -- but this is the /wrong thing/! It will force QuickCheck to shrink - -- @x@, @l@ and @r@ in tandem, and shrinking will stop once /one/ of - -- the three is fully shrunk. - -- - -- There is a fair bit of boilerplate in the code above. - -- We can avoid it with the help of some generic functions. - -- The function 'genericShrink' tries shrinking a term to all of its - -- subterms and, failing that, recursively shrinks the subterms. - -- Using it, we can define 'shrink' as: - -- - -- > shrink x = shrinkToNil x ++ genericShrink x - -- > where - -- > shrinkToNil Nil = [] - -- > shrinkToNil (Branch _ l r) = [Nil] - -- - -- 'genericShrink' is a combination of 'subterms', which shrinks - -- a term to any of its subterms, and 'recursivelyShrink', which shrinks - -- all subterms of a term. These may be useful if you need a bit more - -- control over shrinking than 'genericShrink' gives you. - -- - -- A final gotcha: we cannot define 'shrink' as simply @'shrink' x = Nil:'genericShrink' x@ - -- as this shrinks @Nil@ to @Nil@, and shrinking will go into an - -- infinite loop. - -- - -- If all this leaves you bewildered, you might try @'shrink' = 'genericShrink'@ to begin with, - -- after deriving @Generic@ for your type. However, if your data type has any - -- special invariants, you will need to check that 'genericShrink' can't break those invariants. - shrink :: a -> [a] - shrink _ = [] - --- | Lifting of the 'Arbitrary' class to unary type constructors. -class Arbitrary1 f where - liftArbitrary :: Gen a -> Gen (f a) - liftShrink :: (a -> [a]) -> f a -> [f a] - liftShrink _ _ = [] - -arbitrary1 :: (Arbitrary1 f, Arbitrary a) => Gen (f a) -arbitrary1 = liftArbitrary arbitrary - -shrink1 :: (Arbitrary1 f, Arbitrary a) => f a -> [f a] -shrink1 = liftShrink shrink - --- | Lifting of the 'Arbitrary' class to binary type constructors. -class Arbitrary2 f where - liftArbitrary2 :: Gen a -> Gen b -> Gen (f a b) - liftShrink2 :: (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] - liftShrink2 _ _ _ = [] - -arbitrary2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => Gen (f a b) -arbitrary2 = liftArbitrary2 arbitrary arbitrary - -shrink2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => f a b -> [f a b] -shrink2 = liftShrink2 shrink shrink - -#ifndef NO_GENERICS --- | Shrink a term to any of its immediate subterms, --- and also recursively shrink all subterms. -genericShrink :: (Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] -genericShrink x = subterms x ++ recursivelyShrink x - --- | Recursively shrink all immediate subterms. -recursivelyShrink :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] -recursivelyShrink = map to . grecursivelyShrink . from - -class RecursivelyShrink f where - grecursivelyShrink :: f a -> [f a] - -instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :*: g) where - grecursivelyShrink (x :*: y) = - [x' :*: y | x' <- grecursivelyShrink x] ++ - [x :*: y' | y' <- grecursivelyShrink y] - -instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :+: g) where - grecursivelyShrink (L1 x) = map L1 (grecursivelyShrink x) - grecursivelyShrink (R1 x) = map R1 (grecursivelyShrink x) - -instance RecursivelyShrink f => RecursivelyShrink (M1 i c f) where - grecursivelyShrink (M1 x) = map M1 (grecursivelyShrink x) - -instance Arbitrary a => RecursivelyShrink (K1 i a) where - grecursivelyShrink (K1 x) = map K1 (shrink x) - -instance RecursivelyShrink U1 where - grecursivelyShrink U1 = [] - -instance RecursivelyShrink V1 where - -- The empty type can't be shrunk to anything. - grecursivelyShrink _ = [] - - --- | All immediate subterms of a term. -subterms :: (Generic a, GSubterms (Rep a) a) => a -> [a] -subterms = gSubterms . from - - -class GSubterms f a where - -- | Provides the immediate subterms of a term that are of the same type - -- as the term itself. - -- - -- Requires a constructor to be stripped off; this means it skips through - -- @M1@ wrappers and returns @[]@ on everything that's not `(:*:)` or `(:+:)`. - -- - -- Once a `(:*:)` or `(:+:)` constructor has been reached, this function - -- delegates to `gSubtermsIncl` to return the immediately next constructor - -- available. - gSubterms :: f a -> [a] - -instance GSubterms V1 a where - -- The empty type can't be shrunk to anything. - gSubterms _ = [] - -instance GSubterms U1 a where - gSubterms U1 = [] - -instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :*: g) a where - gSubterms (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r - -instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :+: g) a where - gSubterms (L1 x) = gSubtermsIncl x - gSubterms (R1 x) = gSubtermsIncl x - -instance GSubterms f a => GSubterms (M1 i c f) a where - gSubterms (M1 x) = gSubterms x - -instance GSubterms (K1 i a) b where - gSubterms (K1 _) = [] - - -class GSubtermsIncl f a where - -- | Provides the immediate subterms of a term that are of the same type - -- as the term itself. - -- - -- In contrast to `gSubterms`, this returns the immediate next constructor - -- available. - gSubtermsIncl :: f a -> [a] - -instance GSubtermsIncl V1 a where - -- The empty type can't be shrunk to anything. - gSubtermsIncl _ = [] - -instance GSubtermsIncl U1 a where - gSubtermsIncl U1 = [] - -instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :*: g) a where - gSubtermsIncl (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r - -instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :+: g) a where - gSubtermsIncl (L1 x) = gSubtermsIncl x - gSubtermsIncl (R1 x) = gSubtermsIncl x - -instance GSubtermsIncl f a => GSubtermsIncl (M1 i c f) a where - gSubtermsIncl (M1 x) = gSubtermsIncl x - --- This is the important case: We've found a term of the same type. -instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where - gSubtermsIncl (K1 x) = [x] - -instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where - gSubtermsIncl (K1 _) = [] - -#endif - --- instances - -instance (CoArbitrary a) => Arbitrary1 ((->) a) where - liftArbitrary arbB = promote (`coarbitrary` arbB) - -instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where - arbitrary = arbitrary1 - -instance Arbitrary () where - arbitrary = return () - -instance Arbitrary Bool where - arbitrary = choose (False,True) - shrink True = [False] - shrink False = [] - -instance Arbitrary Ordering where - arbitrary = elements [LT, EQ, GT] - shrink GT = [EQ, LT] - shrink LT = [EQ] - shrink EQ = [] - -instance Arbitrary1 Maybe where - liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] - - liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] - liftShrink _ Nothing = [] - -instance Arbitrary a => Arbitrary (Maybe a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance Arbitrary2 Either where - liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] - - liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] - liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] - -instance Arbitrary a => Arbitrary1 (Either a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink - -instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where - arbitrary = arbitrary2 - shrink = shrink2 - -instance Arbitrary1 [] where - liftArbitrary = listOf - liftShrink = shrinkList - -instance Arbitrary a => Arbitrary [a] where - arbitrary = arbitrary1 - shrink = shrink1 - --- | Shrink a list of values given a shrinking function for individual values. -shrinkList :: (a -> [a]) -> [a] -> [[a]] -shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ] - ++ shrinkOne xs - where - n = length xs - - shrinkOne [] = [] - shrinkOne (x:xs) = [ x':xs | x' <- shr x ] - ++ [ x:xs' | xs' <- shrinkOne xs ] - - removes k n xs - | k > n = [] - | null xs2 = [[]] - | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2) - where - xs1 = take k xs - xs2 = drop k xs - -{- - -- "standard" definition for lists: - shrink [] = [] - shrink (x:xs) = [ xs ] - ++ [ x:xs' | xs' <- shrink xs ] - ++ [ x':xs | x' <- shrink x ] --} - -instance Integral a => Arbitrary (Ratio a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac - -instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where - arbitrary = liftM2 (:+) arbitrary arbitrary - shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ - [ x :+ y' | y' <- shrink y ] - -#ifndef NO_FIXED -instance HasResolution a => Arbitrary (Fixed a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal -#endif - -instance Arbitrary2 (,) where - liftArbitrary2 = liftM2 (,) - liftShrink2 shrA shrB (x, y) = - [ (x', y) | x' <- shrA x ] - ++ [ (x, y') | y' <- shrB y ] - -instance (Arbitrary a) => Arbitrary1 ((,) a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink - -instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where - arbitrary = arbitrary2 - shrink = shrink2 - -instance (Arbitrary a, Arbitrary b, Arbitrary c) - => Arbitrary (a,b,c) - where - arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary - - shrink (x, y, z) = - [ (x', y', z') - | (x', (y', z')) <- shrink (x, (y, z)) ] - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) - => Arbitrary (a,b,c,d) - where - arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary - - shrink (w, x, y, z) = - [ (w', x', y', z') - | (w', (x', (y', z'))) <- shrink (w, (x, (y, z))) ] - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) - => Arbitrary (a,b,c,d,e) - where - arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary - - shrink (v, w, x, y, z) = - [ (v', w', x', y', z') - | (v', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f - ) - => Arbitrary (a,b,c,d,e,f) - where - arbitrary = return (,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - - shrink (u, v, w, x, y, z) = - [ (u', v', w', x', y', z') - | (u', (v', (w', (x', (y', z'))))) <- shrink (u, (v, (w, (x, (y, z))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g - ) - => Arbitrary (a,b,c,d,e,f,g) - where - arbitrary = return (,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - - shrink (t, u, v, w, x, y, z) = - [ (t', u', v', w', x', y', z') - | (t', (u', (v', (w', (x', (y', z')))))) <- shrink (t, (u, (v, (w, (x, (y, z)))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h - ) - => Arbitrary (a,b,c,d,e,f,g,h) - where - arbitrary = return (,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - - shrink (s, t, u, v, w, x, y, z) = - [ (s', t', u', v', w', x', y', z') - | (s', (t', (u', (v', (w', (x', (y', z'))))))) - <- shrink (s, (t, (u, (v, (w, (x, (y, z))))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i - ) - => Arbitrary (a,b,c,d,e,f,g,h,i) - where - arbitrary = return (,,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary - - shrink (r, s, t, u, v, w, x, y, z) = - [ (r', s', t', u', v', w', x', y', z') - | (r', (s', (t', (u', (v', (w', (x', (y', z')))))))) - <- shrink (r, (s, (t, (u, (v, (w, (x, (y, z)))))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j - ) - => Arbitrary (a,b,c,d,e,f,g,h,i,j) - where - arbitrary = return (,,,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - - shrink (q, r, s, t, u, v, w, x, y, z) = - [ (q', r', s', t', u', v', w', x', y', z') - | (q', (r', (s', (t', (u', (v', (w', (x', (y', z'))))))))) - <- shrink (q, (r, (s, (t, (u, (v, (w, (x, (y, z))))))))) ] - --- typical instance for primitive (numerical) types - -instance Arbitrary Integer where - arbitrary = arbitrarySizedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int where - arbitrary = arbitrarySizedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int8 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int16 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int32 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int64 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word where - arbitrary = arbitrarySizedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word8 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word16 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word32 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word64 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Char where - arbitrary = - frequency - [(3, arbitraryASCIIChar), - (1, arbitraryUnicodeChar)] - - shrink c = filter (<. c) $ nub - $ ['a','b','c'] - ++ [ toLower c | isUpper c ] - ++ ['A','B','C'] - ++ ['1','2','3'] - ++ [' ','\n'] - where - a <. b = stamp a < stamp b - stamp a = ( (not (isLower a) - , not (isUpper a) - , not (isDigit a)) - , (not (a==' ') - , not (isSpace a) - , a) - ) - -instance Arbitrary Float where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary Double where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary CChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CShort where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUShort where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CInt where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUInt where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CULong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CPtrdiff where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSize where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CWchar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSigAtomic where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CLLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CULLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CIntPtr where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUIntPtr where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CIntMax where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUIntMax where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -#ifndef NO_CTYPES_CONSTRUCTORS --- The following four types have no Bounded instance, --- so we fake it by discovering the bounds at runtime. -instance Arbitrary CClock where - arbitrary = fmap CClock arbitrary - shrink (CClock x) = map CClock (shrink x) - -instance Arbitrary CTime where - arbitrary = fmap CTime arbitrary - shrink (CTime x) = map CTime (shrink x) - -#ifndef NO_FOREIGN_C_USECONDS -instance Arbitrary CUSeconds where - arbitrary = fmap CUSeconds arbitrary - shrink (CUSeconds x) = map CUSeconds (shrink x) - -instance Arbitrary CSUSeconds where - arbitrary = fmap CSUSeconds arbitrary - shrink (CSUSeconds x) = map CSUSeconds (shrink x) -#endif -#endif - -instance Arbitrary CFloat where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary CDouble where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - --- Arbitrary instances for container types -instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where - arbitrary = fmap Set.fromList arbitrary - shrink = map Set.fromList . shrink . Set.toList -instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where - liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary - liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList -instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where - arbitrary = arbitrary1 - shrink = shrink1 -instance Arbitrary IntSet.IntSet where - arbitrary = fmap IntSet.fromList arbitrary - shrink = map IntSet.fromList . shrink . IntSet.toList -instance Arbitrary1 IntMap.IntMap where - liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary - liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList -instance Arbitrary a => Arbitrary (IntMap.IntMap a) where - arbitrary = arbitrary1 - shrink = shrink1 -instance Arbitrary1 Sequence.Seq where - liftArbitrary = fmap Sequence.fromList . liftArbitrary - liftShrink shr = map Sequence.fromList . liftShrink shr . toList -instance Arbitrary a => Arbitrary (Sequence.Seq a) where - arbitrary = arbitrary1 - shrink = shrink1 - --- Arbitrary instance for Ziplist -instance Arbitrary1 ZipList where - liftArbitrary = fmap ZipList . liftArbitrary - liftShrink shr = map ZipList . liftShrink shr . getZipList -instance Arbitrary a => Arbitrary (ZipList a) where - arbitrary = arbitrary1 - shrink = shrink1 - -#ifndef NO_TRANSFORMERS --- Arbitrary instance for transformers' Functors -instance Arbitrary1 Identity where - liftArbitrary = fmap Identity - liftShrink shr = map Identity . shr . runIdentity -instance Arbitrary a => Arbitrary (Identity a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance Arbitrary2 Constant where - liftArbitrary2 arbA _ = fmap Constant arbA - liftShrink2 shrA _ = fmap Constant . shrA . getConstant -instance Arbitrary a => Arbitrary1 (Constant a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink --- Have to be defined explicitly, as Constant is kind polymorphic -instance Arbitrary a => Arbitrary (Constant a b) where - arbitrary = fmap Constant arbitrary - shrink = map Constant . shrink . getConstant - -instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where - liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) - liftShrink shr (Pair f g) = - [ Pair f' g | f' <- liftShrink shr f ] ++ - [ Pair f g' | g' <- liftShrink shr g ] -instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where - liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary - liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose -instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where - arbitrary = arbitrary1 - shrink = shrink1 -#endif - --- Arbitrary instance for Const -instance Arbitrary2 Const where - liftArbitrary2 arbA _ = fmap Const arbA - liftShrink2 shrA _ = fmap Const . shrA . getConst -instance Arbitrary a => Arbitrary1 (Const a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink --- Have to be defined explicitly, as Const is kind polymorphic -instance Arbitrary a => Arbitrary (Const a b) where - arbitrary = fmap Const arbitrary - shrink = map Const . shrink . getConst - -instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where - arbitrary = WrapMonad <$> arbitrary - shrink (WrapMonad a) = map WrapMonad (shrink a) - -instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where - arbitrary = WrapArrow <$> arbitrary - shrink (WrapArrow a) = map WrapArrow (shrink a) - --- Arbitrary instances for Monoid -instance Arbitrary a => Arbitrary (Monoid.Dual a) where - arbitrary = fmap Monoid.Dual arbitrary - shrink = map Monoid.Dual . shrink . Monoid.getDual - -instance (Arbitrary a, CoArbitrary a) => Arbitrary (Monoid.Endo a) where - arbitrary = fmap Monoid.Endo arbitrary - shrink = map Monoid.Endo . shrink . Monoid.appEndo - -instance Arbitrary Monoid.All where - arbitrary = fmap Monoid.All arbitrary - shrink = map Monoid.All . shrink . Monoid.getAll - -instance Arbitrary Monoid.Any where - arbitrary = fmap Monoid.Any arbitrary - shrink = map Monoid.Any . shrink . Monoid.getAny - -instance Arbitrary a => Arbitrary (Monoid.Sum a) where - arbitrary = fmap Monoid.Sum arbitrary - shrink = map Monoid.Sum . shrink . Monoid.getSum - -instance Arbitrary a => Arbitrary (Monoid.Product a) where - arbitrary = fmap Monoid.Product arbitrary - shrink = map Monoid.Product . shrink . Monoid.getProduct - -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) -instance Arbitrary a => Arbitrary (Monoid.First a) where - arbitrary = fmap Monoid.First arbitrary - shrink = map Monoid.First . shrink . Monoid.getFirst - -instance Arbitrary a => Arbitrary (Monoid.Last a) where - arbitrary = fmap Monoid.Last arbitrary - shrink = map Monoid.Last . shrink . Monoid.getLast -#endif - -#if MIN_VERSION_base(4,8,0) -instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where - arbitrary = fmap Monoid.Alt arbitrary - shrink = map Monoid.Alt . shrink . Monoid.getAlt -#endif -#endif - --- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ -instance Arbitrary Version where - arbitrary = sized $ \n -> - do k <- choose (0, log2 n) - xs <- vectorOf (k+1) arbitrarySizedNatural - return (Version xs []) - where - log2 :: Int -> Int - log2 n | n <= 1 = 0 - | otherwise = 1 + log2 (n `div` 2) - - shrink (Version xs _) = - [ Version xs' [] - | xs' <- shrink xs - , length xs' > 0 - , all (>=0) xs' - ] - -instance Arbitrary QCGen where - arbitrary = MkGen (\g _ -> g) - -instance Arbitrary ExitCode where - arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] - - shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] - shrink _ = [] - - - --- ** Helper functions for implementing arbitrary - --- | Apply a binary function to random arguments. -applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r -applyArbitrary2 f = liftA2 f arbitrary arbitrary - --- | Apply a ternary function to random arguments. -applyArbitrary3 - :: (Arbitrary a, Arbitrary b, Arbitrary c) - => (a -> b -> c -> r) -> Gen r -applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary - --- | Apply a function of arity 4 to random arguments. -applyArbitrary4 - :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) - => (a -> b -> c -> d -> r) -> Gen r -applyArbitrary4 f = applyArbitrary3 (uncurry f) - --- | Generates an integral number. The number can be positive or negative --- and its maximum absolute value depends on the size parameter. -arbitrarySizedIntegral :: Integral a => Gen a -arbitrarySizedIntegral = - sized $ \n -> - inBounds fromInteger (choose (-toInteger n, toInteger n)) - --- | Generates a natural number. The number's maximum value depends on --- the size parameter. -arbitrarySizedNatural :: Integral a => Gen a -arbitrarySizedNatural = - sized $ \n -> - inBounds fromInteger (choose (0, toInteger n)) - -inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a -inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x)) - --- | Generates a fractional number. The number can be positive or negative --- and its maximum absolute value depends on the size parameter. -arbitrarySizedFractional :: Fractional a => Gen a -arbitrarySizedFractional = - sized $ \n -> - let n' = toInteger n in - do b <- choose (1, precision) - a <- choose ((-n') * b, n' * b) - return (fromRational (a % b)) - where - precision = 9999999999999 :: Integer - --- Useful for getting at minBound and maxBound without having to --- fiddle around with asTypeOf. -withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a -withBounds k = k minBound maxBound - --- | Generates an integral number. The number is chosen uniformly from --- the entire range of the type. You may want to use --- 'arbitrarySizedBoundedIntegral' instead. -arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a -arbitraryBoundedIntegral = - withBounds $ \mn mx -> - do n <- choose (toInteger mn, toInteger mx) - return (fromInteger n) - --- | Generates an element of a bounded type. The element is --- chosen from the entire range of the type. -arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a -arbitraryBoundedRandom = choose (minBound,maxBound) - --- | Generates an element of a bounded enumeration. -arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a -arbitraryBoundedEnum = - withBounds $ \mn mx -> - do n <- choose (fromEnum mn, fromEnum mx) - return (toEnum n) - --- | Generates an integral number from a bounded domain. The number is --- chosen from the entire range of the type, but small numbers are --- generated more often than big numbers. Inspired by demands from --- Phil Wadler. -arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a -arbitrarySizedBoundedIntegral = - withBounds $ \mn mx -> - sized $ \s -> - do let bits n | n == 0 = 0 - | otherwise = 1 + bits (n `quot` 2) - k = (toInteger s*(bits mn `max` bits mx `max` 40) `div` 80) - -- computes x `min` (2^k), but avoids computing 2^k - -- if it is too large - x `minexp` k - | bits x < k = x - | otherwise = x `min` (2^k) - -- x `max` (-2^k) - x `maxexpneg` k = -((-x) `minexp` k) - n <- choose (toInteger mn `maxexpneg` k, toInteger mx `minexp` k) - return (fromInteger n) - --- ** Generators for various kinds of character - --- | Generates any Unicode character (but not a surrogate) -arbitraryUnicodeChar :: Gen Char -arbitraryUnicodeChar = - arbitraryBoundedEnum `suchThat` (not . isSurrogate) - where - isSurrogate c = generalCategory c == Surrogate - --- | Generates a random ASCII character (0-127). -arbitraryASCIIChar :: Gen Char -arbitraryASCIIChar = choose ('\0', '\127') - --- | Generates a printable Unicode character. -arbitraryPrintableChar :: Gen Char -arbitraryPrintableChar = arbitrary `suchThat` isPrint - --- ** Helper functions for implementing shrink - --- | Returns no shrinking alternatives. -shrinkNothing :: a -> [a] -shrinkNothing _ = [] - --- | Map a shrink function to another domain. This is handy if your data type --- has special invariants, but is /almost/ isomorphic to some other type. --- --- @ --- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] --- shrinkOrderedList = shrinkMap sort id --- --- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] --- shrinkSet = shrinkMap fromList toList --- @ -shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] -shrinkMap f g = shrinkMapBy f g shrink - --- | Non-overloaded version of `shrinkMap`. -shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] -shrinkMapBy f g shr = map f . shr . g - --- | Shrink an integral number. -shrinkIntegral :: Integral a => a -> [a] -shrinkIntegral x = - nub $ - [ -x - | x < 0, -x > x - ] ++ - [ x' - | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) - ] - where - -- a << b is "morally" abs a < abs b, but taking care of overflow. - a << b = case (a >= 0, b >= 0) of - (True, True) -> a < b - (False, False) -> a > b - (True, False) -> a + b < 0 - (False, True) -> a + b > 0 - --- | Shrink a fraction, preferring numbers with smaller --- numerators or denominators. See also 'shrinkDecimal'. -shrinkRealFrac :: RealFrac a => a -> [a] -shrinkRealFrac x - | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN - | not (2*x+1>x) = 0 : takeWhile ( abs y < abs x) $ - -- Try shrinking to an integer first - map fromInteger (shrink (truncate x) ++ [truncate x]) ++ - -- Shrink the numerator - [fromRational (num' % denom) | num' <- shrink num] ++ - -- Shrink the denominator, and keep the fraction as close - -- to the original as possible, rounding towards zero - [fromRational (truncate (num * denom' % denom) % denom') - | denom' <- shrink denom, denom' /= 0 ] - where - num = numerator (toRational x) - denom = denominator (toRational x) - --- | Shrink a real number, preferring numbers with shorter --- decimal representations. See also 'shrinkRealFrac'. -shrinkDecimal :: RealFrac a => a -> [a] -shrinkDecimal x - | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN - | not (2*x+1>x) = 0 : takeWhile ( instance CoArbitrary MyType --- --- You should only use 'genericCoarbitrary' for data types where --- equality is structural, i.e. if you can't have two different --- representations of the same value. An example where it's not --- safe is sets implemented using binary search trees: the same --- set can be represented as several different trees. --- Here you would have to explicitly define --- @coarbitrary s = coarbitrary (toList s)@. -#else --- | Used for random generation of functions. -#endif -class CoArbitrary a where - -- | Used to generate a function of type @a -> b@. - -- The first argument is a value, the second a generator. - -- You should use 'variant' to perturb the random generator; - -- the goal is that different values for the first argument will - -- lead to different calls to 'variant'. An example will help: - -- - -- @ - -- instance CoArbitrary a => CoArbitrary [a] where - -- coarbitrary [] = 'variant' 0 - -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) - -- @ - coarbitrary :: a -> Gen b -> Gen b -#ifndef NO_GENERICS - default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b - coarbitrary = genericCoarbitrary - --- | Generic CoArbitrary implementation. -genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b -genericCoarbitrary = gCoarbitrary . from - -class GCoArbitrary f where - gCoarbitrary :: f a -> Gen b -> Gen b - -instance GCoArbitrary U1 where - gCoarbitrary U1 = id - -instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where - -- Like the instance for tuples. - gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r - -instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where - -- Like the instance for Either. - gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x - gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x - -instance GCoArbitrary f => GCoArbitrary (M1 i c f) where - gCoarbitrary (M1 x) = gCoarbitrary x - -instance CoArbitrary a => GCoArbitrary (K1 i a) where - gCoarbitrary (K1 x) = coarbitrary x -#endif - -{-# DEPRECATED (><) "Use ordinary function composition instead" #-} --- | Combine two generator perturbing functions, for example the --- results of calls to 'variant' or 'coarbitrary'. -(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) -(><) = (.) - -instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where - coarbitrary f gen = - do xs <- arbitrary - coarbitrary (map f xs) gen - -instance CoArbitrary () where - coarbitrary _ = id - -instance CoArbitrary Bool where - coarbitrary False = variant 0 - coarbitrary True = variant 1 - -instance CoArbitrary Ordering where - coarbitrary GT = variant 0 - coarbitrary EQ = variant 1 - coarbitrary LT = variant 2 - -instance CoArbitrary a => CoArbitrary (Maybe a) where - coarbitrary Nothing = variant 0 - coarbitrary (Just x) = variant 1 . coarbitrary x - -instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where - coarbitrary (Left x) = variant 0 . coarbitrary x - coarbitrary (Right y) = variant 1 . coarbitrary y - -instance CoArbitrary a => CoArbitrary [a] where - coarbitrary [] = variant 0 - coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) - -instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where - coarbitrary r = coarbitrary (numerator r,denominator r) - -#ifndef NO_FIXED -instance HasResolution a => CoArbitrary (Fixed a) where - coarbitrary = coarbitraryReal -#endif - -instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where - coarbitrary (x :+ y) = coarbitrary x . coarbitrary y - -instance (CoArbitrary a, CoArbitrary b) - => CoArbitrary (a,b) - where - coarbitrary (x,y) = coarbitrary x - . coarbitrary y - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) - => CoArbitrary (a,b,c) - where - coarbitrary (x,y,z) = coarbitrary x - . coarbitrary y - . coarbitrary z - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) - => CoArbitrary (a,b,c,d) - where - coarbitrary (x,y,z,v) = coarbitrary x - . coarbitrary y - . coarbitrary z - . coarbitrary v - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) - => CoArbitrary (a,b,c,d,e) - where - coarbitrary (x,y,z,v,w) = coarbitrary x - . coarbitrary y - . coarbitrary z - . coarbitrary v - . coarbitrary w - --- typical instance for primitive (numerical) types - -instance CoArbitrary Integer where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int8 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int16 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int32 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int64 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word8 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word16 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word32 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word64 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Char where - coarbitrary = coarbitrary . ord - -instance CoArbitrary Float where - coarbitrary = coarbitraryReal - -instance CoArbitrary Double where - coarbitrary = coarbitraryReal - --- Coarbitrary instances for container types -instance CoArbitrary a => CoArbitrary (Set.Set a) where - coarbitrary = coarbitrary. Set.toList -instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where - coarbitrary = coarbitrary . Map.toList -instance CoArbitrary IntSet.IntSet where - coarbitrary = coarbitrary . IntSet.toList -instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where - coarbitrary = coarbitrary . IntMap.toList -instance CoArbitrary a => CoArbitrary (Sequence.Seq a) where - coarbitrary = coarbitrary . toList - --- CoArbitrary instance for Ziplist -instance CoArbitrary a => CoArbitrary (ZipList a) where - coarbitrary = coarbitrary . getZipList - -#ifndef NO_TRANSFORMERS --- CoArbitrary instance for transformers' Functors -instance CoArbitrary a => CoArbitrary (Identity a) where - coarbitrary = coarbitrary . runIdentity - -instance CoArbitrary a => CoArbitrary (Constant a b) where - coarbitrary = coarbitrary . getConstant -#endif - --- CoArbitrary instance for Const -instance CoArbitrary a => CoArbitrary (Const a b) where - coarbitrary = coarbitrary . getConst - --- CoArbitrary instances for Monoid -instance CoArbitrary a => CoArbitrary (Monoid.Dual a) where - coarbitrary = coarbitrary . Monoid.getDual - -instance (Arbitrary a, CoArbitrary a) => CoArbitrary (Monoid.Endo a) where - coarbitrary = coarbitrary . Monoid.appEndo - -instance CoArbitrary Monoid.All where - coarbitrary = coarbitrary . Monoid.getAll - -instance CoArbitrary Monoid.Any where - coarbitrary = coarbitrary . Monoid.getAny - -instance CoArbitrary a => CoArbitrary (Monoid.Sum a) where - coarbitrary = coarbitrary . Monoid.getSum - -instance CoArbitrary a => CoArbitrary (Monoid.Product a) where - coarbitrary = coarbitrary . Monoid.getProduct - -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) -instance CoArbitrary a => CoArbitrary (Monoid.First a) where - coarbitrary = coarbitrary . Monoid.getFirst - -instance CoArbitrary a => CoArbitrary (Monoid.Last a) where - coarbitrary = coarbitrary . Monoid.getLast -#endif - -#if MIN_VERSION_base(4,8,0) -instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where - coarbitrary = coarbitrary . Monoid.getAlt -#endif -#endif - -instance CoArbitrary Version where - coarbitrary (Version a b) = coarbitrary (a, b) - --- ** Helpers for implementing coarbitrary - --- | A 'coarbitrary' implementation for integral numbers. -coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b -coarbitraryIntegral = variant - --- | A 'coarbitrary' implementation for real numbers. -coarbitraryReal :: Real a => a -> Gen b -> Gen b -coarbitraryReal x = coarbitrary (toRational x) - --- | 'coarbitrary' helper for lazy people :-). -coarbitraryShow :: Show a => a -> Gen b -> Gen b -coarbitraryShow x = coarbitrary (show x) - --- | A 'coarbitrary' implementation for enums. -coarbitraryEnum :: Enum a => a -> Gen b -> Gen b -coarbitraryEnum = variant . fromEnum - --------------------------------------------------------------------------- --- ** arbitrary generators - --- these are here and not in Gen because of the Arbitrary class constraint - --- | Generates a list of a given length. -vector :: Arbitrary a => Int -> Gen [a] -vector k = vectorOf k arbitrary - --- | Generates an ordered list. -orderedList :: (Ord a, Arbitrary a) => Gen [a] -orderedList = sort `fmap` arbitrary - --- | Generates an infinite list. -infiniteList :: Arbitrary a => Gen [a] -infiniteList = infiniteListOf arbitrary - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs deleted file mode 100644 --- a/Test/QuickCheck/Exception.hs +++ /dev/null @@ -1,115 +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 :: E.SomeException -> Maybe AnException -#if MIN_VERSION_base(4,7,0) - notAsync e = case E.fromException e of - Just (E.SomeAsyncException _) -> Nothing - Nothing -> Just e -#else - notAsync e = case E.fromException e :: Maybe E.AsyncException of - Just _ -> Nothing - Nothing -> 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. diff --git a/Test/QuickCheck/Features.hs b/Test/QuickCheck/Features.hs deleted file mode 100644 --- a/Test/QuickCheck/Features.hs +++ /dev/null @@ -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 --- [] --- [] --- --- *** Found example of count x xs == 1 --- 0 --- [0] --- [] --- --- *** Found example of count x xs >= 2 --- 5 --- [5,5] --- [5] --- --- +++ OK, passed 100 tests: --- 78% count x xs == 0 --- 21% count x xs == 1 --- 1% count x xs >= 2 - - -labelledExamples :: Testable prop => prop -> IO () -labelledExamples prop = labelledExamplesWith stdArgs prop - --- | A variant of 'labelledExamples' that takes test arguments. -labelledExamplesWith :: Testable prop => Args -> prop -> IO () -labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return () - --- | A variant of 'labelledExamples' that returns a result. -labelledExamplesResult :: Testable prop => prop -> IO Result -labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop - --- | A variant of 'labelledExamples' that takes test arguments and returns a result. -labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result -labelledExamplesWithResult args prop = - withState args $ \state -> do - let - loop :: Set String -> State -> IO Result - loop feats state = withNullTerminal $ \nullterm -> do - res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) - let feats' = features (failingLabels res) (failingClasses res) - case res of - Failure{reason = "New feature found"} -> do - putLine (terminal state) $ - "*** Found example of " ++ - intercalate ", " (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 diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs deleted file mode 100644 --- a/Test/QuickCheck/Function.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE TypeOperators, GADTs, CPP #-} -#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! Falsifiable (after 3 tests and 134 shrinks): --- {"elephant"->1, "monkey"->1, _->0} --- --- To generate random values of type @'Fun' a b@, --- you must have an instance @'Function' a@. --- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, --- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. --- See the @'Function' [a]@ instance for an example of the latter. -module Test.QuickCheck.Function - ( Fun(..) - , applyFun - , apply - , applyFun2 - , applyFun3 - , (:->) - , Function(..) - , functionMap - , functionShow - , functionIntegral - , functionRealFrac - , functionBoundedEnum -#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 - --- | The basic building block for 'Function' instances. --- Provides a 'Function' instance by mapping to and from a type that --- already has a 'Function' instance. -functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) -functionMap = functionMapWith function - -functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) -functionMapWith function g h f = Map g h (function (\b -> f (h b))) - -instance Function () where - function f = Unit (f ()) - -instance Function a => Function (Const a b) where - function = functionMap getConst Const - -instance Function a => Function (Identity a) where - function = functionMap runIdentity Identity - -instance (Function a, Function b) => Function (a,b) where - function = functionPairWith function function - -functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) -functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) - -instance (Function a, Function b) => Function (Either a b) where - function = functionEitherWith function function - -functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) -functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (f . Right) - --- tuple convenience instances - -instance (Function a, Function b, Function c) => Function (a,b,c) where - function = functionMap (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c)) - -instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where - function = functionMap (\(a,b,c,d) -> (a,(b,c,d))) (\(a,(b,c,d)) -> (a,b,c,d)) - -instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where - function = functionMap (\(a,b,c,d,e) -> (a,(b,c,d,e))) (\(a,(b,c,d,e)) -> (a,b,c,d,e)) - -instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where - function = functionMap (\(a,b,c,d,e,f) -> (a,(b,c,d,e,f))) (\(a,(b,c,d,e,f)) -> (a,b,c,d,e,f)) - -instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where - function = functionMap (\(a,b,c,d,e,f,g) -> (a,(b,c,d,e,f,g))) (\(a,(b,c,d,e,f,g)) -> (a,b,c,d,e,f,g)) - --- other instances - -instance Function a => Function [a] where - function = functionMap g h - where - g [] = Left () - g (x:xs) = Right (x,xs) - - h (Left _) = [] - h (Right (x,xs)) = x:xs - -instance Function a => Function (Maybe a) where - function = functionMap g h - where - g Nothing = Left () - g (Just x) = Right x - - h (Left _) = Nothing - h (Right x) = Just x - -instance Function Bool where - function = functionMap g h - where - g False = Left () - g True = Right () - - h (Left _) = False - h (Right _) = True - -instance Function Integer where - function = functionMap gInteger hInteger - where - gInteger n | n < 0 = Left (gNatural (abs n - 1)) - | otherwise = Right (gNatural n) - - hInteger (Left ws) = -(hNatural ws + 1) - hInteger (Right ws) = hNatural ws - - gNatural 0 = [] - gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256) - - hNatural [] = 0 - hNatural (w:ws) = fromIntegral w + 256 * hNatural ws - -instance Function Int where - function = functionIntegral - -instance Function Word where - function = functionIntegral - -instance Function Char where - function = functionMap ord chr - -instance Function Float where - function = functionRealFrac - -instance Function Double where - function = functionRealFrac - --- instances for assorted types in the base package - -instance Function Ordering where - function = functionMap g h - where - g LT = Left False - g EQ = Left True - g GT = Right () - - h (Left False) = LT - h (Left True) = EQ - h (Right _) = GT - -instance (Integral a, Function a) => Function (Ratio a) where - function = functionMap g h - where - g r = (numerator r, denominator r) - h (n, d) = n % d - -#ifndef NO_FIXED -instance HasResolution a => Function (Fixed a) where - function = functionRealFrac -#endif - -instance (RealFloat a, Function a) => Function (Complex a) where - function = functionMap g h - where - g (x :+ y) = (x, y) - h (x, y) = x :+ y - -instance (Ord a, Function a) => Function (Set.Set a) where - function = functionMap Set.toList Set.fromList - -instance (Ord a, Function a, Function b) => Function (Map.Map a b) where - function = functionMap Map.toList Map.fromList - -instance Function IntSet.IntSet where - function = functionMap IntSet.toList IntSet.fromList - -instance Function a => Function (IntMap.IntMap a) where - function = functionMap IntMap.toList IntMap.fromList - -instance Function a => Function (Sequence.Seq a) where - function = functionMap toList Sequence.fromList - -instance Function Int8 where - function = functionBoundedEnum - -instance Function Int16 where - function = functionIntegral - -instance Function Int32 where - function = functionIntegral - -instance Function Int64 where - function = functionIntegral - -instance Function Word8 where - function = functionBoundedEnum - -instance Function Word16 where - function = functionIntegral - -instance Function Word32 where - function = functionIntegral - -instance Function Word64 where - function = functionIntegral - --- instances for Data.Monoid newtypes - -instance Function a => Function (Monoid.Dual a) where - function = functionMap Monoid.getDual Monoid.Dual - -instance Function Monoid.All where - function = functionMap Monoid.getAll Monoid.All - -instance Function Monoid.Any where - function = functionMap Monoid.getAny Monoid.Any - -instance Function a => Function (Monoid.Sum a) where - function = functionMap Monoid.getSum Monoid.Sum - -instance Function a => Function (Monoid.Product a) where - function = functionMap Monoid.getProduct Monoid.Product - -instance Function a => Function (Monoid.First a) where - function = functionMap Monoid.getFirst Monoid.First - -instance Function a => Function (Monoid.Last a) where - function = functionMap Monoid.getLast Monoid.Last - -#if MIN_VERSION_base(4,8,0) -instance Function (f a) => Function (Monoid.Alt f a) where - function = functionMap Monoid.getAlt Monoid.Alt -#endif - --- poly instances - -instance Function A where - function = functionMap unA A - -instance Function B where - function = functionMap unB B - -instance Function C where - function = functionMap unC C - -instance Function OrdA where - function = functionMap unOrdA OrdA - -instance Function OrdB where - function = functionMap unOrdB OrdB - -instance Function OrdC where - function = functionMap unOrdC OrdC - --- instance Arbitrary - -instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where - arbitrary = function `fmap` arbitrary - shrink = shrinkFun shrink - --------------------------------------------------------------------------- --- generic function instances - -#ifndef NO_GENERICS --- | Generic 'Function' implementation. -genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) -genericFunction = functionMapWith gFunction from to - -class GFunction f where - gFunction :: (f a -> b) -> (f a :-> b) - -instance GFunction U1 where - gFunction = functionMap (\U1 -> ()) (\() -> U1) - -instance (GFunction f, GFunction g) => GFunction (f :*: g) where - gFunction = functionMapWith (functionPairWith gFunction gFunction) g h - where - g (x :*: y) = (x, y) - h (x, y) = x :*: y - -instance (GFunction f, GFunction g) => GFunction (f :+: g) where - gFunction = functionMapWith (functionEitherWith gFunction gFunction) g h - where - g (L1 x) = Left x - g (R1 x) = Right x - h (Left x) = L1 x - h (Right x) = R1 x - -instance GFunction f => GFunction (M1 i c f) where - gFunction = functionMapWith gFunction (\(M1 x) -> x) M1 - -instance Function a => GFunction (K1 i a) where - gFunction = functionMap (\(K1 x) -> x) K1 -#endif - --------------------------------------------------------------------------- --- shrinking - -shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] -shrinkFun shr (Pair p) = - [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] - where - pair Nil = Nil - pair p = Pair p - -shrinkFun shr (p :+: q) = - [ p .+. Nil | not (isNil q) ] ++ - [ Nil .+. q | not (isNil p) ] ++ - [ p .+. q' | q' <- shrinkFun shr q ] ++ - [ p' .+. q | p' <- shrinkFun shr p ] - where - isNil :: (a :-> b) -> Bool - isNil Nil = True - isNil _ = False - - Nil .+. Nil = Nil - p .+. q = p :+: q - -shrinkFun shr (Unit c) = - [ Nil ] ++ - [ Unit c' | c' <- shr c ] - -shrinkFun shr (Table xys) = - [ table xys' | xys' <- shrinkList shrXy xys ] - where - shrXy (x,y) = [(x,y') | y' <- shr y] - - table [] = Nil - table xys = Table xys - -shrinkFun shr Nil = - [] - -shrinkFun shr (Map g h p) = - [ mapp g h p' | p' <- shrinkFun shr p ] - where - mapp g h Nil = Nil - mapp g h p = Map g h p - --------------------------------------------------------------------------- --- the Fun modifier - --- | Generation of random shrinkable, showable functions. --- --- To generate random values of type @'Fun' a b@, --- you must have an instance @'Function' a@. --- --- See also 'applyFun', and 'Fn' with GHC >= 7.8. -data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) -data Shrunk = Shrunk | NotShrunk deriving Eq - -instance Functor (Fun a) where - fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g) - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 --- | A modifier for testing functions. --- --- > prop :: Fun String Integer -> Bool --- > prop (Fn f) = f "banana" == f "monkey" --- > || f "banana" == f "elephant" -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn :: (a -> b) -> Fun a b -#endif -pattern Fn f <- (applyFun -> f) - --- | A modifier for testing binary functions. --- --- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool --- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c -#endif -pattern Fn2 f <- (applyFun2 -> f) - --- | A modifier for testing ternary functions. -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d -#endif -pattern Fn3 f <- (applyFun3 -> f) -#endif - -mkFun :: (a :-> b) -> b -> Fun a b -mkFun p d = Fun (p, d, NotShrunk) (abstract p d) - --- | Alias to 'applyFun'. -apply :: Fun a b -> (a -> b) -apply = applyFun - --- | Extracts the value of a function. --- --- 'Fn' is the pattern equivalent of this function. --- --- > prop :: Fun String Integer -> Bool --- > prop f = applyFun f "banana" == applyFun f "monkey" --- > || applyFun f "banana" == applyFun f "elephant" -applyFun :: Fun a b -> (a -> b) -applyFun (Fun _ f) = f - --- | Extracts the value of a binary function. --- --- 'Fn2' is the pattern equivalent of this function. --- --- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool --- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] --- -applyFun2 :: Fun (a, b) c -> (a -> b -> c) -applyFun2 (Fun _ f) a b = f (a, b) - --- | Extracts the value of a ternary function. 'Fn3' is the --- pattern equivalent of this function. -applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) -applyFun3 (Fun _ f) a b c = f (a, b, c) - -instance (Show a, Show b) => Show (Fun a b) where - show (Fun (_, _, NotShrunk) _) = "" - show (Fun (p, d, Shrunk) _) = showFunction p (Just d) - -instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where - arbitrary = - do p <- arbitrary - d <- arbitrary - return (mkFun p d) - - shrink (Fun (p, d, s) f) = - [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ - [ Fun (p, d, Shrunk) f | s == NotShrunk ] - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs deleted file mode 100644 --- a/Test/QuickCheck/Gen.hs +++ /dev/null @@ -1,257 +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 - --------------------------------------------------------------------------- --- ** Generator type - --- | A generator for values of type @a@. --- --- The third-party package --- --- provides a monad transformer version of @GenT@. -newtype Gen a = MkGen{ - unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. - -- If you just want to get a random value out, consider using 'generate'. - } - -instance Functor Gen where - fmap f (MkGen h) = - MkGen (\r n -> f (h r n)) - -instance Applicative Gen where - pure = return - gf <*> gx = gf >>= \f -> fmap f gx - -instance Monad Gen where - return x = - MkGen (\_ _ -> x) - - MkGen m >>= k = - MkGen (\r n -> - case split r of - (r1, r2) -> - let MkGen m' = k (m r1 n) - in m' r2 n - ) - -instance MonadFix Gen where - mfix f = - MkGen $ \r n -> - let a = unGen (f a) r n - in a - --------------------------------------------------------------------------- --- ** Primitive generator combinators - --- | Modifies a generator using an integer seed. -variant :: Integral n => n -> Gen a -> Gen a -variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n) - --- | Used to construct generators that depend on the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = sized $ \n -> --- > do k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'getSize'. -sized :: (Int -> Gen a) -> Gen a -sized f = MkGen (\r n -> let MkGen m = f n in m r n) - --- | Returns the size parameter. Used to construct generators that depend on --- the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = do --- > n <- getSize --- > k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'sized'. -getSize :: Gen Int -getSize = sized pure - --- | Overrides the size parameter. Returns a generator which uses --- the given size instead of the runtime-size parameter. -resize :: Int -> Gen a -> Gen a -resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" -resize n (MkGen g) = MkGen (\r _ -> g r n) - --- | Adjust the size parameter, by transforming it with the given --- function. -scale :: (Int -> Int) -> Gen a -> Gen a -scale f g = sized (\n -> resize (f n) g) - --- | Generates a random element in the given inclusive range. -choose :: Random a => (a,a) -> Gen a -choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) - --- | Generates a random element over the natural range of `a`. -chooseAny :: Random a => Gen a -chooseAny = MkGen (\r _ -> let (x,_) = random r in x) - --- | Run a generator. The size passed to the generator is always 30; --- if you want another size then you should explicitly use 'resize'. -generate :: Gen a -> IO a -generate (MkGen g) = - do r <- newQCGen - return (g r 30) - --- | Generates some example values. -sample' :: Gen a -> IO [a] -sample' g = - generate (sequence [ resize n g | n <- [0,2..20] ]) - --- | Generates some example values and prints them to 'stdout'. -sample :: Show a => Gen a -> IO () -sample g = - do cases <- sample' g - mapM_ print cases - --------------------------------------------------------------------------- --- ** Common generator combinators - --- | Generates a value that satisfies a predicate. -suchThat :: Gen a -> (a -> Bool) -> Gen a -gen `suchThat` p = - do mx <- gen `suchThatMaybe` p - case mx of - Just x -> return x - Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) - --- | Generates a value for which the given function returns a 'Just', and then --- applies the function. -suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b -gen `suchThatMap` f = - fmap fromJust $ fmap f gen `suchThat` isJust - --- | Tries to generate a value that satisfies a predicate. --- If it fails to do so after enough attempts, returns @Nothing@. -suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) -gen `suchThatMaybe` p = sized (\n -> try n (2*n)) - where - try m n - | m > n = return Nothing - | otherwise = do - x <- resize m gen - if p x then return (Just x) else try (m+1) n - --- | Randomly uses one of the given generators. The input list --- must be non-empty. -oneof :: [Gen a] -> Gen a -oneof [] = error "QuickCheck.oneof used with empty list" -oneof gs = choose (0,length gs - 1) >>= (gs !!) - --- | Chooses one of the given generators, with a weighted random distribution. --- The input list must be non-empty. -frequency :: [(Int, Gen a)] -> Gen a -frequency [] = error "QuickCheck.frequency used with empty list" -frequency xs0 = choose (1, tot) >>= (`pick` xs0) - where - tot = sum (map fst xs0) - - pick n ((k,x):xs) - | n <= k = x - | otherwise = pick (n-k) xs - pick _ _ = error "QuickCheck.pick used with empty list" - --- | Generates one of the given values. The input list must be non-empty. -elements :: [a] -> Gen a -elements [] = error "QuickCheck.elements used with empty list" -elements xs = (xs !!) `fmap` choose (0, length xs - 1) - --- | Generates a random subsequence of the given list. -sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> choose (False, True)) xs - --- | Generates a random permutation of the given list. -shuffle :: [a] -> Gen [a] -shuffle xs = do - ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) - return (map snd (sortBy (comparing fst) (zip ns xs))) - --- | Takes a list of elements of increasing size, and chooses --- among an initial segment of the list. The size of this initial --- segment increases with the size parameter. --- The input list must be non-empty. -growingElements :: [a] -> Gen a -growingElements [] = error "QuickCheck.growingElements used with empty list" -growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) - where - k = length xs - mx = 100 - log' = round . log . toDouble - size n = (log' n + 1) * k `div` log' mx - toDouble = fromIntegral :: Int -> Double - -{- WAS: -growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) - where - k = length xs --} - --- | Generates a list of random length. The maximum length depends on the --- size parameter. -listOf :: Gen a -> Gen [a] -listOf gen = sized $ \n -> - do k <- choose (0,n) - vectorOf k gen - --- | Generates a non-empty list of random length. The maximum length --- depends on the size parameter. -listOf1 :: Gen a -> Gen [a] -listOf1 gen = sized $ \n -> - do k <- choose (1,1 `max` n) - vectorOf k gen - --- | Generates a list of the given length. -vectorOf :: Int -> Gen a -> Gen [a] -vectorOf = replicateM - --- | Generates an infinite list. -infiniteListOf :: Gen a -> Gen [a] -infiniteListOf gen = sequence (repeat gen) - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Gen/Unsafe.hs b/Test/QuickCheck/Gen/Unsafe.hs deleted file mode 100644 --- a/Test/QuickCheck/Gen/Unsafe.hs +++ /dev/null @@ -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 diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs deleted file mode 100644 --- a/Test/QuickCheck/Modifiers.hs +++ /dev/null @@ -1,510 +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(..) - , NonZero(..) - , NonNegative(..) - , 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! Falsifiable (after 1 test and 14 shrinks): --- "bbbbbbbbbb" ++ ... -data InfiniteList a = - InfiniteList { - getInfiniteList :: [a], - infiniteListInternalData :: InfiniteListInternalData a } - --- Uses a similar trick to Test.QuickCheck.Function: --- the Arbitrary instance generates an infinite list, which is --- reduced to a finite prefix by shrinking. We use discard to --- check that nothing coming after the finite prefix is used --- (see infiniteListFromData). -data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] - -infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a -infiniteListFromData info@(Infinite xs) = InfiniteList xs info -infiniteListFromData info@(FinitePrefix xs) = - InfiniteList (xs ++ discard) info - -instance Show a => Show (InfiniteList a) where - showsPrec _ (InfiniteList _ (Infinite _)) = - ("" ++) - showsPrec n (InfiniteList _ (FinitePrefix xs)) = - (if n > 10 then ('(':) else id) . - showsPrec 0 xs . - (" ++ ..." ++) . - (if n > 10 then (')':) else id) - -instance Arbitrary a => Arbitrary (InfiniteList a) where - arbitrary = fmap infiniteListFromData arbitrary - shrink (InfiniteList _ info) = - map infiniteListFromData (shrink info) - -instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where - arbitrary = fmap Infinite infiniteList - shrink (Infinite xs) = - [FinitePrefix (take n xs) | n <- map (2^) [0..]] - shrink (FinitePrefix xs) = - map FinitePrefix (shrink xs) - --------------------------------------------------------------------------- --- | @Sorted xs@: guarantees that xs is sorted. -newtype SortedList a = Sorted {getSorted :: [a]} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor SortedList where - fmap f (Sorted x) = Sorted (map f x) - -instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where - arbitrary = fmap (Sorted . sort) arbitrary - - shrink (Sorted xs) = - [ Sorted xs' - | xs' <- map sort (shrink xs) - ] - --------------------------------------------------------------------------- --- | @Positive x@: guarantees that @x \> 0@. -newtype Positive a = Positive {getPositive :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Positive where - fmap f (Positive x) = Positive (f x) - -instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where - arbitrary = - ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0 - where gt0 (Positive x) = x > 0 - - shrink (Positive x) = - [ Positive x' - | x' <- shrink x - , x' > 0 - ] - --------------------------------------------------------------------------- --- | @NonZero x@: guarantees that @x \/= 0@. -newtype NonZero a = NonZero {getNonZero :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#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 = - (frequency - -- why is this distrbution like this? - [ (5, (NonNegative . abs) `fmap` arbitrary) - , (1, return (NonNegative 0)) - ] - ) `suchThat` ge0 - where ge0 (NonNegative x) = x >= 0 - - shrink (NonNegative x) = - [ NonNegative x' - | x' <- shrink x - , x' >= 0 - ] - --------------------------------------------------------------------------- --- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small --- range. @Large Int@ gives you values drawn from the entire range instead. -newtype Large a = Large {getLarge :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum, 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. diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs deleted file mode 100644 --- a/Test/QuickCheck/Monadic.hs +++ /dev/null @@ -1,277 +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 \"\". --} -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 - fail = fail_ - -#ifndef NO_MONADFAIL -instance Monad m => Fail.MonadFail (PropertyM m) where - fail = fail_ -#endif - -#ifndef NO_TRANSFORMERS -instance MonadTrans PropertyM where - lift = run - -instance MonadIO m => MonadIO (PropertyM m) where - liftIO = run . liftIO -#endif - -stop :: (Testable prop, Monad m) => prop -> PropertyM m a -stop p = MkPropertyM (\_k -> return (return (property p))) - --- should think about strictness/exceptions here --- assert :: Testable prop => prop -> PropertyM m () --- | Allows embedding non-monadic properties into monadic ones. -assert :: Monad m => Bool -> PropertyM m () -assert True = return () -assert False = fail "Assertion failed" - --- should think about strictness/exceptions here --- | Tests preconditions. Unlike 'assert' this does not cause the --- property to fail, rather it discards them just like using the --- implication combinator 'Test.QuickCheck.Property.==>'. --- --- This allows representing the --- --- > {p} x ← e{q} --- --- as --- --- @ --- pre p --- x \<- run e --- assert q --- @ --- -pre :: Monad m => Bool -> PropertyM m () -pre True = return () -pre False = stop rejected - --- should be called lift? --- | The lifting operation of the property monad. Allows embedding --- monadic\/'IO'-actions in properties: --- --- @ --- log :: Int -> IO () --- --- prop_foo n = monadicIO $ do --- run (log n) --- -- ... --- @ -run :: Monad m => m a -> PropertyM m a -run m = MkPropertyM (liftM (m >>=) . promote) - --- | Quantification in a monadic property, fits better with --- /do-notation/ than 'forAllM'. --- __Note__: values generated by 'pick' do not shrink. -pick :: (Monad m, Show a) => Gen a -> PropertyM m a -pick gen = MkPropertyM $ \k -> - do a <- gen - mp <- k a - return (do p <- mp - return (forAll (return a) (const p))) - --- | The --- --- > wp(x ← e, p) --- --- can be expressed as in code as @wp e (\\x -> p)@. -wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b -wp m k = run m >>= k - --- | Quantification in monadic properties to 'pick', with a notation similar to --- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. - -forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b -forAllM gen k = pick gen >>= k - --- | Allows making observations about the test data: --- --- @ --- monitor ('collect' e) --- @ --- --- collects the distribution of value of @e@. --- --- @ --- monitor ('counterexample' "Failure!") --- @ --- --- Adds @"Failure!"@ to the counterexamples. -monitor :: Monad m => (Property -> Property) -> PropertyM m () -monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) - --- run functions - -monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property -monadic runner m = property (fmap runner (monadic' m)) - -monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) -monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) - --- | Runs the property monad for 'IO'-computations. --- --- @ --- prop_cat msg = monadicIO $ do --- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) --- --- pre ('System.Exit.ExitSuccess' == exitCode) --- --- assert (stdout == msg) --- @ --- --- >>> quickCheck prop_cat --- +++ OK, passed 100 tests. --- -monadicIO :: Testable a => PropertyM IO a -> Property -monadicIO = monadic ioProperty - -#ifndef NO_ST_MONAD --- | Runs the property monad for 'ST'-computations. --- --- @ --- -- Your mutable sorting algorithm here --- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) --- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' --- --- prop_sortST xs = monadicST $ do --- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) --- assert ('Data.Vector.toList' sorted == sort xs) --- @ --- --- >>> quickCheck prop_sortST --- +++ OK, passed 100 tests. --- -monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property -monadicST m = property (runSTGen (monadic' m)) - -runSTGen :: (forall s. Gen (ST s a)) -> Gen a -runSTGen f = do - Capture eval <- capture - return (runST (eval f)) -#endif - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs deleted file mode 100644 --- a/Test/QuickCheck/Poly.hs +++ /dev/null @@ -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. diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs deleted file mode 100644 --- a/Test/QuickCheck/Property.hs +++ /dev/null @@ -1,925 +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 - --- | 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 Bool where - property = property . liftBool - -instance Testable Result where - property = MkProperty . return . MkProp . protectResults . return - -instance Testable Prop where - property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r - -instance Testable prop => Testable (Gen prop) where - property mp = MkProperty $ do p <- mp; unProperty (again p) - -instance Testable Property where - property (MkProperty mp) = MkProperty $ do p <- mp; unProperty (property p) - --- | 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 = forAllShrink arbitrary shrink f - --- ** Exception handling -protect :: (AnException -> a) -> IO a -> IO a -protect f x = either f id `fmap` tryEvaluateIO x - --------------------------------------------------------------------------- --- ** Type Prop - -newtype Prop = MkProp{ unProp :: Rose Result } - --- ** type Rose - -data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) --- Only use IORose if you know that the argument is not going to throw an exception! --- Otherwise, try ioRose. -ioRose :: IO (Rose Result) -> Rose Result -ioRose = IORose . protectRose - -joinRose :: Rose (Rose a) -> Rose a -joinRose (IORose rs) = IORose (fmap joinRose rs) -joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) -joinRose (MkRose (MkRose x ts) tts) = - -- first shrinks outer quantification; makes most sense - MkRose x (map joinRose tts ++ ts) - -- first shrinks inner quantification: terrible - --MkRose x (ts ++ map joinRose tts) - -instance Functor Rose where - -- f must be total - fmap f (IORose rs) = IORose (fmap (fmap f) rs) - fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] - -instance Applicative Rose where - pure = return - -- f must be total - (<*>) = liftM2 ($) - -instance Monad Rose where - return x = MkRose x [] - -- k must be total - m >>= k = joinRose (fmap k m) - --- | Execute the "IORose" bits of a rose tree, returning a tree --- constructed by MkRose. -reduceRose :: Rose Result -> IO (Rose Result) -reduceRose r@(MkRose _ _) = return r -reduceRose (IORose m) = m >>= reduceRose - --- | Apply a function to the outermost MkRose constructor of a rose tree. --- The function must be total! -onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a -onRose f (MkRose x rs) = f x rs -onRose f (IORose m) = IORose (fmap (onRose f) m) - --- | Wrap a rose tree in an exception handler. -protectRose :: IO (Rose Result) -> IO (Rose Result) -protectRose = protect (return . exception "Exception") - --- | Wrap all the Results in a rose tree in exception handlers. -protectResults :: Rose Result -> Rose Result -protectResults = onRose $ \x rs -> - IORose $ do - y <- protectResult (return x) - return (MkRose y (map protectResults rs)) - --- ** Result type - --- | Different kinds of callbacks -data Callback - = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test - | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case -data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator - | NotCounterexample -- ^ Not affected by the 'verbose' combinator - --- | The result of a single test. -data Result - = MkResult - { ok :: Maybe Bool - -- ^ result of the test case; Nothing = discard - , expect :: Bool - -- ^ indicates what the expected result of the property is - , reason :: String - -- ^ a message indicating what went wrong - , theException :: Maybe AnException - -- ^ the exception thrown, if any - , abort :: Bool - -- ^ if True, the test should not be repeated - , 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 = "Falsifiable" } - -mapResult :: Testable prop => (Result -> Result) -> prop -> Property -mapResult f = mapRoseResult (protectResults . fmap f) - -mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property -mapTotalResult f = mapRoseResult (fmap f) - --- f here mustn't throw an exception (rose tree invariant). -mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property -mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) - -mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property -mapProp f = MkProperty . fmap f . unProperty . property - --------------------------------------------------------------------------- --- ** Property combinators - --- | 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 = - s `deepseq` - 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 = - s `deepseq` - mapTotalResult $ - \res -> res { classes = s:classes res } - --- | Checks that at least the given proportion of /successful/ test --- cases belong to the given class. Discarded tests (i.e. ones --- with a false precondition) do not affect coverage. --- --- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but --- the property does /not/ fail. To make the property fail, use 'checkCoverage'. --- --- For example: --- --- > prop_sorted_sort :: [Int] -> Property --- > prop_sorted_sort xs = --- > sorted xs ==> --- > cover 50 (length xs > 1) "non-trivial" $ --- > sort xs === xs --- --- >>> quickCheck prop_sorted_sort --- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). --- --- Only 26% non-trivial, but expected 50% -cover :: Testable prop => - Double -- ^ The required percentage (0-100) of test cases. - -> Bool -- ^ @True@ if the test case belongs to the class. - -> String -- ^ Label for the test case class. - -> prop -> Property -cover p x s = mapTotalResult f . classify x s - where - f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res } - --- | Collects information about test case distribution into a table. --- The arguments to 'tabulate' are the table's name and a list of values --- associated with the current test case. After testing, QuickCheck prints the --- frequency of all collected values. The frequencies are expressed as a --- percentage of the total number of values collected. --- --- You should prefer 'tabulate' to 'label' when each test case is associated --- with a varying number of values. Here is a (not terribly useful) example, --- where the test data is a list of integers and we record all values that --- occur in the list: --- --- > prop_sorted_sort :: [Int] -> Property --- > prop_sorted_sort xs = --- > sorted xs ==> --- > tabulate "List elements" (map show xs) $ --- > sort xs === xs --- --- >>> quickCheck prop_sorted_sort --- +++ OK, passed 100 tests; 1684 discarded. --- --- List elements (109 in total): --- 3.7% 0 --- 3.7% 17 --- 3.7% 2 --- 3.7% 6 --- 2.8% -6 --- 2.8% -7 --- --- Here is a more useful example. We are testing a chatroom, where the user can --- log in, log out, or send a message: --- --- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) --- > instance Arbitrary Command where ... --- --- There are some restrictions on command sequences; for example, the user must --- log in before doing anything else. The function @valid :: [Command] -> Bool@ --- checks that a command sequence is allowed. Our property then has the form: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > valid cmds ==> --- > ... --- --- The use of '==>' may skew test case distribution. We use 'collect' to see the --- length of the command sequences, and 'tabulate' to get the frequencies of the --- individual commands: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > 'collect' (length cmds) $ --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... --- --- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom --- +++ OK, passed 100 tests; 2775 discarded: --- 60% 0 --- 20% 1 --- 15% 2 --- 3% 3 --- 1% 4 --- 1% 5 --- --- Commands (68 in total): --- 62% LogIn --- 22% SendMessage --- 16% LogOut -tabulate :: Testable prop => String -> [String] -> prop -> Property -tabulate key values = - key `deepseq` values `deepseq` - mapTotalResult $ - \res -> res { tables = [(key, value) | value <- values] ++ tables res } - --- | Checks that the values in a given 'table' appear a certain proportion of --- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts --- that of the values in @table@, @x1@ should appear at least @p1@ percent of --- the time, @x2@ at least @p2@ percent of the time, and so on. --- --- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but --- the property does /not/ fail. To make the property fail, use 'checkCoverage'. --- --- Continuing the example from the 'tabular' combinator... --- --- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... --- --- ...we can add a coverage requirement as follows, which checks that @LogIn@, --- @LogOut@ and @SendMessage@ each occur at least 25% of the time: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... property goes here ... --- --- >>> quickCheck prop_chatroom --- +++ OK, passed 100 tests; 2909 discarded: --- 56% 0 --- 17% 1 --- 10% 2 --- 6% 3 --- 5% 4 --- 3% 5 --- 3% 7 --- --- Commands (111 in total): --- 51.4% LogIn --- 30.6% SendMessage --- 18.0% LogOut --- --- Table 'Commands' had only 18.0% LogOut, but expected 25.0% -coverTable :: Testable prop => - String -> [(String, Double)] -> prop -> Property -coverTable table xs = - tables `deepseq` xs `deepseq` - 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. -within :: Testable prop => Int -> prop -> Property -within n = mapRoseResult f - where - f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe x) m - MkRose res roses <- timeout n (reduceRose rose) `orError` - return timeoutResult - res' <- timeout n (protectResult (return res)) `orError` - timeoutResult - return (MkRose res' (map f roses)) - - timeoutResult = failed { reason = "Timeout" } -#ifdef NO_TIMEOUT - timeout _ = fmap Just -#endif - --- | Explicit universal quantification: uses an explicitly given --- test case generator. -forAll :: (Show a, Testable prop) - => Gen a -> (a -> prop) -> Property -forAll gen pf = forAllShrink gen (\_ -> []) pf - --- | Like 'forAll', but with an explicitly given show function. -forAllShow :: Testable prop - => Gen a -> (a -> String) -> (a -> prop) -> Property -forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf - --- | Like 'forAll', but without printing the generated value. -forAllBlind :: Testable prop - => Gen a -> (a -> prop) -> Property -forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf - --- | Like 'forAll', but tries to shrink the argument for failing test cases. -forAllShrink :: (Show a, Testable prop) - => Gen a -> (a -> [a]) -> (a -> prop) -> Property -forAllShrink gen shrinker = forAllShrinkShow gen shrinker show - --- | Like 'forAllShrink', but with an explicitly given show function. -forAllShrinkShow - :: Testable prop - => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property -forAllShrinkShow gen shrinker shower pf = - forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x)) - --- | Like 'forAllShrink', but without printing the generated value. -forAllShrinkBlind - :: Testable prop - => Gen a -> (a -> [a]) -> (a -> prop) -> Property -forAllShrinkBlind gen shrinker pf = - again $ - MkProperty $ - gen >>= \x -> - unProperty $ - shrinking shrinker x pf - --- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of --- 'p1' and 'p2' to test. If you test the property 100 times it --- makes 100 random choices. -(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .&. p2 = - again $ - MkProperty $ - arbitrary >>= \b -> - unProperty $ - counterexample (if b then "LHS" else "RHS") $ - if b then property p1 else property p2 - --- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. -(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .&&. p2 = conjoin [property p1, property p2] - --- | Take the conjunction of several properties. -conjoin :: Testable prop => [prop] -> Property -conjoin ps = - again $ - MkProperty $ - do roses <- mapM (fmap unProp . unProperty . property) ps - return (MkProp (conj id roses)) - where - conj k [] = - MkRose (k succeeded) [] - - conj k (p : ps) = IORose $ do - rose@(MkRose result _) <- reduceRose p - case ok result of - _ | not (expect result) -> - return (return failed { reason = "expectFailure may not occur inside a conjunction" }) - Just True -> return (conj (addLabels result . addCallbacksAndCoverage result . k) ps) - Just False -> return rose - Nothing -> do - rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage result . k) ps) - return $ - -- Nasty work to make sure we use the right callbacks - case ok result2 of - Just True -> MkRose (result2 { ok = Nothing }) [] - Just False -> rose2 - Nothing -> rose2 - - addCallbacksAndCoverage result r = - r { callbacks = callbacks result ++ callbacks r, - requiredCoverage = requiredCoverage result ++ requiredCoverage r } - addLabels result r = - r { labels = labels result ++ labels r, - classes = classes result ++ classes r, - tables = tables result ++ tables r } - --- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. -(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .||. p2 = disjoin [property p1, property p2] - --- | Take the disjunction of several properties. -disjoin :: Testable prop => [prop] -> Property -disjoin ps = - again $ - MkProperty $ - do roses <- mapM (fmap unProp . unProperty . property) ps - return (MkProp (foldr disj (MkRose failed []) roses)) - where - disj :: Rose Result -> Rose Result -> Rose Result - disj p q = - do result1 <- p - case ok result1 of - _ | not (expect result1) -> return expectFailureError - Just False -> do - result2 <- q - return $ - case ok result2 of - _ | not (expect result2) -> expectFailureError - Just True -> addCoverage result1 result2 - Just False -> - MkResult { - ok = Just False, - expect = True, - reason = sep (reason result1) (reason result2), - theException = theException result1 `mplus` theException result2, - -- The following few fields are not important because the - -- test case has failed anyway - abort = False, - maybeNumTests = Nothing, - maybeCheckCoverage = Nothing, - labels = [], - classes = [], - tables = [], - requiredCoverage = [], - callbacks = - callbacks result1 ++ - [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ - callbacks result2, - testCase = - testCase result1 ++ - testCase result2 } - Nothing -> result2 - -- The "obvious" semantics of .||. has: - -- discard .||. true = true - -- discard .||. discard = discard - -- but this implementation gives discard .||. true = discard. - -- This is reasonable because evaluating result2 in the case - -- that result1 discards is just busy-work - it won't ever - -- cause the property to fail. On the other hand, discarding - -- instead of returning true causes us to execute one more - -- test case - but assuming that preconditions are cheap to - -- evaluate, this is no more work than evaluating result2 - -- would be, while (unlike evaluating result2) it might catch - -- a bug. - _ -> return result1 - - expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } - sep [] s = s - sep s [] = s - sep s s' = s ++ ", " ++ s' - - addCoverage result r = - r { requiredCoverage = requiredCoverage result ++ requiredCoverage r } - --- | Like '==', but prints a counterexample when it fails. -infix 4 === -(===) :: (Eq a, Show a) => a -> a -> Property -x === y = - counterexample (show x ++ interpret res ++ show y) res - where - res = x == y - interpret True = " == " - interpret False = " /= " - --- | Like '/=', but prints a counterexample when it fails. -infix 4 =/= -(=/=) :: (Eq a, Show a) => a -> a -> Property -x =/= y = - counterexample (show x ++ interpret res ++ show y) res - where - res = x /= y - interpret True = " /= " - interpret False = " == " - -#ifndef NO_DEEPSEQ --- | Checks that a value is total, i.e., doesn't crash when evaluated. -total :: NFData a => a -> Property -total x = property (rnf x) -#endif - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs deleted file mode 100644 --- a/Test/QuickCheck/Random.hs +++ /dev/null @@ -1,109 +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 - -#ifndef NO_TF_RANDOM -import System.Random -import System.Random.TF -import System.Random.TF.Gen(splitn) -import Data.Word -import Data.Bits - -#define TheGen TFGen - -newTheGen :: IO TFGen -newTheGen = newTFGen - -bits, mask, doneBit :: Integral a => a -bits = 14 -mask = 0x3fff -doneBit = 0x4000 - -chip :: Bool -> Word32 -> TFGen -> TFGen -chip done n g = splitn g (bits+1) (if done then m .|. doneBit else m) - where - m = n .&. mask - -chop :: Integer -> Integer -chop n = n `shiftR` bits - -stop :: Integral a => a -> Bool -stop n = n <= mask - -mkTheGen :: Int -> TFGen -mkTheGen = mkTFGen - -#else -import System.Random - -#define TheGen StdGen - -newTheGen :: IO StdGen -newTheGen = newStdGen - -mkTheGen :: Int -> StdGen -mkTheGen = mkStdGen - -chip :: Bool -> Int -> StdGen -> StdGen -chip finished n = boolVariant finished . boolVariant (even n) - -chop :: Integer -> Integer -chop n = n `div` 2 - -stop :: Integral a => a -> Bool -stop n = n <= 1 -#endif - --- | The "standard" QuickCheck random number generator. --- A wrapper around either 'TFGen' on GHC, or 'StdGen' --- on other Haskell systems. -newtype QCGen = QCGen TheGen - -instance Show QCGen where - showsPrec n (QCGen g) 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 -newQCGen = fmap QCGen newTheGen - -mkQCGen :: Int -> QCGen -mkQCGen n = QCGen (mkTheGen n) - -bigNatVariant :: Integer -> TheGen -> TheGen -bigNatVariant n g - | g `seq` stop n = chip True (fromInteger n) g - | otherwise = (bigNatVariant $! chop n) $! chip False (fromInteger n) g - -{-# INLINE natVariant #-} -natVariant :: Integral a => a -> TheGen -> TheGen -natVariant n g - | g `seq` stop n = chip True (fromIntegral n) g - | otherwise = bigNatVariant (toInteger n) g - -{-# INLINE variantTheGen #-} -variantTheGen :: Integral a => a -> TheGen -> TheGen -variantTheGen n g - | n >= 1 = natVariant (n-1) (boolVariant False g) - | n == 0 = natVariant (0 `asTypeOf` n) (boolVariant True g) - | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g) - -boolVariant :: Bool -> TheGen -> TheGen -boolVariant False = fst . split -boolVariant True = snd . split - -variantQCGen :: Integral a => a -> QCGen -> QCGen -variantQCGen n (QCGen g) = QCGen (variantTheGen n g) diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs deleted file mode 100644 --- a/Test/QuickCheck/State.hs +++ /dev/null @@ -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. diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs deleted file mode 100644 --- a/Test/QuickCheck/Test.hs +++ /dev/null @@ -1,608 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | The main test loop. -{-# LANGUAGE CPP #-} -#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 Data.Number.Erf(invnormcdf) -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 - , intercalate - ) - -import Data.Maybe(fromMaybe, isNothing, catMaybes) -import Data.Ord(comparing) -import Text.Printf(printf) -import Data.Either(lefts, rights) -import Control.Monad -import Data.Bits - --------------------------------------------------------------------------- --- 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 ) - --- | 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'. -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 reason ++ " ") ++ - count True ++ "..." - - full = - (header ++ - (if isOneLine reason then reason ++ " " else "") ++ - count False ++ ":"): - if isOneLine reason then [] else lines reason - - reason = 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 = (labels, tables) - where - labels :: [String] - labels = - 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 ] - - tables :: [String] - tables = - 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)) - -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 (labels, tables) = labelsAndTables st in - foldr counterexample (property failed{P.reason = "Insufficient coverage"}) - (paragraphs [labels, tables]) - | 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. diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs deleted file mode 100644 --- a/Test/QuickCheck/Text.hs +++ /dev/null @@ -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 = intercalate " " (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 = intercalate [""] . 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. diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,302 +0,0 @@ -QuickCheck 2.12.6 (released 2018-10-02) - * Make arbitrarySizedBoundedIntegral handle huge sizes correctly. - * Add changelog for QuickCheck 2.12.5 :) - -QuickCheck 2.12.5 (released 2018-09-30) - * Export isSuccess from Test.QuickCheck. - * Export CoArbitrary even when generics are disabled (bugfix). - * Fix bug in shrinkDecimal. - * Include Test.QuickCheck.Gen in exposed modules for Haddock. - -QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) - * Shrinking for Float and Decimal now works by reducing the number - of digits in the number. The new function shrinkDecimal - implements this shrinking behaviour. - * Shrinking for Rational now tries to make the numerator and - denominator of the number smaller. Previously it tried to reduce - the magnitude of the number. - -QuickCheck 2.12.2 (released 2018-09-10) - * Fix infinite shrinking loop for fractional types. - * Add SortedList modifier. - -QuickCheck 2.12.1 (released 2018-09-06) - * Fix bug in 'classify'. - -QuickCheck 2.12 (released 2018-09-03) - * Silently breaking changes! - - The Arbitrary instance for Word now generates only small - values, the same as Int - - cover no longer causes a property failure if coverage is - insufficient. It just prints a warning. (But see next item!) - - * Overhaul of label/cover family of combinators: - - New property combinator checkCoverage, which checks coverage - requirements in a statistically sound way, and *does* fail if - they are not met. - - Order of arguments to cover swapped, to make it easier to - switch between classify and cover - - New combinators tabulate and coverTable, for reporting test - case distribution more flexibly than label. - - When label is called multiple times in a property, each call - produces a separate table of frequencies. - - * New functions: - - (=/=): like (/=), but prints a counterexample - (thanks to tom-bop) - - forAllShow/forAllShrinkShow: quantification using an - explicit show function (thanks to Stevan Andjelkovic) - - forAllBlind/forAllShrinkBlind: quantification without - printing anything - - verboseShrinking: see how a counterexample is shrunk - - labelledExamples: given a property which uses label, - generate an example test case for each label - - idempotentIOProperty: a variant of ioProperty which shrinks - better but only works for idempotent I/O actions - - * Other improvements: - - MonadFix Gen instance (thanks to Jon Fowler) - - Rational numbers shrink using continued fractions - (thanks to Justus Sagemüller) - - Function instances for Const, Identity, and the types in - Data.Monoid; instance Functor Fun (thanks to Erik Schnetter - and Xia Li-yao) - - More of Test.QuickCheck.Function is exported from - Test.QuickCheck - - Semantics of .||. changed to improve short-circuiting: - if the left argument's precondition is false, the right - argument is not evaluated and the whole disjunction is - considered to have a false precondition - - Bug fix: suchThatMaybe always increased size to at least 1 - - * Miscellaneous API changes: - - Result type has changed a bit: - - InsufficientCovered constructor is gone - - Type of labels has changed - - New fields classes, tables - -QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) - * Cosmetic fixes. - -QuickCheck 2.11 (released 2018-01-12) - * New features: - - InfiniteList modifier generates infinite lists and shows - only the relevant part. - - applyArbitrary2/3/4 for applying a function to random - arguments. - - Template Haskell function allProperties returns all - properties in a module. - - * Applicative Gen instances do less splitting. - * Property now has a Typeable instance. - * (===) now prints correct output when the property is true. - * Test.QuickCheck now exports Fun constructor. - * verboseCheck output is now slightly less confusing. - -QuickCheck 2.10.1 (released 2017-10-06) - * Arbitrary instances for Foreign.C.Types are available in more - GHC versions. - * Fixed a bug where withMaxSuccess didn't adjust the allowed - number of discarded tests. - * Remove quadratic behaviour in terminal output. - -QuickCheck 2.10 (released 2017-06-15) - * New combinators: - - withMaxSuccess sets the maximum number of test cases for a property. - - shrinkMap/shrinkMapBy are helpers for defining shrink functions. - - total checks that a value is non-crashing. - - suchThatMap is similar to 'suchThat' - but takes a Maybe-returning function instead of a predicate. - - getSize returns the current test case size. - - * Random strings and characters now include Unicode characters by - default. To generate only ASCII characters, use the new - ASCIIString modifier or arbitraryASCIIChar generator. - The following modifiers and generators also control the - kind of strings generated: UnicodeString, PrintableString, - arbitraryUnicodeChar, arbitraryPrintableChar. - - * QuickCheck no longer catches asynchronous exceptions, which - means that pressing ctrl-C will now cancel testing without - printing a counterexample. If you are debugging an infinite loop, - please use the 'within' combinator or 'verboseCheck' instead. - ('within' is better as it allows the counterexample to be - shrunk.) - - * Much of Test.QuickCheck.Function (showable random functions) - is now exported from Test.QuickCheck. - - Test.QuickCheck.Function now defines functions and - pattern synonyms which simplify testing functions of - more than one argument: apply2, apply3, Fn2, Fn3. - - * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary - to unary/binary type constructors, like in Data.Functor.Classes. - - * Some Arbitrary instances have been removed: NonEmpty, Natural. - This is because they resulted in a lot of extra dependencies. - You can now find them in the quickcheck-instances package. - Alternatively, use the NonEmptyList and NonNegative modifiers. - - * New Arbitrary instances for the following types: Proxy, ExitCode, - WrappedMonad, WrappedArrow, QCGen, and the types in - Foreign.C.Types and Data.Functor.{Product,Compose}. - Also a Function instance for Word. - - * The functions in Test.QuickCheck.Monadic which take an argument - of type PropertyM m a now expect that 'a' to be Testable, and test it. - To reduce breakage from this, () is now an instance of Testable which - always succeeds. - - PropertyM now has a MonadFail instance on recent GHCs. - Furthermore, the constraints on some instances were loosened. - - * Miscellaneous API changes: - - Result now returns the counterexample as a list of strings. - See the "failingTestCase" field. - - Args now has a `maxShrinks` argument, the maximum number of - shrinks to try before giving up shrinking. - - The 'labels' field of Result now encodes frequencies as Doubles - rather than Ints. - - * Bugfixes: - - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and - 'Test.QuickCheck.Monadic' are now Safe modules. - - Result.theException and Result.reason were taken from - the pre-shrunk counterexample, not the shrunk one. - - The Testable Property instance improperly used 'again'. - - Gen.>>= is strict in the result of split, fixing a space leak. - - within now gives a better error message on timeout - - * Some more examples and links have been added to the documentation. - -QuickCheck 2.9.2 (released 2016-09-15) - * Fix a bug where some properties were only being tested once - * Make shrinking of floating-point values less aggressive - * Add function chooseAny :: Random a => Gen a - -QuickCheck 2.9.1 (released 2016-07-11) - * 'again' was only used in forAllShrink, not forAll - -QuickCheck 2.9 (released 2016-07-10) - * Arbitrary, CoArbitrary and Function instances for more types - * Generics for automatic Function instances - * A new combinator "again" which undoes the effect of "once" - * Remove "exhaustive" from Testable typeclass; - instead, combinators which are nonexhaustive (such as forAll) - call "again", which should be more robust - - * Drop support for GHC 6.x - - * Fixed bugs: - * arbitrarySizedBoundedIntegral wasn't generating huge integers - * verboseCheck failed with Test.QuickCheck.Function - * label had a space leak - -QuickCheck 2.8.2 (released 2016-01-15) - * GHC 8 support - * Add Arbitrary and CoArbitrary instances for types in - containers package - * Improve speed of shuffle combinator - * Only print to stderr if it's a terminal. - * Small changes: slightly improve documentation, - remove redundant constraints from some functions' types, - small improvements to Test.QuickCheck.All. - -QuickCheck 2.8.1 (released 2015-04-03) - * Fix bug where exceptions thrown printing counterexamples weren't - being caught when terminal output was disabled - * Don't export Test.QuickCheck.Property.result - -QuickCheck 2.8 (released 2015-03-18) - * New features: - * Support for GHC 7.10 - * Arbitrary instance for Natural - * New generators shuffle and sublistOf - * Support for generic coarbitrary - * When using the cover combinator, insufficient coverage now - causes the property to fail - - * API changes: - * Test.QuickCheck.Function: new pattern synonym Fn - * genericShrink no longer requires Typeable - * Result has a new constructor InsufficientCoverage - * resize throws an error if the size is negative - - * Bug fixes: - * Fix memory leaks - * Exceptions thrown by callbacks now cause the test to fail - * Fixed a bug where the cover combinator wouldn't give a - warning if coverage was 0% - -QuickCheck 2.7.3 (released 2014-03-24) - * Add annotations for Safe Haskell. - -QuickCheck 2.7.2 (released 2014-03-22) - * Fix bug in cabal file which broke cabal test - -QuickCheck 2.7.1 (released 2014-03-20) - * Fixed bug - the Small modifier didn't work on unsigned types - * Changed arbitrarySizedIntegral to have an Integral constraint - instead of just Num - -QuickCheck 2.7 (released 2014-03-19) - - * New features: - * New genericShrink function provides generic shrinking with GHC. - * New combinator x === y: fails if x /= y, but also prints their values - * New function generate :: Gen a -> IO a for running a generator. - * New combinators infiniteList and infiniteListOf for generating infinite lists. - * Several combinators added to the main Test.QuickCheck module which - were previously languishing in other modules. Of particular interest: - quickCheckAll, ioProperty. - * New combinators delay and capture which can be used (unsafely!) - to reuse the random number seed. Useful for generating - polymorphic (rank-2) values. - * A new Discard data type and a Testable instance for discarding test cases. - * All modifiers now have Functor instances and accessor functions. - * Pressing ctrl-C during shrinking now shows the last failed - test case, rather than the current shrinking candidate. - * Experimental support for UHC. You will need the latest version of Cabal from git. - - * Better distribution of test data: - * The Int generator now only generates fairly small numbers. - * The new Small and Large modifiers control the distribution of integers - (Small generates small numbers, Large from the whole range). - * Floating-point numbers shrink better. - - * Improved random number generation: - * QuickCheck now uses TFGen rather than StdGen on newer versions - of GHC, because StdGen's random numbers aren't always random. - * 'variant' now uses a prefix code. This should prevent some - potential bananaskins with coarbitrary. - - * API changes: - * The Gen monad now uses an abstract type QCGen rather than StdGen. - * The Result type now returns the thrown exception and number - of failed shrink attempts. - * Property is now a newtype rather than Gen Prop as it was before. - * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. - * 'printTestCase' is deprecated - its new name is 'counterexample' - * 'morallyDubiousIOProperty' is deprecated - its new name is - 'ioProperty', no moral judgement involved :) - -QuickCheck 2.6, released 2013-03-07 - - * Add convenience Function instances for up to 7-tuples - * Make stderr line buffered to reduce console I/O. - * Return a flag to say whether the test case was interrupted. - -QuickCheck 2.5, released 2012-06-18 - - * Replace maxDiscard with maxDiscardRatio - * Remove Testable () instance. - * Added a 'discard' exception that discards the current test case - * Add accessors for modifiers (where it makes sense) - * Rename 'stop' to 'abort' to avoid a name clash - * Added a 'once' combinator - * If a property is of type Bool, only run it once - * Add coarbitraryEnum to Test.QuickCheck module. - * Add 'coarbitrary' helper for Enums. - * Rejiggled the formatting code to support multi-line error messages - * Add instances for Ordering and Fixed. - * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). - * Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,457 @@ +## UNRELEASED + +## QuickCheck 2.18.0.0 (released 2026-02-26) +* BREAKING: Added a number of `CoArbitrary` and `Function` instances for types in `base` +* Improve implementation of `shrinkIntegral` (thanks tom93) +* Improve implementation of `Arbitrary NonEmptyList` (thanks konsumlamm) +* Convert changelog to markdown (thanks Artem) +* Deprecate `withMaxSuccess` in favour of the renamed `withNumTests` +* `Test.QuickCheck.Function` marked as `Trustworthy` not `Safe` +* Fix bug in heap example + +## QuickCheck 2.17.1.0 (released 2025-10-13) +* Fix random-1.2 support (thanks bodigrim) +* Update docs (thanks effectfully) + +## QuickCheck 2.17.0.0 (released 2025-10-07) +* Lower the memory use of `arbitrary` for `Double` and `Float` (thanks +ChickenProp) +* BREAKING: Remove `Gen.Class` +* BREAKING: Add `Arbitrary` instances for most of the types in `base` +* Add microHS support (thanks Lennart) + +## QuickCheck 2.16.0.0 (released 2025-06-17) +* Add a `Safe` declaration to `Test.QuickCheck.Monoids` +* Fix `Test.QuickCheck.Features` to not depend on the internal testing loop +* Add `withProgress` to install common callbacks for downstream tools +* Relax bounds on `random` dependency (thanks to LaurentRDC and +Andreas Abel) +* Fix some haddock issues (thanks to pgujjula) +* Use `displayException` instead of `show` (thanks Edsko) +* Added helper monoids `Every` and `Some` for predicates (thanks +Marcin) + +## QuickCheck 2.15 (released 2024-04-22) +* BREAKING: properties without quantification are no longer implicitly + wrapped in once +* Add witness property modifier and witnesses field in result on +compilers that support Typeable to allow conveniently exposing +counterexamples +* Add assertException, assertExceptionIO, assertDeepException, and +assertDeepExceptionIO (thanks to Alexey Kuleshevich) +* Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators +* Add recheck +* Add HasCallStack to partial top-level functions +* Updated some documentation +* Fix overflow bug when calculating discard ratio +* Fix error printing bug when shrinks are discarded +* Fix withMaxSuccess not working when checkCoverage is turned on +* Fix a bug whereby an unfortunately timed discard could unduly fail a +property running with checkCoverage +* Fix Arbitrary intance for Map breaking invariants from +Data.Map.Strict (thanks to Neil Mayhew) +* Fix non-covered classes not showing up in output as 0% covered +* Fix Negative's Arbitrary instance discarding an unnecessary number +of generated values. +* Fix promote doing an unnecessary seed split +* Fix a bug whereby maxSuccess and discardRatio would interact poorly +to produce too few size increases. +* Fix a couple of underflow bugs in generators for Small Natural and +Ratio Natural +* Fix a bug whereby the internal DISCARDED exception would show up +user-side in sample + +## QuickCheck 2.14.3 (released 2023-05-31) +* Add shrinkBoundedEnum (thanks to Jonathan Knowles) +* Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) +* Add assertWith for monadic testing (thanks to KtorZ) +* Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus) +* Add Arbitrary instance for Newline (thanks to Daniel Bramucci) +* Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus) +* Improve arbitrarySizedFractional (thanks to Bodigrim) +* Fix shrinkRealFrac and shrinkDecimal, which were broken +* Speed up printing of progress messages (thanks to Bodigrim) +* Add COMPLETE pragmas for Fn and family (thanks to ilkecan) +* Make templateHaskell flag manual (thanks to Oleg Grenrus) + +## QuickCheck 2.14.2 (released 2020-11-14) +* Add Arbitrary instances for Tree (thanks to Oleg Grenrus) +* GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) + +## QuickCheck 2.14.1 (released 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 + fast as before, for example. Of course, your mileage may vary. + + The reason for this is that there are now specialised versions + of the 'choose' combinator for various types. These are: + chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. + These combinators are identical to 'choose' but much faster. + All QuickCheck combinators, with the exception of 'choose' + itself, use the new combinators behind the scenes. + + You should see a speedup without doing anything, but to get a + further speedup, consider replacing any uses of 'choose' in your + own generators with the new combinators. + + We are hoping that future releases of the 'random' library may + speed up 'choose', in which case these combinators may no longer + be needed. + + Thanks to Oleg Grenrus for suggesting to bypass 'choose' for + random number generation, and providing the appropriate + primitive in his 'splitmix' random number library. + +* Smaller changes and bugfixes: +- RecursivelyShrink and GSubterms are exported from + Test.QuickCheck.Test (thanks to Tom Mortiboy). +- Don't generate invalid unicode characters + (thanks to Boris Stepanov). +- 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). +- Fix a couple of bugs with shrinking of floating-point + numbers. +- Export functionMapWith, functionEitherWith and + functionPairWith from Test.QuickCheck.Function + (thanks to Oleg Grenrus). +- Remove redundant RealFloat constraint from + Arbitrary/CoArbitrary instances for Complex + (thanks to Bodigrim). + +## QuickCheck 2.13.2 (released 2019-06-30) +* Compatibility with GHC 8.8 (thanks to Bodigrim) +* Improve error message when 'frequency' is used with only zero weights +* Add 'functionVoid' combinator (thanks to Oleg Grenrus) +* Tighten bounds for random package (thanks to Oleg Grenrus) + +## QuickCheck 2.13.1 (released 2019-03-29) +* A couple of bug fixes + +## QuickCheck 2.13 (released 2019-03-26) +* Properties with multiple arguments now shrink better. + Previously, the first argument was shrunk, then the second, and + so on. Now, the arguments are shrunk as a whole, so shrink steps + for different arguments can be interleaved. + +* New features: + - New modifiers Negative and NonPositive + - A Testable instance for Maybe prop (where Nothing means 'discard + the test case') +* Dependencies on C code removed: + - Use splitmix instead of tf-random for random number generation + - Remove dependency on 'erf' package +* Small changes: + - Say 'Falsified' instead of 'Falsifiable' when a property fails +* Compatibility improvements: + - Explicitly derive instance Typeable Args + - Lower bound on deepseq + - A script for building Hugs packages + +## QuickCheck 2.12.6 (released 2018-10-02) +* Make arbitrarySizedBoundedIntegral handle huge sizes correctly. +* Add changelog for QuickCheck 2.12.5 :) + +## QuickCheck 2.12.5 (released 2018-09-30) +* Export isSuccess from Test.QuickCheck. +* Export CoArbitrary even when generics are disabled (bugfix). +* Fix bug in shrinkDecimal. +* Include Test.QuickCheck.Gen in exposed modules for Haddock. + +## QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) +* Shrinking for Float and Decimal now works by reducing the number + of digits in the number. The new function shrinkDecimal + implements this shrinking behaviour. +* Shrinking for Rational now tries to make the numerator and + denominator of the number smaller. Previously it tried to reduce + the magnitude of the number. + +## QuickCheck 2.12.2 (released 2018-09-10) +* Fix infinite shrinking loop for fractional types. +* Add SortedList modifier. + +## QuickCheck 2.12.1 (released 2018-09-06) +* Fix bug in 'classify'. + +## QuickCheck 2.12 (released 2018-09-03) +* Silently breaking changes! + - The Arbitrary instance for Word now generates only small + values, the same as Int + - cover no longer causes a property failure if coverage is + insufficient. It just prints a warning. (But see next item!) + +* Overhaul of label/cover family of combinators: + - New property combinator checkCoverage, which checks coverage + requirements in a statistically sound way, and *does* fail if + they are not met. + - Order of arguments to cover swapped, to make it easier to + switch between classify and cover + - New combinators tabulate and coverTable, for reporting test + case distribution more flexibly than label. + - When label is called multiple times in a property, each call + produces a separate table of frequencies. + +* New functions: + - (=/=): like (/=), but prints a counterexample + (thanks to tom-bop) + - forAllShow/forAllShrinkShow: quantification using an + explicit show function (thanks to Stevan Andjelkovic) + - forAllBlind/forAllShrinkBlind: quantification without + printing anything + - verboseShrinking: see how a counterexample is shrunk + - labelledExamples: given a property which uses label, + generate an example test case for each label + - idempotentIOProperty: a variant of ioProperty which shrinks + better but only works for idempotent I/O actions + +* Other improvements: + - MonadFix Gen instance (thanks to Jon Fowler) + - Rational numbers shrink using continued fractions + (thanks to Justus Sagemüller) + - Function instances for Const, Identity, and the types in + Data.Monoid; instance Functor Fun (thanks to Erik Schnetter + and Xia Li-yao) + - More of Test.QuickCheck.Function is exported from + Test.QuickCheck + - Semantics of .||. changed to improve short-circuiting: + if the left argument's precondition is false, the right + argument is not evaluated and the whole disjunction is + considered to have a false precondition + - Bug fix: suchThatMaybe always increased size to at least 1 + +* Miscellaneous API changes: + - Result type has changed a bit: + - InsufficientCovered constructor is gone + - Type of labels has changed + - New fields classes, tables + +## QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) +* Cosmetic fixes. + +## QuickCheck 2.11 (released 2018-01-12) +* New features: + - InfiniteList modifier generates infinite lists and shows + only the relevant part. + - applyArbitrary2/3/4 for applying a function to random + arguments. + - Template Haskell function allProperties returns all + properties in a module. + +* Applicative Gen instances do less splitting. +* Property now has a Typeable instance. +* (===) now prints correct output when the property is true. +* Test.QuickCheck now exports Fun constructor. +* verboseCheck output is now slightly less confusing. + +## QuickCheck 2.10.1 (released 2017-10-06) +* Arbitrary instances for Foreign.C.Types are available in more + GHC versions. +* Fixed a bug where withMaxSuccess didn't adjust the allowed + number of discarded tests. +* Remove quadratic behaviour in terminal output. + +## QuickCheck 2.10 (released 2017-06-15) +* New combinators: + - withMaxSuccess sets the maximum number of test cases for a property. + - shrinkMap/shrinkMapBy are helpers for defining shrink functions. + - total checks that a value is non-crashing. + - suchThatMap is similar to 'suchThat' + but takes a Maybe-returning function instead of a predicate. + - getSize returns the current test case size. + +* Random strings and characters now include Unicode characters by + default. To generate only ASCII characters, use the new + ASCIIString modifier or arbitraryASCIIChar generator. + The following modifiers and generators also control the + kind of strings generated: UnicodeString, PrintableString, + arbitraryUnicodeChar, arbitraryPrintableChar. + +* QuickCheck no longer catches asynchronous exceptions, which + means that pressing ctrl-C will now cancel testing without + printing a counterexample. If you are debugging an infinite loop, + please use the 'within' combinator or 'verboseCheck' instead. + ('within' is better as it allows the counterexample to be + shrunk.) + +* Much of Test.QuickCheck.Function (showable random functions) + is now exported from Test.QuickCheck. + - Test.QuickCheck.Function now defines functions and + pattern synonyms which simplify testing functions of + more than one argument: apply2, apply3, Fn2, Fn3. + +* New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary + to unary/binary type constructors, like in Data.Functor.Classes. + +* Some Arbitrary instances have been removed: NonEmpty, Natural. + This is because they resulted in a lot of extra dependencies. + You can now find them in the quickcheck-instances package. + Alternatively, use the NonEmptyList and NonNegative modifiers. + +* New Arbitrary instances for the following types: Proxy, ExitCode, + WrappedMonad, WrappedArrow, QCGen, and the types in + Foreign.C.Types and Data.Functor.{Product,Compose}. + Also a Function instance for Word. + +* The functions in Test.QuickCheck.Monadic which take an argument + of type PropertyM m a now expect that 'a' to be Testable, and test it. + To reduce breakage from this, () is now an instance of Testable which + always succeeds. + - PropertyM now has a MonadFail instance on recent GHCs. + Furthermore, the constraints on some instances were loosened. + +* Miscellaneous API changes: + - Result now returns the counterexample as a list of strings. + See the "failingTestCase" field. + - Args now has a `maxShrinks` argument, the maximum number of + shrinks to try before giving up shrinking. + - The 'labels' field of Result now encodes frequencies as Doubles + rather than Ints. + +* Bugfixes: + - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and + 'Test.QuickCheck.Monadic' are now Safe modules. + - Result.theException and Result.reason were taken from + the pre-shrunk counterexample, not the shrunk one. + - The Testable Property instance improperly used 'again'. + - Gen.>>= is strict in the result of split, fixing a space leak. + - within now gives a better error message on timeout + +* Some more examples and links have been added to the documentation. + +## QuickCheck 2.9.2 (released 2016-09-15) +* Fix a bug where some properties were only being tested once +* Make shrinking of floating-point values less aggressive +* Add function chooseAny :: Random a => Gen a + +## QuickCheck 2.9.1 (released 2016-07-11) +* 'again' was only used in forAllShrink, not forAll + +## QuickCheck 2.9 (released 2016-07-10) +* Arbitrary, CoArbitrary and Function instances for more types +* Generics for automatic Function instances +* A new combinator "again" which undoes the effect of "once" +* Remove "exhaustive" from Testable typeclass; + instead, combinators which are nonexhaustive (such as forAll) + call "again", which should be more robust + +* Drop support for GHC 6.x + +* Fixed bugs: + * arbitrarySizedBoundedIntegral wasn't generating huge integers + * verboseCheck failed with Test.QuickCheck.Function + * label had a space leak + +## QuickCheck 2.8.2 (released 2016-01-15) +* GHC 8 support +* Add Arbitrary and CoArbitrary instances for types in + containers package +* Improve speed of shuffle combinator +* Only print to stderr if it's a terminal. +* Small changes: slightly improve documentation, + remove redundant constraints from some functions' types, + small improvements to Test.QuickCheck.All. + +## QuickCheck 2.8.1 (released 2015-04-03) +* Fix bug where exceptions thrown printing counterexamples weren't + being caught when terminal output was disabled +* Don't export Test.QuickCheck.Property.result + +## QuickCheck 2.8 (released 2015-03-18) +* New features: + * Support for GHC 7.10 + * Arbitrary instance for Natural + * New generators shuffle and sublistOf + * Support for generic coarbitrary + * When using the cover combinator, insufficient coverage now + causes the property to fail + +* API changes: + * Test.QuickCheck.Function: new pattern synonym Fn + * genericShrink no longer requires Typeable + * Result has a new constructor InsufficientCoverage + * resize throws an error if the size is negative + +* Bug fixes: + * Fix memory leaks + * Exceptions thrown by callbacks now cause the test to fail + * Fixed a bug where the cover combinator wouldn't give a + warning if coverage was 0% + +## QuickCheck 2.7.3 (released 2014-03-24) +* Add annotations for Safe Haskell. + +## QuickCheck 2.7.2 (released 2014-03-22) +* Fix bug in cabal file which broke cabal test + +## QuickCheck 2.7.1 (released 2014-03-20) +* Fixed bug - the Small modifier didn't work on unsigned types +* Changed arbitrarySizedIntegral to have an Integral constraint + instead of just Num + +## QuickCheck 2.7 (released 2014-03-19) + +* New features: + * New genericShrink function provides generic shrinking with GHC. + * New combinator x === y: fails if x /= y, but also prints their values + * New function generate :: Gen a -> IO a for running a generator. + * New combinators infiniteList and infiniteListOf for generating infinite lists. + * Several combinators added to the main Test.QuickCheck module which + were previously languishing in other modules. Of particular interest: + quickCheckAll, ioProperty. + * New combinators delay and capture which can be used (unsafely!) + to reuse the random number seed. Useful for generating + polymorphic (rank-2) values. + * A new Discard data type and a Testable instance for discarding test cases. + * All modifiers now have Functor instances and accessor functions. + * Pressing ctrl-C during shrinking now shows the last failed + test case, rather than the current shrinking candidate. + * Experimental support for UHC. You will need the latest version of Cabal from git. + +* Better distribution of test data: + * The Int generator now only generates fairly small numbers. + * The new Small and Large modifiers control the distribution of integers + (Small generates small numbers, Large from the whole range). + * Floating-point numbers shrink better. + +* Improved random number generation: + * QuickCheck now uses TFGen rather than StdGen on newer versions + of GHC, because StdGen's random numbers aren't always random. + * 'variant' now uses a prefix code. This should prevent some + potential bananaskins with coarbitrary. + +* API changes: + * The Gen monad now uses an abstract type QCGen rather than StdGen. + * The Result type now returns the thrown exception and number + of failed shrink attempts. + * Property is now a newtype rather than Gen Prop as it was before. + * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. + * 'printTestCase' is deprecated - its new name is 'counterexample' + * 'morallyDubiousIOProperty' is deprecated - its new name is + 'ioProperty', no moral judgement involved :) + +## QuickCheck 2.6 (released 2013-03-07) + +* Add convenience Function instances for up to 7-tuples +* Make stderr line buffered to reduce console I/O. +* Return a flag to say whether the test case was interrupted. + +## QuickCheck 2.5 (released 2012-06-18) + +* Replace maxDiscard with maxDiscardRatio +* Remove Testable () instance. +* Added a 'discard' exception that discards the current test case +* Add accessors for modifiers (where it makes sense) +* Rename 'stop' to 'abort' to avoid a name clash +* Added a 'once' combinator +* If a property is of type Bool, only run it once +* Add coarbitraryEnum to Test.QuickCheck module. +* Add 'coarbitrary' helper for Enums. +* Rejiggled the formatting code to support multi-line error messages +* Add instances for Ordering and Fixed. +* Added arbitraryBoundedEnum generator (thanks to Antoine Latter). +* Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -72,7 +72,7 @@ toSortedList :: Ord a => Heap a -> [a] toSortedList Empty = [] -toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) +toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -------------------------------------------------------------------------- -- specification @@ -144,24 +144,21 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. -{- - shrink Empty = [] - shrink (Node x h1 h2) = - [ h1, h2 ] - ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] - ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] - ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] --} +-- shrink Empty = [] +-- shrink (Node x h1 h2) = +-- [ h1, h2 ] +-- ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] +-- ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] +-- ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] + -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -{- -prop_HeapIsNotSorted (h :: Heap Int) = - expectFailure $ - toList h == toSortedList h --} +-- prop_HeapIsNotSorted (h :: Heap Int) = +-- expectFailure $ +-- toList h == toSortedList h diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs --- a/examples/Heap_Program.hs +++ b/examples/Heap_Program.hs @@ -187,7 +187,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs --- a/examples/Heap_ProgramAlgebraic.hs +++ b/examples/Heap_ProgramAlgebraic.hs @@ -245,7 +245,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Merge.hs b/examples/Merge.hs --- a/examples/Merge.hs +++ b/examples/Merge.hs @@ -110,7 +110,7 @@ -- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Set.hs b/examples/Set.hs --- a/examples/Set.hs +++ b/examples/Set.hs @@ -21,8 +21,6 @@ import Data.Maybe ---import Text.Show.Functions - -------------------------------------------------------------------------- -- binary search trees @@ -142,8 +140,6 @@ shrink t@(Node x s1 s2) = [ s1, s2 ] ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ] --- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a) - -------------------------------------------------------------------------- -- properties @@ -197,8 +193,6 @@ where xs = toSortedList s --- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ - prop_FromList' (xs :: [Int]) = shrinking shrink xs $ \xs' -> fromList xs ==? xs @@ -207,7 +201,7 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -40,7 +40,7 @@ prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/make-hugs b/make-hugs new file mode 100644 --- /dev/null +++ b/make-hugs @@ -0,0 +1,28 @@ +#!/bin/bash + +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 -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 -DNO_CALLSTACK \ + -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS \ + "$src" > "$tgt" +done + +echo "A Hugs-compatible version of QuickCheck is now" +echo "available in the quickcheck-hugs directory." +echo "Load it with hugs -98." diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck.hs @@ -0,0 +1,381 @@ +{-| +The +gives detailed information about using QuickCheck effectively. +You can also try , +a tutorial written by a user of QuickCheck. + +To start using QuickCheck, write down your property as a function returning @Bool@. +For example, to check that reversing a list twice gives back the same list you can write: + +@ +import Test.QuickCheck + +prop_reverse :: [Int] -> Bool +prop_reverse xs = reverse (reverse xs) == xs +@ + +You can then use QuickCheck to test @prop_reverse@ on 100 random lists: + +>>> quickCheck prop_reverse ++++ OK, passed 100 tests. + +To run more tests you can use the 'withNumTests' combinator: + +>>> quickCheck (withNumTests 10000 prop_reverse) ++++ OK, passed 10000 tests. + +To use QuickCheck on your own data types you will need to write 'Arbitrary' +instances for those types. See the + for +details about how to do that. + +When testing fails @quickCheck@ will try to give you a minimal counterexample to +your property: +@ +import Test.QuickCheck + +prop_reverse_bad :: [Int] -> Bool +prop_reverse_bad xs = reverse xs == xs + +>>> quickCheck prop_reverse_bad +*** Failed! Falsified (after 3 tests and 3 shrinks): +[0,1] +@ + +However, beware because not all properties that ought to fail will fail when you expect +them to: + +@ +>>> quickCheck $ \ x y -> x == y ++++ Ok, passed 100 tests. +@ + +That's because GHCi will default any type variables in your property to @()@, so in the example +above @quickCheck@ was really testing that @()@ is equal to itself. To avoid this behaviour it +is best practise to monomorphise your polymorphic properties when testing: + +@ +>>> quickCheck $ \ x y -> (x :: Int) == y +*** Failed! Falsified (after 4 tests and 3 shrinks): +0 +1 +@ + +-} +{-# 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(..), TestProgress(..) + , stdArgs + , quickCheckWith + , quickCheckWithResult + , quickCheckResult + , recheck + , 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 + , shrinkBoundedEnum + , 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 +#ifndef NO_SPLITMIX + , chooseWord64 + , chooseInt64 + , chooseUpTo +#endif + , 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 :: ['Test.QuickCheck.Poly.A']) = + -- takeWhile p xs ++ dropWhile p xs == xs + -- @ + -- + -- @ + -- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) = + -- take n xs ++ drop n xs == xs + -- @ + -- + -- @ + -- -- cycle does not work for empty lists + -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) = + -- take n (cycle xs) == take n (xs ++ cycle xs) + -- @ + -- + -- @ + -- -- Instead of 'forAll' 'orderedList' + -- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.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 + , withNumTests + , withMaxSuccess + , within + , discardAfter + , withDiscardRatio + , withMaxSize + , withMaxShrinks + , once + , again + , mapSize + -- ** Conjunction and disjunction + , (.&.) + , (.&&.) + , conjoin + , Every (..) + , (.||.) + , disjoin + , Some (..) + -- ** What to do on failure +#ifndef NO_TYPEABLE + , Witness(..) + , witness + , coerceWitness + , castWitness +#endif + , counterexample + , printTestCase + , withProgress + , 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.Monoids +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. diff --git a/src/Test/QuickCheck/All.hs b/src/Test/QuickCheck/All.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/All.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE Rank2Types, CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#else +{-# LANGUAGE TemplateHaskell #-} +#endif +#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, + runQuickCheckAll, + -- ** 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 (isPrefixOf, nubBy) +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 |] `appE` 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 |] `appE` 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 (ForallT xs ctx ty) = do +#if MIN_VERSION_template_haskell(2,17,0) + let plain (PlainTV nm _) = return nm + plain (KindedTV nm _ StarT) = return nm +#else + let plain (PlainTV nm) = return nm +# if MIN_VERSION_template_haskell(2,8,0) + plain (KindedTV nm StarT) = return nm +# else + plain (KindedTV nm StarK) = return nm +# endif +#endif + plain _ = err "Higher-kinded type variables in type" + xs' <- mapM plain xs + return (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 |] `appE` allProperties + +-- | List all properties in the current module. +-- +-- @$'allProperties'@ has type @[('String', 'Property')]@. +-- +-- 'allProperties' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +allProperties :: Q Exp +allProperties = do + Loc { loc_filename = filename } <- location + when (filename == "") $ error "don't run this interactively" + ls <- runIO (fmap lines (readUTF8File filename)) + let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') . dropWhile (\c -> isSpace c || c == '>')) ls + idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes)) +#if MIN_VERSION_template_haskell(2,8,0) + warning x = reportWarning ("Name " ++ x ++ " found in source file but was not in scope") +#else + warning x = report False ("Name " ++ x ++ " found in source file but was not in scope") +#endif + quickCheckOne :: (Int, String) -> Q [Exp] + quickCheckOne (l, x) = do + exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True) + if exists + then sequence + [ tupE + [ stringE $ x ++ " from " ++ filename ++ ":" ++ show l + , [| property |] `appE` monomorphic (mkName x) + ] + ] + else return [] + fmap (ListE . concat) (mapM quickCheckOne idents) `sigE` [t| [(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 `appE` [| 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 `appE` [| 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 diff --git a/src/Test/QuickCheck/Arbitrary.hs b/src/Test/QuickCheck/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Arbitrary.hs @@ -0,0 +1,1981 @@ +-- | 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] + , shrinkBoundedEnum -- :: (Bounded a, Enum 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) +#if MIN_VERSION_random(1,3,0) +import System.Random(Random, uniformByteArray) +#else +import System.Random(Random) +#endif +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Test.QuickCheck.Gen.Unsafe +#if defined(__MHS__) +-- These two are not exported by Control.Applicative. +-- Why should they be? They are just bloat. +import Data.ZipList +import Control.WrappedMonad +#endif + +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 (..)) + +#if defined(MIN_VERSION_base) +import Numeric.Natural + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + +import System.IO + ( Newline(..) + , NewlineMode(..) + , SeekMode(..) + , BufferMode(..) + , TextEncoding + , latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 + , IOMode(..) + ) +#endif + +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.IntSet as IntSet +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as IntMap +#else +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +#endif +import qualified Data.Sequence as Sequence +import qualified Data.Tree as Tree + +import qualified Data.Monoid as Monoid +#if defined(MIN_VERSION_base) +import qualified Data.Semigroup as Semigroup +#endif + +#ifndef NO_TRANSFORMERS +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Functor.Compose +import Data.Functor.Product +#endif + +#if defined(MIN_VERSION_base) +import qualified Data.Semigroup as Semigroup +import Data.Ord + +import System.Console.GetOpt + ( ArgDescr(..), ArgOrder(..), OptDescr(..) ) + +import Data.Functor.Contravariant + +import Data.Array.Byte +import qualified GHC.Exts as Exts + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif +#endif + +import Data.Bits +import Text.Printf + +import Test.QuickCheck.Compat + +-------------------------------------------------------------------------- +-- ** class Arbitrary + +-- | Random generation and shrinking of values. +-- +-- QuickCheck provides @Arbitrary@ instances for most types in @base@, +-- except those which incur extra dependencies. +-- For a wider range of @Arbitrary@ instances see the +-- +-- package. +class Arbitrary a where + -- | A generator for values of the given type. + -- + -- It is worth spending time thinking about what sort of test data + -- you want - good generators are often the difference between + -- finding bugs and not finding them. You can use 'sample', + -- 'Test.QuickCheck.label' and 'Test.QuickCheck.classify' to check the quality + -- of your test data. + -- + -- There is no generic @arbitrary@ implementation included because we don't + -- know how to make a high-quality one. If you want one, consider using the + -- or + -- packages. + -- + -- The + -- goes into detail on how to write good generators. Make sure to look at it, + -- especially if your type is recursive! + arbitrary :: Gen a + + -- | Produces a (possibly) empty list of all the possible + -- immediate shrinks of the given value. + -- + -- The default implementation returns the empty list, so will not try to + -- shrink the value. If your data type has no special invariants, you can + -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising + -- the behaviour of @shrink@ you can often get simpler counterexamples. + -- + -- Most implementations of 'shrink' should try at least three things: + -- + -- 1. Shrink a term to any of its immediate subterms. + -- You can use 'subterms' to do this. + -- + -- 2. Recursively apply 'shrink' to all immediate subterms. + -- You can use 'recursivelyShrink' to do this. + -- + -- 3. Type-specific shrinkings such as replacing a constructor by a + -- simpler constructor. + -- + -- For example, suppose we have the following implementation of binary trees: + -- + -- > data Tree a = Nil | Branch a (Tree a) (Tree a) + -- + -- We can then define 'shrink' as follows: + -- + -- > shrink Nil = [] + -- > shrink (Branch x l r) = + -- > -- shrink Branch to Nil + -- > [Nil] ++ + -- > -- shrink to non-Nil subterms + -- > [t | t@Branch{} <- [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 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 + +#if defined(MIN_VERSION_base) +instance Arbitrary1 NonEmpty where + liftArbitrary arb = NonEmpty.fromList <$> listOf1 arb + liftShrink shr xs = [ NonEmpty.fromList xs' | xs' <- liftShrink shr (NonEmpty.toList xs), not (null xs') ] + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + +instance Integral a => Arbitrary (Ratio a) where + arbitrary = sized $ \ n -> do + denom <- chooseInt (1, max 1 n) + let lb | isNonNegativeType fromI = 0 + | otherwise = (-n*denom) + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral + numer <- chooseInt (lb, n*denom) + pure $ fromI numer % fromI denom + shrink = shrinkRealFrac + + +#if defined(MIN_VERSION_base) +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 + +#if defined(MIN_VERSION_base) +instance Arbitrary Natural where + arbitrary = arbitrarySizedNatural + shrink = shrinkIntegral +#endif + +instance Arbitrary Int where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word where + arbitrary = 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 = oneof + -- generate 0..1 numbers with full precision + [ genFloat + -- generate integral numbers + , fromIntegral <$> (arbitrary :: Gen Int) + -- generate fractions with small denominators + , smallDenominators + -- uniform -size..size with with denominators ~ size + , uniform + -- and uniform -size..size with higher precision + , arbitrarySizedFractional + ] + where + smallDenominators = sized $ \n -> do + i <- chooseInt (0, min n 256) + pure (fromRational (streamNth i rationalUniverse)) + + uniform = sized $ \n -> do + let n' = toInteger n + b <- chooseInteger (1, max 1 n') + a <- chooseInteger ((-n') * b, n' * b) + return (fromRational (a % b)) + + shrink = shrinkDecimal + +instance Arbitrary Double where + arbitrary = oneof + -- generate 0..1 numbers with full precision + [ genDouble + -- generate integral numbers + , fromIntegral <$> (arbitrary :: Gen Int) + -- generate fractions with small denominators + , smallDenominators + -- uniform -size..size with with denominators ~ size + , uniform + -- and uniform -size..size with higher precision + , arbitrarySizedFractional + ] + where + smallDenominators = sized $ \n -> do + i <- chooseInt (0, min n 256) + pure (fromRational (streamNth i rationalUniverse)) + + uniform = sized $ \n -> do + let n' = toInteger n + b <- chooseInteger (1, max 1 n') + a <- chooseInteger ((-n') * b, n' * b) + return (fromRational (a % b)) + + 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 +-- | WARNING: Users working on the internals of the @Set@ type via e.g. @Data.Set.Internal@ +-- should be aware that this instance aims to give a good representation of @Set a@ +-- as mathematical sets but *does not* aim to provide a varied distribution over the +-- underlying representation. +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 +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where + arbitrary = arbitrary1 + shrink = shrink1 +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + shrink = map IntSet.fromList . shrink . IntSet.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. +instance Arbitrary1 IntMap.IntMap where + liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. +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 +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. +instance Arbitrary a => Arbitrary (Sequence.Seq a) where + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary1 Tree.Tree where + liftArbitrary arb = sized $ \n -> do + k <- chooseInt (0, n) + go k + where + go n = do -- n is the size of the trees. + value <- arb + pars <- arbPartition (n - 1) -- can go negative! + forest <- mapM go pars + return $ Tree.Node value forest + + arbPartition :: Int -> Gen [Int] + arbPartition k = case compare k 1 of + LT -> pure [] + EQ -> pure [1] + GT -> do + first <- chooseInt (1, k) + rest <- arbPartition $ k - first + shuffle (first : rest) + + liftShrink shr = go + where + go (Tree.Node val forest) = forest ++ + [ Tree.Node e fs + | (e, fs) <- liftShrink2 shr (liftShrink go) (val, forest) + ] +instance Arbitrary a => Arbitrary (Tree.Tree 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) +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 + +instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where + arbitrary = fmap Monoid.Alt arbitrary + shrink = map Monoid.Alt . shrink . Monoid.getAlt + +instance Arbitrary a => Arbitrary (Semigroup.Min a) where + arbitrary = fmap Semigroup.Min arbitrary + shrink = map Semigroup.Min . shrink . Semigroup.getMin + +instance Arbitrary a => Arbitrary (Semigroup.Max a) where + arbitrary = fmap Semigroup.Max arbitrary + shrink = map Semigroup.Max . shrink . Semigroup.getMax + +instance Arbitrary a => Arbitrary (Semigroup.First a) where + arbitrary = fmap Semigroup.First arbitrary + shrink = map Semigroup.First . shrink . Semigroup.getFirst + +instance Arbitrary a => Arbitrary (Semigroup.Last a) where + arbitrary = fmap Semigroup.Last arbitrary + shrink = map Semigroup.Last . shrink . Semigroup.getLast + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Semigroup.Arg a b) where + arbitrary = Semigroup.Arg <$> arbitrary <*> arbitrary + shrink (Semigroup.Arg a b) = uncurry Semigroup.Arg <$> shrink (a, b) + +instance Arbitrary a => Arbitrary (Semigroup.WrappedMonoid a) where + arbitrary = Semigroup.WrapMonoid <$> arbitrary + shrink = map Semigroup.WrapMonoid . shrink . Semigroup.unwrapMonoid + +#if !MIN_VERSION_base(4,15,0) +instance Arbitrary a => Arbitrary (Semigroup.Option a) where + arbitrary = Semigroup.Option <$> arbitrary + shrink = map Semigroup.Option . shrink . Semigroup.getOption + +instance CoArbitrary a => CoArbitrary (Semigroup.Option a) where + coarbitrary = coarbitrary . Semigroup.getOption +#endif + +#if MIN_VERSION_base(4,16,0) +instance Arbitrary a => Arbitrary (Iff a) where + arbitrary = Iff <$> arbitrary + shrink = map Iff . shrink . getIff + +instance Arbitrary a => Arbitrary (Ior a) where + arbitrary = Ior <$> arbitrary + shrink = map Ior . shrink . getIor + +instance Arbitrary a => Arbitrary (Xor a) where + arbitrary = Xor <$> arbitrary + shrink = map Xor . shrink . getXor + +instance Arbitrary a => Arbitrary (And a) where + arbitrary = And <$> arbitrary + shrink = map And . shrink . getAnd + +instance CoArbitrary a => CoArbitrary (And a) where + coarbitrary = coarbitrary . getAnd + +instance CoArbitrary a => CoArbitrary (Iff a) where + coarbitrary = coarbitrary . getIff + +instance CoArbitrary a => CoArbitrary (Ior a) where + coarbitrary = coarbitrary . getIor + +instance CoArbitrary a => CoArbitrary (Xor a) where + coarbitrary = coarbitrary . getXor +#endif + +#if !defined(__MHS__) +instance Arbitrary ByteArray where +#if MIN_VERSION_random(1,3,0) + arbitrary = do + pin <- arbitrary + len <- abs <$> arbitrary + MkGen $ \ qcGen _ -> fst $ uniformByteArray pin len qcGen +#else + arbitrary = Exts.fromList <$> arbitrary +#endif + shrink = map Exts.fromList . shrink . Exts.toList + +instance CoArbitrary ByteArray where + coarbitrary = coarbitrary . Exts.toList + +-- MicroHs does not have Exts.fromList +#endif /* !defined(__MHS__) */ + +#if MIN_VERSION_base(4,16,0) + +instance Arbitrary a => Arbitrary (Solo a) where + arbitrary = mkSolo <$> arbitrary + shrink = map mkSolo . shrink . getSolo + +instance CoArbitrary a => CoArbitrary (Solo a) where + coarbitrary = coarbitrary . getSolo + +#endif + +instance Arbitrary a => Arbitrary (Down a) where + arbitrary = fmap Down arbitrary + shrink = map Down . shrink . getDown + +instance CoArbitrary a => CoArbitrary (Down a) where + coarbitrary = coarbitrary . getDown + +#endif + +#ifdef __GLASGOW_HASKELL__ + +instance Arbitrary a => Arbitrary (ArgDescr a) where + arbitrary = oneof [ NoArg <$> arbitrary + , ReqArg <$> arbitrary <*> arbitrary + , OptArg <$> arbitrary <*> arbitrary + ] + + shrink (NoArg i) = [ NoArg i' | i' <- shrink i ] + shrink (ReqArg a1 a2) = [ ReqArg a1' a2 | a1' <- shrink a1 ] ++ + [ ReqArg a1 a2' | a2' <- shrink a2 ] + shrink (OptArg a1 a2) = [ OptArg a1' a2 | a1' <- shrink a1 ] ++ + [ OptArg a1 a2' | a2' <- shrink a2 ] + +instance Arbitrary a => Arbitrary (ArgOrder a) where + arbitrary = oneof [ return RequireOrder + , return Permute + , ReturnInOrder <$> arbitrary + ] + + shrink RequireOrder = [] + shrink Permute = [] + shrink (ReturnInOrder a) = [ ReturnInOrder a' | a' <- shrink a ] + +instance Arbitrary a => Arbitrary (OptDescr a) where + arbitrary = Option + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + shrink (Option a b c d) = [ Option a' b c d | a' <- shrink a ] ++ + [ Option a b' c d | b' <- shrink b ] ++ + [ Option a b c' d | c' <- shrink c ] ++ + [ Option a b c d' | d' <- shrink d ] + +-- Data.Functor.Contravariant + +-- can maybe use Arbitrary1/2 for these +instance CoArbitrary a => Arbitrary (Predicate a) where + arbitrary = Predicate <$> arbitrary + + shrink (Predicate p) = [ Predicate p' | p' <- shrink p ] + +instance (Arbitrary a, CoArbitrary b) => Arbitrary (Op a b) where + arbitrary = Op <$> arbitrary + + shrink (Op f) = [ Op f' | f' <- shrink f ] + +instance CoArbitrary a => Arbitrary (Equivalence a) where + arbitrary = do + Comparison cmp <- arbitrary + return $ Equivalence (\x y -> cmp x y == EQ) + +instance CoArbitrary a => Arbitrary (Comparison a) where + arbitrary = do + Comparison . comparing <$> (liftArbitrary arbitrary :: Gen (a -> Integer)) + +#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 _ = [] + +#if defined(MIN_VERSION_base) +instance Arbitrary Newline where + arbitrary = elements [LF, CRLF] + + -- The behavior of code for LF is generally simpler than for CRLF + -- See the documentation for this type, which states that Haskell + -- Internally always assumes newlines are \n and this type represents + -- how to translate that to and from the outside world, where LF means + -- no translation. + shrink LF = [] + shrink CRLF = [LF] + +instance Arbitrary NewlineMode where + arbitrary = NewlineMode <$> arbitrary <*> arbitrary + + shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)] + +instance Arbitrary GeneralCategory where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum + +instance Arbitrary SeekMode where + arbitrary = elements [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + shrink x = takeWhile (x /=) [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + +instance Arbitrary TextEncoding where + arbitrary = elements [ latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 ] + +instance Arbitrary BufferMode where + arbitrary = oneof [ pure NoBuffering + , pure LineBuffering + , pure $ BlockBuffering Nothing + , BlockBuffering . Just . (+1) . fromIntegral <$> (arbitrary :: Gen Natural) + ] + shrink NoBuffering = [] + shrink LineBuffering = [ NoBuffering ] + shrink (BlockBuffering m) = [ NoBuffering, LineBuffering ] ++ map BlockBuffering (filter (maybe True (>0)) $ shrink m) + +instance Arbitrary IOMode where + arbitrary = elements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + shrink x = takeWhile (/=x) [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Arbitrary FormatSign where + arbitrary = elements [SignPlus, SignSpace] + shrink SignPlus = [] + shrink SignSpace = [SignPlus] + +instance Arbitrary FormatAdjustment where + arbitrary = elements [LeftAdjust, ZeroPad] + shrink LeftAdjust = [] + shrink ZeroPad = [LeftAdjust] + +instance Arbitrary FormatParse where + arbitrary = FormatParse <$> arbitrary <*> arbitrary <*> arbitrary + shrink (FormatParse a b c) = [ FormatParse a' b' c' | (a', b', c') <- shrink (a, b, c) ] + +instance Arbitrary FieldFormat where + arbitrary = FieldFormat <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (FieldFormat a b c d e f g) = [ FieldFormat a' b' c' d' e' f' g' | (a', b', c', d', e', f', g') <- shrink (a, b, c, d, e, f, g) ] + +#endif + +-- ** 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 + | isNonNegativeType fromI = arbitrarySizedNatural + | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n)) + where + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral + +isNonNegativeType :: Enum a => (Int -> a) -> Bool +isNonNegativeType fromI = + case enumFromThen (fromI 1) (fromI 0) of + [_, _] -> True + _ -> False + +-- | 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))) + +-- | Uniformly 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 -> do + denom <- chooseInt (1, max 1 n) + numer <- chooseInt (-n*denom, n*denom) + pure $ fromIntegral numer / fromIntegral denom + +-- 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 = + [ -x | x < 0, -x > x ] ++ + [ x - i | i <- takeWhile (/= 0) (iterate (`quot` 2) x)] + +-- | Shrink an element of a bounded enumeration. +-- +-- === __Example__ +-- +-- @ +-- data MyEnum = E0 | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 | E9 +-- deriving (Bounded, Enum, Eq, Ord, Show) +-- @ +-- +-- >>> shrinkBoundedEnum E9 +-- [E0,E5,E7,E8] +-- +-- >>> shrinkBoundedEnum E5 +-- [E0,E3,E4] +-- +-- >>> shrinkBoundedEnum E0 +-- [] +-- +shrinkBoundedEnum :: (Bounded a, Enum a, Eq a) => a -> [a] +shrinkBoundedEnum a + | a == minBound = + [] + | otherwise = + toEnum <$> filter (>= minBoundInt) (shrinkIntegral $ fromEnum a) + where + minBoundInt :: Int + minBoundInt = fromEnum (minBound `asTypeOf` a) + +-- | Shrink a fraction, preferring numbers with smaller +-- numerators or denominators. See also 'shrinkDecimal'. +shrinkRealFrac :: RealFrac a => a -> [a] +shrinkRealFrac x + | not (x == x) = 0 : takeWhile (< 1000) numbers -- NaN + | x > 0 && not (2*x+1>x) = 0 : takeWhile (= 0 + -- 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) + numbers = iterate (*2) 1 + +-- | Shrink a real number, preferring numbers with shorter +-- decimal representations. See also 'shrinkRealFrac'. +shrinkDecimal :: RealFrac a => a -> [a] +shrinkDecimal x + | not (x == x) = 0 : takeWhile (< 1000) numbers -- NaN + | not (2*abs x+1>abs x) = 0 : takeWhile (= 0 + -- 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 ] + where + -- 1, 2, 3, ..., 10, 20, 30, ..., 100, 200, 300, etc. + numbers = concat $ iterate (map (*10)) (map fromInteger [1..9]) + +-------------------------------------------------------------------------- +-- ** 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) +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 + +#if defined(MIN_VERSION_base) +instance CoArbitrary Natural where + coarbitrary = coarbitraryIntegral +#endif + +-- 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 +instance CoArbitrary a => CoArbitrary (Tree.Tree a) where + coarbitrary (Tree.Node val forest) = coarbitrary val . coarbitrary forest + +-- CoArbitrary instance for Ziplist +instance CoArbitrary a => CoArbitrary (ZipList a) where + coarbitrary = coarbitrary . getZipList + +-- CoArbitrary instance for NonEmpty +#if defined(MIN_VERSION_base) +instance CoArbitrary a => CoArbitrary (NonEmpty a) where + coarbitrary (a NonEmpty.:| as) = coarbitrary (a, as) +#endif + +#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) +instance CoArbitrary a => CoArbitrary (Monoid.First a) where + coarbitrary = coarbitrary . Monoid.getFirst + +instance CoArbitrary a => CoArbitrary (Monoid.Last a) where + coarbitrary = coarbitrary . Monoid.getLast + +instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where + coarbitrary = coarbitrary . Monoid.getAlt + +instance CoArbitrary a => CoArbitrary (Semigroup.Max a) where + coarbitrary = coarbitrary . Semigroup.getMax + +instance CoArbitrary a => CoArbitrary (Semigroup.Min a) where + coarbitrary = coarbitrary . Semigroup.getMin + +instance CoArbitrary a => CoArbitrary (Semigroup.First a) where + coarbitrary = coarbitrary . Semigroup.getFirst + +instance CoArbitrary a => CoArbitrary (Semigroup.Last a) where + coarbitrary = coarbitrary . Semigroup.getLast + +instance CoArbitrary Newline where + coarbitrary LF = variant 0 + coarbitrary CRLF = variant 1 + +instance CoArbitrary NewlineMode where + coarbitrary (NewlineMode inNL outNL) = coarbitrary inNL . coarbitrary outNL + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Semigroup.Arg a b) where + coarbitrary (Semigroup.Arg a b) = coarbitrary (a, b) + +instance CoArbitrary GeneralCategory where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary SeekMode where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary IOMode where +#if !defined(__MHS__) + coarbitrary = coarbitrary . fromEnum +#else + coarbitrary ReadMode = variant 0 + coarbitrary WriteMode = variant 1 + coarbitrary AppendMode = variant 2 + coarbitrary ReadWriteMode = variant 3 +#endif + +instance CoArbitrary FieldFormat where + coarbitrary ff = coarbitrary (fmtWidth ff) + . coarbitrary (fmtPrecision ff) + . coarbitrary (fmtAdjust ff) + . coarbitrary (fmtSign ff) + . coarbitrary (fmtAlternate ff) + . coarbitrary (fmtModifiers ff) + . coarbitrary (fmtChar ff) + +instance CoArbitrary FormatParse where + coarbitrary fp = coarbitrary (fpModifiers fp) + . coarbitrary (fpChar fp) + . coarbitrary (fpRest fp) + +instance CoArbitrary FormatAdjustment where + coarbitrary LeftAdjust = coarbitrary True + coarbitrary ZeroPad = coarbitrary False + +instance CoArbitrary FormatSign where + coarbitrary SignPlus = coarbitrary True + coarbitrary SignSpace = coarbitrary False + +instance CoArbitrary BufferMode where + coarbitrary = coarbitrary . embed + where embed NoBuffering = Left True + embed LineBuffering = Left False + embed (BlockBuffering m) = Right m + +instance CoArbitrary ExitCode where + coarbitrary = coarbitrary . embed + where embed ExitSuccess = Nothing + embed (ExitFailure i) = Just i + +#if !defined(__MHS__) +instance CoArbitrary TextEncoding where + coarbitrary = coarbitrary . show -- No other way as far as I can tell :( +#endif + +instance CoArbitrary a => CoArbitrary (Semigroup.WrappedMonoid a) where + coarbitrary = coarbitrary . Semigroup.unwrapMonoid + +#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 + + +-------------------------------------------------------------------------- +-- ** Rational helper + +infixr 5 :< +data Stream a = !a :< Stream a + +streamNth :: Int -> Stream a -> a +streamNth n (x :< xs) | n <= 0 = x + | otherwise = streamNth (n - 1) xs + +-- We read into this stream only with ~size argument, capped to 256, +-- so it's ok to have it as CAF. (256 chosen somewhat arbitrarily, the +-- point is just to stop this blowing up.) +-- +rationalUniverse :: Stream Rational +rationalUniverse = 0 :< 1 :< (-1) :< go leftSideStream + where + go (x :< xs) = + let nx = -x + rx = recip x + nrx = -rx + in nx `seq` rx `seq` nrx `seq` (x :< rx :< nx :< nrx :< go xs) + +-- All the rational numbers on the left side of the Calkin-Wilf tree, +-- in breadth-first order. +leftSideStream :: Stream Rational +leftSideStream = (1 % 2) :< go leftSideStream + where + go (x :< xs) = + lChild `seq` rChild `seq` + (lChild :< rChild :< go xs) + where + nd = numerator x + denominator x + lChild = numerator x % nd + rChild = nd % denominator x + +-------------------------------------------------------------------------- +-- the end. diff --git a/src/Test/QuickCheck/Compat.hs b/src/Test/QuickCheck/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Compat.hs @@ -0,0 +1,34 @@ +-- This module provides tools to simplify compat code across different compiler and library versions +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Compat where + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif + +#if MIN_VERSION_base(4,16,0) + +#if !MIN_VERSION_base(4,18,0) + +getSolo :: Solo a -> a +getSolo (Solo a) = a + +mkSolo :: a -> Solo a +mkSolo = Solo + +#elif !MIN_VERSION_base(4,19,0) + +getSolo :: Solo a -> a +getSolo (MkSolo a) = a + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#else + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#endif + +#endif diff --git a/src/Test/QuickCheck/Exception.hs b/src/Test/QuickCheck/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Exception.hs @@ -0,0 +1,118 @@ +-- | 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 #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +module Test.QuickCheck.Exception where + +#if (!defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)) && !defined(__MHS__) +#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 defined(MIN_VERSION_base) + 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 + +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. diff --git a/src/Test/QuickCheck/Features.hs b/src/Test/QuickCheck/Features.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Features.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +{-# 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 Test.QuickCheck.Random +import qualified Data.Set as Set +import Data.Set(Set) +import Data.List (intersperse) +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 (map fst $ filter snd $ P.classes res)) `Set.isSubsetOf` feats) -> + res{ok = Just False, P.reason = "New feature found"} + _ -> res + +-- | Given a property, which must use 'label', 'collect', 'classify' or 'cover' +-- to associate labels with test cases, find an example test case for each possible label. +-- The example test cases are minimised using shrinking. +-- +-- For example, suppose we test @'Data.List.delete' x xs@ and record the number +-- of times that @x@ occurs in @xs@: +-- +-- > prop_delete :: Int -> [Int] -> Property +-- > prop_delete x xs = +-- > classify (count x xs == 0) "count x xs == 0" $ +-- > classify (count x xs == 1) "count x xs == 1" $ +-- > classify (count x xs >= 2) "count x xs >= 2" $ +-- > counterexample (show (delete x xs)) $ +-- > count x (delete x xs) == max 0 (count x xs-1) +-- > where count x xs = length (filter (== x) xs) +-- +-- 'labelledExamples' generates three example test cases, one for each label: +-- +-- >>> labelledExamples prop_delete +-- *** Found example of count x xs == 0 +-- 0 +-- [] +-- [] +-- +-- *** Found example of count x xs == 1 +-- 0 +-- [0] +-- [] +-- +-- *** Found example of count x xs >= 2 +-- 5 +-- [5,5] +-- [5] +-- +-- +++ OK, passed 100 tests: +-- 78% count x xs == 0 +-- 21% count x xs == 1 +-- 1% count x xs >= 2 + + +labelledExamples :: Testable prop => prop -> IO () +labelledExamples prop = labelledExamplesWith stdArgs prop + +-- | A variant of 'labelledExamples' that takes test arguments. +labelledExamplesWith :: Testable prop => Args -> prop -> IO () +labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return () + +-- | A variant of 'labelledExamples' that returns a result. +labelledExamplesResult :: Testable prop => prop -> IO Result +labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop + +-- | A variant of 'labelledExamples' that takes test arguments and returns a result. +labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result +labelledExamplesWithResult args prop = loop Set.empty $ replay args + where + loop :: Set String -> Maybe (QCGen, Int) -> IO Result + loop feats replay = withNullTerminal $ \nullterm -> do + res <- quickCheckWithResult args{chatty = False, replay = replay} (prop_noNewFeatures feats prop) + let feats' = features (failingLabels res) (failingClasses res) + case res of + Failure{reason = "New feature found"} -> do + putStrLn $ + "*** Found example of " ++ + concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) + mapM_ putStrLn (failingTestCase res) + putStrLn "" + loop (Set.union feats feats') (Just (usedSeed res, usedSize res)) + _ -> do + out <- terminalOutput nullterm + putStr out + return res + at0 f s 0 0 = s + at0 f s n d = f n d diff --git a/src/Test/QuickCheck/Function.hs b/src/Test/QuickCheck/Function.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Function.hs @@ -0,0 +1,772 @@ +{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#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(..) + , mkFun + , applyFun + , apply + , applyFun2 + , applyFun3 + , (:->) + , Function(..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum + , functionElements + , 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 qualified Data.Tree as Tree +import Data.Int +import Data.Complex +import Data.Foldable(toList) +import Data.Functor.Identity +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.List.NonEmpty as NonEmpty +import Numeric.Natural +import qualified Data.Bits as Bits +import Data.Tuple +import Data.Ord +import Data.Functor.Contravariant +import Text.Printf +import System.IO +import System.Exit +import Data.Version +import Data.Array.Byte +import qualified GHC.Exts as Exts + +#if defined(__MHS__) +import Data.ZipList +import Control.WrappedMonad +#endif + +#if defined(MIN_VERSION_base) +import System.IO + ( Newline(..) + , NewlineMode(..) + ) +#endif + +#ifndef NO_FIXED +import Data.Fixed +#endif + +#ifndef NO_GENERICS +import GHC.Generics hiding (C) +#endif + +import Test.QuickCheck.Compat + +-------------------------------------------------------------------------- +-- 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) +#if defined(__MHS__) +{- This is a temporary fix for a deficiency in the MicroHs type checker. -} +abstract (Pair p) d xy = + case xy of + (x,y) -> abstract (fmap (\q -> abstract q d y) p) d x +#else +abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +#endif +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 = functionElements [minBound..maxBound] + +-- | Provides a 'Function' instance for small finite types. +functionElements :: Eq a => [a] -> (a->b) -> (a:->b) +functionElements xs f = Table [(x,f x) | x <- xs] + +-- | 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 (NonEmpty.NonEmpty a) where + function = functionMap (\(a NonEmpty.:| as) -> (a, as)) (\(a, as) -> a NonEmpty.:| as) + +instance Function a => Function (ZipList a) where + function = functionMap getZipList ZipList + +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 + +instance Function Natural where + function = functionIntegral + +-- 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 a => Function (Tree.Tree a) where + function = functionMap (\(Tree.Node x xs) -> (x,xs)) (uncurry Tree.Node) + +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 + +#if defined(MIN_VERSION_base) +instance Function Newline where + function = functionMap g h + where + g LF = False + g CRLF = True + + h False = LF + h True = CRLF + +instance Function NewlineMode where + function = functionMap g h + where + g (NewlineMode inNL outNL) = (inNL,outNL) + h (inNL,outNL) = NewlineMode inNL outNL +#endif + +-- 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 + +instance Function (f a) => Function (Monoid.Alt f a) where + function = functionMap Monoid.getAlt Monoid.Alt + +instance Function a => Function (Semigroup.Min a) where + function = functionMap Semigroup.getMin Semigroup.Min + +instance Function a => Function (Semigroup.Max a) where + function = functionMap Semigroup.getMax Semigroup.Max + +instance Function a => Function (Semigroup.Last a) where + function = functionMap Semigroup.getLast Semigroup.Last + +instance Function a => Function (Semigroup.First a) where + function = functionMap Semigroup.getFirst Semigroup.First + +instance Function a => Function (Semigroup.WrappedMonoid a) where + function = functionMap Semigroup.unwrapMonoid Semigroup.WrapMonoid + +instance (Function a, Function b) => Function (Semigroup.Arg a b) where + function = functionMap (\(Semigroup.Arg a b) -> (a, b)) (uncurry Semigroup.Arg) + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Bits.And a) where + function = functionMap Bits.getAnd Bits.And + +instance Function a => Function (Bits.Ior a) where + function = functionMap Bits.getIor Bits.Ior + +instance Function a => Function (Bits.Xor a) where + function = functionMap Bits.getXor Bits.Xor + +instance Function a => Function (Bits.Iff a) where + function = functionMap Bits.getIff Bits.Iff +#endif + +instance Function FormatSign where + function = functionMap (\x -> case x of SignPlus -> True; _ -> False) (\b -> if b then SignPlus else SignSpace) + +instance Function FormatAdjustment where + function = functionMap (\x -> case x of LeftAdjust -> True; _ -> False) (\b -> if b then LeftAdjust else ZeroPad) + +instance Function FormatParse where + function = functionMap to from + where to fp = (fpModifiers fp, fpChar fp, fpRest fp) + from (a, b, c) = FormatParse a b c + +instance Function FieldFormat where + function = functionMap to from + where to ff = ( fmtWidth ff + , fmtPrecision ff + , fmtAdjust ff + , fmtSign ff + , fmtAlternate ff + , fmtModifiers ff + , fmtChar ff) + from (a, b, c, d, e, f, g) = FieldFormat a b c d e f g + +instance Function GeneralCategory where + function = functionBoundedEnum + +instance Function SeekMode where + function = functionElements [AbsoluteSeek, RelativeSeek, SeekFromEnd] + +instance Function IOMode where + function = functionElements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Function BufferMode where + function = functionMap to from + where to NoBuffering = Left True + to LineBuffering = Left False + to (BlockBuffering m) = Right m + + from (Left True) = NoBuffering + from (Left False) = LineBuffering + from (Right m) = BlockBuffering m + +instance Function ExitCode where + function = functionMap to from + where to ExitSuccess = Nothing + to (ExitFailure c) = Just c + + from Nothing = ExitSuccess + from (Just c) = ExitFailure c + +instance Function Version where + function = functionMap to from + where to (Version a b) = (a, b) + from (a, b) = Version a b + +#if !defined(__MHS__) +instance Function ByteArray where + function = functionMap Exts.toList Exts.fromList +#endif + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Solo a) where + function = functionMap getSolo mkSolo +#endif + +instance Function a => Function (Down a) where + function = functionMap getDown Down + +#if !MIN_VERSION_base(4,15,0) +instance Function a => Function (Semigroup.Option a) where + function = functionMap Semigroup.getOption Semigroup.Option +#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 :: Eq aa => [(aa,cc)] -> (aa :-> cc) -- MicroHs needs this + 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) +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE Fn #-} +#endif + +-- | 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) +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE Fn2 #-} +#endif + +-- | 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) +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE Fn3 #-} +#endif +#endif + +-- | Create a `Fun` from a function representation and a default value (in case the function +-- is partial). +mkFun :: (a :-> b) -> b -> Fun a b +mkFun p d = Fun (p, d, NotShrunk) (abstract p d) + +-- | Alias to 'applyFun'. +apply :: Fun a b -> (a -> b) +apply = applyFun + +-- | Extracts the value of a function. +-- +-- 'Fn' is the pattern equivalent of this function. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop f = applyFun f "banana" == applyFun f "monkey" +-- > || applyFun f "banana" == applyFun f "elephant" +applyFun :: Fun a b -> (a -> b) +applyFun (Fun _ f) = f + +-- | Extracts the value of a binary function. +-- +-- 'Fn2' is the pattern equivalent of this function. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] +-- +applyFun2 :: Fun (a, b) c -> (a -> b -> c) +applyFun2 (Fun _ f) a b = f (a, b) + +-- | Extracts the value of a ternary function. 'Fn3' is the +-- pattern equivalent of this function. +applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) +applyFun3 (Fun _ f) a b c = f (a, b, c) + +instance (Show a, Show b) => Show (Fun a b) where + show (Fun (_, _, NotShrunk) _) = "" + show (Fun (p, d, Shrunk) _) = showFunction p (Just d) + +instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where + arbitrary = + do p <- arbitrary + d <- arbitrary + return (mkFun p d) + + shrink (Fun (p, d, s) f) = + [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ + [ Fun (p, d, Shrunk) f | s == NotShrunk ] + +-------------------------------------------------------------------------- +-- the end. diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Gen.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#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 Test.QuickCheck.Exception + +import System.Random + ( Random + , random + , randomR + ) + +import Control.Monad + ( ap + , replicateM + , filterM + ) + +import Control.Monad.Fix + ( MonadFix(..) ) + +import Control.Applicative + ( Applicative(..) ) + +import Test.QuickCheck.Random +import Data.List (sortBy) +import Data.Ord +import Data.Maybe +#ifndef NO_SPLITMIX +import System.Random.SplitMix(bitmaskWithRejection64', nextInteger, nextDouble, nextFloat, SMGen) +#endif +import Data.Word +import Data.Int +import Data.Bits +import Control.Applicative +#ifndef NO_CALLSTACK +import GHC.Stack +#define WITHCALLSTACK(ty) HasCallStack => ty +#else +#define WITHCALLSTACK(ty) ty +#endif + +-------------------------------------------------------------------------- +-- ** Generator type + +-- | A generator for values of type @a@. +-- +-- The third-party packages +-- +-- and +-- +-- provide monad transformer versions of @Gen@. +newtype Gen a = MkGen{ + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed and size. + -- 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 splitImpl 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 :: WITHCALLSTACK(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 'System.IO.stdout'. +sample :: Show a => Gen a -> IO () +sample g = + sequence_ [ do r <- newQCGen + munit <- tryEvaluateIO (print $ unGen g r n) + case munit of + Left e + | isDiscard e -> putStrLn "" + | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map (" " ++) (lines $ show e) + Right () -> return () + | n <- [0,2..20] ] + +-------------------------------------------------------------------------- +-- ** Floating point + +-- | Generate 'Double' in 0..1 range +genDouble :: Gen Double + +-- | Generate 'Float' in 0..1 range +genFloat :: Gen Float + +#ifndef NO_SPLITMIX +genDouble = MkGen $ \(QCGen g) _ -> fst (nextDouble g) +genFloat = MkGen $ \(QCGen g) _ -> fst (nextFloat g) +#else +genDouble = choose (0,1) +genFloat = choose (0,1) +#endif + +-------------------------------------------------------------------------- +-- ** 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 :: WITHCALLSTACK([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 :: WITHCALLSTACK([(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 :: WITHCALLSTACK([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 :: WITHCALLSTACK([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. diff --git a/src/Test/QuickCheck/Gen/Unsafe.hs b/src/Test/QuickCheck/Gen/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Gen/Unsafe.hs @@ -0,0 +1,53 @@ +{-# 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 +import Control.Applicative + +-- | Promotes a monadic generator to a generator of monadic values. +promote :: Monad m => m (Gen a) -> Gen (m a) +promote m = flip liftM m <$> delay + +-- | 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 diff --git a/src/Test/QuickCheck/Modifiers.hs b/src/Test/QuickCheck/Modifiers.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Modifiers.hs @@ -0,0 +1,549 @@ +{-# 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 :: ['Test.QuickCheck.Poly.A']) = +-- takeWhile p xs ++ dropWhile p xs == xs +-- @ +-- +-- @ +-- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) = +-- take n xs ++ drop n xs == xs +-- @ +-- +-- @ +-- -- cycle does not work for empty lists +-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) = +-- take n (cycle xs) == take n (xs ++ cycle xs) +-- @ +-- +-- @ +-- -- Instead of 'Test.QuickCheck.forAll' 'orderedList' +-- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.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(..) + , NoShrink(..) +#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 Arbitrary1 NonEmptyList where + liftArbitrary = fmap NonEmpty . listOf1 + liftShrink shr = map NonEmpty . filter (not . null) . shrinkList shr . getNonEmpty + +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = arbitrary1 + shrink = shrink1 + +---------------------------------------------------------------------- +-- | @InfiniteList xs _@: guarantees that xs is an infinite list. +-- When a counterexample is found, only prints the prefix of xs +-- that was used by the program. +-- +-- Here is a contrived example property: +-- +-- > prop_take_10 :: InfiniteList Char -> Bool +-- > prop_take_10 (InfiniteList xs _) = +-- > or [ x == \'a\' | x <- take 10 xs ] +-- +-- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but +-- the remaining (infinite) part can contain anything: +-- +-- >>> quickCheck prop_take_10 +-- *** Failed! Falsified (after 1 test and 14 shrinks): +-- "bbbbbbbbbb" ++ ... +data InfiniteList a = + InfiniteList { + getInfiniteList :: [a], + infiniteListInternalData :: InfiniteListInternalData a } + +-- Uses a similar trick to Test.QuickCheck.Function: +-- the Arbitrary instance generates an infinite list, which is +-- reduced to a finite prefix by shrinking. We use discard to +-- check that nothing coming after the finite prefix is used +-- (see infiniteListFromData). +data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] + +infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a +infiniteListFromData info@(Infinite xs) = InfiniteList xs info +infiniteListFromData info@(FinitePrefix xs) = + InfiniteList (xs ++ discard) info + +instance Show a => Show (InfiniteList a) where + showsPrec _ (InfiniteList _ (Infinite _)) = + ("" ++) + showsPrec n (InfiniteList _ (FinitePrefix xs)) = + (if n > 10 then ('(':) else id) . + showsPrec 0 xs . + (" ++ ..." ++) . + (if n > 10 then (')':) else id) + +instance Arbitrary a => Arbitrary (InfiniteList a) where + arbitrary = fmap infiniteListFromData arbitrary + shrink (InfiniteList _ info) = + map infiniteListFromData (shrink info) + +instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where + arbitrary = fmap Infinite infiniteList + shrink (Infinite xs) = + [FinitePrefix (take n xs) | n <- map (2^) [0..]] + shrink (FinitePrefix xs) = + map FinitePrefix (shrink xs) + +-------------------------------------------------------------------------- +-- | @Sorted xs@: guarantees that xs is sorted. +newtype SortedList a = Sorted {getSorted :: [a]} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor SortedList where + fmap f (Sorted x) = Sorted (map f x) + +instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where + arbitrary = fmap (Sorted . sort) arbitrary + + shrink (Sorted xs) = + [ Sorted xs' + | xs' <- map sort (shrink xs) + ] + +-------------------------------------------------------------------------- +-- | @Positive x@: guarantees that @x \> 0@. +newtype Positive a = Positive {getPositive :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Positive where + fmap f (Positive x) = Positive (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where + arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) + shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] + +-------------------------------------------------------------------------- +-- | @Negative x@: guarantees that @x \< 0@. +newtype Negative a = Negative {getNegative :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Negative where + fmap f (Negative x) = Negative (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where + arbitrary = fmap Negative (fmap (negate . abs) 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 + +-------------------------------------------------------------------------- +-- | @NoShrink x@: no shrinking +newtype NoShrink a = NoShrink {getNoShrink :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NoShrink where + fmap f (NoShrink x) = NoShrink (f x) + +instance Arbitrary a => Arbitrary (NoShrink a) where + arbitrary = fmap NoShrink arbitrary + +-------------------------------------------------------------------------- +-- | @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. diff --git a/src/Test/QuickCheck/Monadic.hs b/src/Test/QuickCheck/Monadic.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Monadic.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +{-| +Module : Test.QuickCheck.Monadic + +Allows testing of monadic values. Will generally follow this form: + +@ +prop_monadic a b = 'monadicIO' $ do + a\' \<- 'run' (f a) + b\' \<- 'run' (f b) + -- ... + 'assert' someBoolean +@ + +Example using the @FACTOR(1)@ command-line utility: + +@ +import System.Process +import Test.QuickCheck +import Test.QuickCheck.Monadic + +-- $ factor 16 +-- 16: 2 2 2 2 +factor :: Integer -> IO [Integer] +factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where + + parse :: String -> [Integer] + parse = map read . tail . words + +prop_factor :: Positive Integer -> Property +prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do + factors \<- 'run' (factor n) + + 'assert' (product factors == n) +@ + +>>> quickCheck prop_factor ++++ OK, passed 100 tests. + +See the paper \"\". +-} +module Test.QuickCheck.Monadic ( + -- * Property monad + PropertyM(..) + + -- * Monadic specification combinators + , run + , assert + , assertWith + , pre + , wp + , pick + , forAllM + , monitor + , stop + + -- * Run functions + , monadic + , monadic' + , monadicIO +#ifndef NO_ST_MONAD + , monadicST + , runSTGen +#endif + + -- * Exceptions + +#ifndef NO_EXCEPTIONS + , assertException + , assertExceptionIO +#ifndef NO_DEEPSEQ + , assertDeepException + , assertDeepExceptionIO +#endif +#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 + +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif + +#ifndef NO_EXCEPTIONS +import qualified Control.Exception as E +#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 + +#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" + +-- | Like 'assert' but allows caller to specify an explicit message to show on failure. +-- +-- __Example:__ +-- +-- @ +-- do +-- assertWith True "My first predicate." +-- assertWith False "My other predicate." +-- ... +-- @ +-- +-- @ +-- Assertion failed (after 2 tests): +-- Passed: My first predicate +-- Failed: My other predicate +-- @ +assertWith :: Monad m => Bool -> String -> PropertyM m () +assertWith condition msg = do + let prefix = if condition then "Passed: " else "Failed: " + monitor $ counterexample $ prefix ++ msg + assert condition + +-- should think about strictness/exceptions here +-- | Tests preconditions. Unlike 'assert' this does not cause the +-- property to fail, rather it discards them just like using the +-- implication combinator 'Test.QuickCheck.Property.==>'. +-- +-- This allows representing the +-- +-- > {p} x ← e{q} +-- +-- as +-- +-- @ +-- pre p +-- x \<- run e +-- assert q +-- @ +-- +pre :: Monad m => Bool -> PropertyM m () +pre True = return () +pre False = stop rejected + +-- should be called lift? +-- | The lifting operation of the property monad. Allows embedding +-- monadic\/'IO'-actions in properties: +-- +-- @ +-- log :: Int -> IO () +-- +-- prop_foo n = monadicIO $ do +-- run (log n) +-- -- ... +-- @ +run :: Monad m => m a -> PropertyM m a +run m = MkPropertyM (liftM (m >>=) . promote) + +-- | Quantification in a monadic property, fits better with +-- /do-notation/ than 'forAllM'. +-- __Note__: values generated by 'pick' do not shrink. +pick :: (Monad m, Show a) => Gen a -> PropertyM m a +pick gen = MkPropertyM $ \k -> + do a <- gen + mp <- k a + return (do p <- mp + return (forAll (return a) (const p))) + +-- | The +-- +-- > wp(x ← e, p) +-- +-- can be expressed as in code as @wp e (\\x -> p)@. +wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b +wp m k = run m >>= k + +-- | Quantification in monadic properties to 'pick', with a notation similar to +-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. + +forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b +forAllM gen k = pick gen >>= k + +-- | Allows making observations about the test data: +-- +-- @ +-- monitor ('collect' e) +-- @ +-- +-- collects the distribution of value of @e@. +-- +-- @ +-- monitor ('counterexample' "Failure!") +-- @ +-- +-- Adds @"Failure!"@ to the counterexamples. +monitor :: Monad m => (Property -> Property) -> PropertyM m () +monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) + +-- run functions + +monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property +monadic runner m = property (fmap runner (monadic' m)) + +monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) +monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) + +-- | Runs the property monad for 'IO'-computations. +-- +-- @ +-- prop_cat msg = monadicIO $ do +-- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) +-- +-- pre ('System.Exit.ExitSuccess' == exitCode) +-- +-- assert (stdout == msg) +-- @ +-- +-- >>> quickCheck prop_cat +-- +++ OK, passed 100 tests. +-- +monadicIO :: Testable a => PropertyM IO a -> Property +monadicIO = monadic ioProperty + +#ifndef NO_ST_MONAD +-- | Runs the property monad for 'ST'-computations. +-- +-- @ +-- -- Your mutable sorting algorithm here +-- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) +-- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' +-- +-- prop_sortST xs = monadicST $ do +-- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) +-- assert ('Data.Vector.toList' sorted == sort xs) +-- @ +-- +-- >>> quickCheck prop_sortST +-- +++ OK, passed 100 tests. +-- +monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property +monadicST m = property (runSTGen (monadic' m)) + +runSTGen :: (forall s. Gen (ST s a)) -> Gen a +runSTGen f = do + Capture eval <- capture + return (runST (eval f)) +#endif + +-- Exceptions + + +#ifndef NO_EXCEPTIONS + +-- | Evaluate the value to Weak Head Normal Form (WHNF) and fail if it does not result in +-- an expected exception being thrown. +assertException :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when evaluated to WHNF + -> Property +assertException isExc value = assertExceptionIO isExc (return value) + + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to WHNF. +assertExceptionIO :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertExceptionIO isExc action = + monadicIO $ do + hasFailed <- + run + (E.catch + (do res <- action + res `seq` return False) + (return . isExc)) + assert hasFailed + +#ifndef NO_DEEPSEQ + +-- | Same as `assertException`, but evaluate the value to Normal Form (NF) and fail if it +-- does not result in an expected exception being thrown. +assertDeepException :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when fully evaluated to NF + -> Property +assertDeepException isExc value = assertException isExc (rnf value) + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to NF. +assertDeepExceptionIO :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertDeepExceptionIO isExc action = assertExceptionIO isExc (fmap rnf action) + +#endif +#endif + +-------------------------------------------------------------------------- +-- the end. diff --git a/src/Test/QuickCheck/Monoids.hs b/src/Test/QuickCheck/Monoids.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Monoids.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Safe #-} + +module Test.QuickCheck.Monoids + ( Every (..) + , Some (..) + ) where + +#ifndef NO_SEMIGROUP +import Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..)) +#endif +import Test.QuickCheck.Property + +-- | Conjunction monoid built with `.&&.`. +-- +-- Use `property @Every` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Every = forall p. Testable p => Every { getEvery :: p } +#else +data Every = forall p. Testable p => Every p +#endif + +instance Testable Every where + property (Every p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Every where + Every p <> Every p' = Every (p .&&. p') + sconcat = Every . conjoin . NonEmpty.toList + +instance Monoid Every where + mempty = Every True + mappend = (<>) + mconcat = Every . conjoin +#else +instance Monoid Every where + mempty = Every True + mappend (Every p) (Every p') = Every (p .&&. p') + mconcat = Every . conjoin +#endif + + +-- | Disjunction monoid built with `.||.`. +-- +-- Use `property @Some` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Some = forall p. Testable p => Some { getSome :: p } +#else +data Some = forall p. Testable p => Some p +#endif + +instance Testable Some where + property (Some p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Some where + Some p <> Some p' = Some (p .||. p') + sconcat = Some . disjoin . NonEmpty.toList + +instance Monoid Some where + mempty = Some False + mappend = (<>) + mconcat = Some . disjoin +#else +instance Monoid Some where + mempty = Some False + mappend (Some p) (Some p') = Some (p .||. p') + mconcat = Some . disjoin +#endif diff --git a/src/Test/QuickCheck/Poly.hs b/src/Test/QuickCheck/Poly.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Poly.hs @@ -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. diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Property.hs @@ -0,0 +1,1099 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Combinators for constructing properties. +{-# LANGUAGE CPP #-} +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +#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, numSuccessTests, numDiscardedTests, maxSuccessTests, numSuccessShrinks, numTryShrinks, numTotTryShrinks), Confidence(..), TestProgress(..) ) + +#ifndef NO_TIMEOUT +import System.Timeout(timeout) +#endif +import Data.Maybe +import Control.Applicative +#if defined(MIN_VERSION_base) +import Control.Exception (displayException) +#endif +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, cast) +#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'. +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 (property 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. +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 x = MkRose x [] + -- f must be total + (<*>) = liftM2 ($) + +instance Monad Rose where + return = pure + -- 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 + +#ifndef NO_TYPEABLE +data Witness = forall a. (Typeable a, Show a) => Wit a + +instance Show Witness where + show (Wit a) = show a + +coerceWitness :: Typeable a => Witness -> a +coerceWitness (Wit a) = case cast a of + Nothing -> error $ "Can't coerceWitness " ++ show a + Just a -> a + +castWitness :: Typeable a => Witness -> Maybe a +castWitness (Wit a) = cast a + +#define WITNESSES(a) , theWitnesses a +#else +#define WITNESSES(a) +#endif + +-- | 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 + , maybeDiscardedRatio :: Maybe Int + -- ^ maximum number of discarded tests per successful test + , maybeMaxShrinks :: Maybe Int + -- ^ maximum number of shrinks + , maybeMaxTestSize :: Maybe Int + -- ^ maximum test size + , labels :: [String] + -- ^ test case labels + , classes :: [(String, Bool)] + -- ^ 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 + WITNESSES(:: [Witness]) + } + +exception :: String -> AnException -> Result +exception msg err + | isDiscard err = rejected + | otherwise = failed{ reason = formatException msg err, + theException = Just err } + +formatException :: String -> AnException -> String +#if defined(MIN_VERSION_base) +formatException msg err = msg ++ ":" ++ format (displayException err) +#else +formatException msg err = msg ++ ":" ++ format (show err) +#endif + where format xs | isOneLine xs = " '" ++ xs ++ "'" + | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] + +protectResult :: IO Result -> IO Result +protectResult = protect (exception "Exception") + +succeeded, failed, rejected :: Result +(succeeded, failed, rejected) = + (result{ ok = Just True }, + result{ ok = Just False }, + result{ ok = Nothing }) + where + result = + MkResult + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = False + , maybeNumTests = Nothing + , maybeCheckCoverage = Nothing + , maybeDiscardedRatio = Nothing + , maybeMaxShrinks = Nothing + , maybeMaxTestSize = Nothing + , labels = [] + , classes = [] + , tables = [] + , requiredCoverage = [] + , callbacks = [] + , testCase = [] + WITNESSES(= []) + } + +-------------------------------------------------------------------------- +-- ** 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 () + +-- | Performs an IO action every time a property is tested, after every test. +-- The IO action is allowed to depend on @TestProgress@, which contains information +-- regarding how testing is progressing. +-- +-- Note: QC invokes callbacks before the internal state has been updated to reflect the +-- most recent test. The means that e.g. @currentPassed@ will, after the first test has +-- been executed, still show 0. +withProgress :: Testable prop => (TestProgress -> IO ()) -> prop -> Property +withProgress m = + callback $ PostTest NotCounterexample $ \st _r -> + let tp = TestProgress { currentPassed = numSuccessTests st + , currentDiscarded = numDiscardedTests st + , maxTests = maxSuccessTests st + , currentShrinks = numSuccessShrinks st + , currentFailedShrinks = numTryShrinks st + , currentTotalShrinks = numTotTryShrinks st + } + in m tp + +-- | 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. +{-# DEPRECATED withMaxSuccess "Use withNumTests instead" #-} +withMaxSuccess :: Testable prop => Int -> prop -> Property +withMaxSuccess = withNumTests + +-- | Configures how many times a property will be tested. +-- +-- For example, +-- +-- > quickCheck (withNumTests 1000 p) +-- +-- will test @p@ up to 1000 times. +withNumTests :: Testable prop => Int -> prop -> Property +withNumTests n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) + +-- | Configures how many times a property is allowed to be discarded before failing. +-- +-- For example, +-- +-- > quickCheck (withDiscardRatio 10 p) +-- +-- will allow @p@ to fail up to 10 times per successful test. +withDiscardRatio :: Testable prop => Int -> prop -> Property +withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n }) + +-- | Configure the maximum number of times a property will be shrunk. +-- +-- For example, +-- +-- > quickCheck (withMaxShrinks 100 p) +-- +-- will cause @p@ to only attempt 100 shrinks on failure. +withMaxShrinks :: Testable prop => Int -> prop -> Property +withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n }) + +-- | Configure the maximum size a property will be tested at. +withMaxSize :: Testable prop => Int -> prop -> Property +withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n }) + +#ifndef NO_TYPEABLE +-- | Return a value in the 'Test.QuickCheck.witnesses' field of the 'Result' +-- returned by 'Test.QuickCheck.quickCheckResult'. Witnesses are returned +-- outer-most first. +-- +-- In ghci, for example: +-- +-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int) +-- *** Failed! Falsified (after 2 tests): +-- 1 +-- >>> x +-- 1 +-- >>> :t x +-- x :: Int +witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property +witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res }) +#endif + +-- | 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 b s = +#ifndef NO_DEEPSEQ + s `deepseq` +#endif + b `seq` + mapTotalResult $ + \res -> res { classes = (s, b):classes res } + +-- | Checks that at least the given proportion of /successful/ test +-- cases belong to the given class. Discarded tests (i.e. ones +-- with a false precondition) do not affect coverage. +-- +-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but +-- the property does /not/ fail. To make the property fail, use 'checkCoverage'. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > cover 50 (length xs > 1) "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). +-- +-- Only 26% non-trivial, but expected 50% +cover :: Testable prop => + Double -- ^ The required percentage (0-100) of test cases. + -> Bool -- ^ @True@ if the test case belongs to the class. + -> String -- ^ Label for the test case class. + -> prop -> Property +cover p x s = mapTotalResult f . classify x s + where + f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res } + +-- | Collects information about test case distribution into a table. +-- The arguments to 'tabulate' are the table's name and a list of values +-- associated with the current test case. After testing, QuickCheck prints the +-- frequency of all collected values. The frequencies are expressed as a +-- percentage of the total number of values collected. +-- +-- You should prefer 'tabulate' to 'label' when each test case is associated +-- with a varying number of values. Here is a (not terribly useful) example, +-- where the test data is a list of integers and we record all values that +-- occur in the list: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > tabulate "List elements" (map show xs) $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests; 1684 discarded. +-- +-- List elements (109 in total): +-- 3.7% 0 +-- 3.7% 17 +-- 3.7% 2 +-- 3.7% 6 +-- 2.8% -6 +-- 2.8% -7 +-- +-- Here is a more useful example. We are testing a chatroom, where the user can +-- log in, log out, or send a message: +-- +-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) +-- > instance Arbitrary Command where ... +-- +-- There are some restrictions on command sequences; for example, the user must +-- log in before doing anything else. The function @valid :: [Command] -> Bool@ +-- checks that a command sequence is allowed. Our property then has the form: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > valid cmds ==> +-- > ... +-- +-- The use of '==>' may skew test case distribution. We use 'collect' to see the +-- length of the command sequences, and 'tabulate' to get the frequencies of the +-- individual commands: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > 'collect' (length cmds) $ +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... +-- +-- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom +-- +++ OK, passed 100 tests; 2775 discarded: +-- 60% 0 +-- 20% 1 +-- 15% 2 +-- 3% 3 +-- 1% 4 +-- 1% 5 +-- +-- Commands (68 in total): +-- 62% LogIn +-- 22% SendMessage +-- 16% LogOut +tabulate :: Testable prop => String -> [String] -> prop -> Property +tabulate key values = +#ifndef NO_DEEPSEQ + key `deepseq` values `deepseq` +#endif + mapTotalResult $ + \res -> res { tables = [(key, value) | value <- values] ++ tables res } + +-- | Checks that the values in a given @table@ appear a certain proportion of +-- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts +-- that of the values in @table@, @x1@ should appear at least @p1@ percent of +-- the time that @table@ appears, @x2@ at least @p2@ percent of the time that +-- @table@ appears, 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 'tabulate' combinator... +-- +-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... +-- +-- ...we can add a coverage requirement as follows, which checks that @LogIn@, +-- @LogOut@ and @SendMessage@ each occur at least 25% of the time: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... property goes here ... +-- +-- >>> quickCheck prop_chatroom +-- +++ OK, passed 100 tests; 2909 discarded: +-- 56% 0 +-- 17% 1 +-- 10% 2 +-- 6% 3 +-- 5% 4 +-- 3% 5 +-- 3% 7 +-- +-- Commands (111 in total): +-- 51.4% LogIn +-- 30.6% SendMessage +-- 18.0% LogOut +-- +-- Table 'Commands' had only 18.0% LogOut, but expected 25.0% +coverTable :: Testable prop => + String -> [(String, Double)] -> prop -> Property +coverTable table xs = +#ifndef NO_DEEPSEQ + table `deepseq` xs `deepseq` +#endif + mapTotalResult $ + \res -> res { requiredCoverage = ys ++ requiredCoverage res } + where + ys = [(Just table, x, p/100) | (x, p) <- xs] + +-- | Implication for properties: The resulting property holds if +-- the first argument is 'False' (in which case the test case is discarded), +-- or if the given property holds. Note that using implication carelessly can +-- severely skew test case distribution: consider using 'cover' to make sure +-- that your test data is still good quality. +(==>) :: Testable prop => Bool -> prop -> Property +False ==> _ = property Discard +True ==> p = property p + +-- | Considers a property failed if it does not complete within +-- the given number of microseconds. +-- +-- Note: if the property times out, variables quantified inside the +-- `within` will not be printed. Therefore, you should use `within` +-- only in the body of your property. +-- +-- Good: @prop_foo a b c = within 1000000 ...@ +-- +-- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@ +-- +-- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@ +within :: Testable prop => Int -> prop -> Property +within n = onTimeout + (failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." }) + n + +-- | Discards the test case if it does not complete within the given +-- number of microseconds. This can be useful when testing algorithms +-- that have pathological cases where they run extremely slowly. +discardAfter :: Testable prop => Int -> prop -> Property +discardAfter n = onTimeout + (rejected { reason = "Timeout of " ++ show n ++ " microseconds exceeded." }) + n + +onTimeout :: Testable prop => Result -> Int -> prop -> Property +onTimeout timeoutResult n = mapRoseResult f + where + f rose = ioRose $ do + let orError :: IO (Maybe a) -> a -> IO a + 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)) +#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 = + 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 = + MkProperty $ + arbitrary >>= \b -> + unProperty $ + counterexample (if b then "LHS" else "RHS") $ + if b then property p1 else property p2 + +-- | Conjunction: @p1@ '.&&.' @p2@ passes if both @p1@ and @p2@ pass. +(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .&&. p2 = conjoin [property p1, property p2] + +-- | Take the conjunction of several properties. +conjoin :: Testable prop => [prop] -> Property +conjoin ps = + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps + return (MkProp (conj id roses)) + where + conj k [] = + MkRose (k succeeded) [] + + conj k (p : ps) = IORose $ do + rose@(MkRose result _) <- reduceRose p + case ok result of + _ | not (expect result) -> + return (return failed { reason = "expectFailure may not occur inside a conjunction" }) + Just True -> return (conj (addLabels result . 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 = + 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, + maybeDiscardedRatio = Nothing, + maybeMaxShrinks = Nothing, + maybeMaxTestSize = Nothing, + labels = [], + classes = [], + tables = [], + requiredCoverage = [], + callbacks = + callbacks result1 ++ + [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ + callbacks result2, + testCase = + testCase result1 ++ + testCase result2 + WITNESSES(= theWitnesses result1 ++ theWitnesses 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. diff --git a/src/Test/QuickCheck/Random.hs b/src/Test/QuickCheck/Random.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Random.hs @@ -0,0 +1,131 @@ +{-# 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] + +splitImpl :: QCGen -> (QCGen, QCGen) +#ifdef NO_SPLITMIX +splitImpl (QCGen g) = + case split g of + (g1, g2) -> (QCGen g1, QCGen g2) +#else +splitImpl (QCGen g) = + case splitSMGen g of + (g1, g2) -> (QCGen g1, QCGen g2) +#endif + +instance RandomGen QCGen where +#if !MIN_VERSION_random(1,3,0) + split = splitImpl +#endif +#ifdef NO_SPLITMIX + genRange (QCGen g) = genRange g + next = wrapQCGen next +#else + 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) +#if MIN_VERSION_random(1,3,0) + genShortByteString n = wrapQCGen (uniformShortByteString n) +#endif +#endif +#endif + +#if MIN_VERSION_random(1,3,0) +instance SplitGen QCGen where + splitGen = splitImpl +#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 . splitImpl + right = snd . splitImpl + +-- 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) diff --git a/src/Test/QuickCheck/State.hs b/src/Test/QuickCheck/State.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/State.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +{-# 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 + -- ^ how to compute the size of test cases from + -- #tests and #discarded tests + , numTotMaxShrinks :: !Int + -- ^ How many shrinks to try before giving up + , replayStartSize :: Maybe Int + -- ^ Size to start at when replaying + , maxTestSize :: !Int + -- ^ Maximum size of test + + -- 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 'Test.QuickCheck.checkCoverage'. +data Confidence = + Confidence { + certainty :: Integer, + -- ^ How certain 'Test.QuickCheck.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 'Test.QuickCheck.checkCoverage' at the cost of + -- false positives. + -- + -- If you are using 'Test.QuickCheck.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 'Test.QuickCheck.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, 'Test.QuickCheck.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 'Test.QuickCheck.checkCoverage' at the cost of + -- not detecting minor coverage violations. + } + deriving Show + +-- | TestProgress, contains information that might be interesting to external +-- libraries, e.g. Tasty. From this it is possible to install your own callbacks +-- that reports e.g. progress. +data TestProgress + = TestProgress + { currentPassed :: Int -- ^ Number of tests passed so far + , currentDiscarded :: Int -- ^ Number of discared tests so far + , maxTests :: Int -- ^ Number of tests to execute + , currentShrinks :: Int -- ^ Number of successful shrinking steps + , currentFailedShrinks :: Int -- ^ Number of failed shrinking steps since last successful one + , currentTotalShrinks :: Int -- ^ Total number of failed shrinking steps + } deriving Show + +-------------------------------------------------------------------------- +-- the end. diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Test.hs @@ -0,0 +1,780 @@ +{-# 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 Control.Applicative +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 +#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 +import Data.Maybe + +#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 do 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') +#ifndef NO_TYPEABLE + , witnesses :: [Witness] + -- ^ The existentially quantified witnesses provided by 'witness' +#endif + } + -- | 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 'System.IO.stdout'. +-- +-- By default up to 100 tests are performed, which may not be enough +-- to find all bugs. To run more tests, use 'withNumTests'. +-- +-- If you want to get the counterexample as a Haskell value, +-- rather than just printing it, try the +-- +-- package. + +quickCheck :: Testable prop => prop -> IO () +quickCheck p = quickCheckWith stdArgs p + +-- | Tests a property, using test arguments, and prints the results to 'System.IO.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 'System.IO.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 'System.IO.stdout'. +quickCheckWithResult :: Testable prop => Args -> prop -> IO Result +quickCheckWithResult a p = + withState a (\s -> test s (property p)) + +-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'. +recheck :: Testable prop => Result -> prop -> IO () +recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once +recheck _ = error "Can only recheck tests that failed with a counterexample." + +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 + , replayStartSize = snd <$> replay a + , maxTestSize = maxSize a + , 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 + } + +computeSize :: State -> Int +computeSize MkState{replayStartSize = Just s,numSuccessTests = 0,numRecentlyDiscardedTests=0} = s +-- NOTE: Beware that changing this means you also have to change `prop_discardCoverage` as that currently relies +-- on the sequence produced by this function. +computeSize MkState{maxSuccessTests = ms, maxTestSize = mts, maxDiscardedRatio = md,numSuccessTests=n,numRecentlyDiscardedTests=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` mts + mts <= ms || + n >= ms || + ms `mod` mts == 0 = (n `mod` mts + d `div` dDenom) `min` mts + | otherwise = + ((n `mod` mts) * mts `div` (ms `mod` mts) + d `div` dDenom) `min` mts + where + -- The inverse of the rate at which we increase size as a function of discarded tests + -- if the discard ratio is high we can afford this to be slow, but if the discard ratio + -- is low we risk bowing out too early + dDenom + | md > 0 = (ms * md `div` 3) `clamp` (1, 10) + | otherwise = 1 -- Doesn't matter because there will be no discards allowed + n `roundTo` m = (n `div` m) * m + +clamp :: Ord a => a -> (a, a) -> a +clamp x (l, h) = max l (min x h) + +-- | Tests a property and prints the results and all test cases generated to 'System.IO.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 'System.IO.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 'System.IO.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 'System.IO.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 prop + | finishedSuccessfully st = doneTesting st + | finishedInsufficientCoverage st = failCoverage st + | tooManyDiscards st = giveUp st + | otherwise = runATest st prop + +finishedSuccessfully :: State -> Bool +finishedSuccessfully st + | checkingCoverage st = + and [ timeToCheckCoverage st + , coverageKnownSufficient st + , numSuccessTests st >= maxSuccessTests st + ] + | otherwise = numSuccessTests st >= maxSuccessTests st + +finishedInsufficientCoverage :: State -> Bool +finishedInsufficientCoverage st = + and [ checkingCoverage st + , timeToCheckCoverage st + , coverageKnownInsufficient st + ] + +tooManyDiscards :: State -> Bool +tooManyDiscards st + | maxDiscardedRatio st > 0 = numDiscardedTests st `div` maxDiscardedRatio st >= max (numSuccessTests st) (maxSuccessTests st) + | otherwise = numDiscardedTests st > 0 + +checkingCoverage :: State -> Bool +checkingCoverage st = isJust (coverageConfidence st) + +timeToCheckCoverage :: State -> Bool +timeToCheckCoverage st + -- This is the time when we would normally finish testing, so lets check + -- it now to see if we can finish testing already + | numSuccessTests st == maxSuccessTests st && numRecentlyDiscardedTests st == 0 = True + -- We are on test 100 * 2^k for k > 0 + | otherwise = + and [ numSuccessTests st > 0 + , numSuccessTests st `mod` 100 == 0 + , powerOfTwo (numSuccessTests st `div` 100) + ] + where powerOfTwo n = n .&. (n - 1) == 0 + +coverageKnownSufficient :: State -> Bool +coverageKnownSufficient st@MkState{coverageConfidence=Just confidence} = + and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownSufficient _ = True + +coverageKnownInsufficient :: State -> Bool +coverageKnownInsufficient st@MkState{coverageConfidence=Just confidence} = + or [ insufficientlyCovered (Just (certainty confidence)) tot n p + | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownInsufficient _ = False + +failCoverage :: State -> IO Result +failCoverage st = + -- The last test wasn't actually successful, as the coverage failed + -- also this prevents an off-by-one error in the printing + runATest st{numSuccessTests = numSuccessTests st - 1} + $ foldr counterexample (property failed{P.reason = "Insufficient coverage"}) + (paragraphs [theLabels, theTables]) + where (theLabels, theTables) = labelsAndTables st + +doneTesting :: State -> IO Result +doneTesting st + | 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 -> IO Result +giveUp st = + 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 = formatTestCount (numSuccessTests st) (numDiscardedTests st) + +formatTestCount :: Int -> Int -> String +formatTestCount succeeded discarded = + number succeeded "test" + ++ concat [ "; " ++ show discarded ++ " discarded" + | discarded > 0 + ] + +runATest :: State -> Property -> IO Result +runATest st prop = + do -- CALLBACK before_test + putTemp (terminal st) + ( "(" + ++ showTestCount st + ++ ")" + ) + + let size = computeSize st + + MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size))) + res <- callbackPostTest st res + + let continue :: (State -> IO Result) -> State -> IO Result + continue break st' + | abort res = break $ updateState st' + | otherwise = test (updateState st') prop + + updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } + + addNewOptions st0 = st0{ maxSuccessTests = fromMaybe (maxSuccessTests st0) (maybeNumTests res) + , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st0) (maybeDiscardedRatio res) + , numTotMaxShrinks = fromMaybe (numTotMaxShrinks st0) (maybeMaxShrinks res) + , maxTestSize = fromMaybe (maxTestSize st0) (maybeMaxTestSize res) + , expected = expect res + } + + addCoverageInfo st0 = + st0{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st0 + , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st0) + , S.classes = Map.unionWith (+) (S.classes st0) + (Map.fromList [ (s, if b then 1 else 0) | (s, b) <- P.classes res ]) + , S.tables = + foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) + (S.tables st0) (P.tables res) + , S.requiredCoverage = + foldr (\(key, value, p) -> Map.insertWith max (key, value) p) + (S.requiredCoverage st0) (P.requiredCoverage res) + } + + stC = addCoverageInfo st + + case res of + MkResult{ok = Just True} -> -- successful test + do continue doneTesting + stC{ numSuccessTests = numSuccessTests st + 1 + , numRecentlyDiscardedTests = 0 + } + + MkResult{ok = Nothing} -> -- discarded test + do continue giveUp + -- Don't add coverage info from this test + st{ numDiscardedTests = numDiscardedTests st + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + } + + MkResult{ok = Just False} -> -- failed test + do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts + theOutput <- terminalOutput (terminal stC) + if not (expect res) then + return Success{ labels = S.labels stC, + classes = S.classes stC, + tables = S.tables stC, + numTests = numSuccessTests stC+1, + numDiscarded = numDiscardedTests stC, + output = theOutput } + else do + testCase <- mapM showCounterexample (P.testCase res) + return Failure{ usedSeed = randomSeed stC -- correct! (this will be split first) + , usedSize = size + , numTests = numSuccessTests stC + 1 + , numDiscarded = numDiscardedTests stC + , 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 (map fst $ filter snd $ P.classes res) +#ifndef NO_TYPEABLE + , witnesses = theWitnesses res +#endif + } + where + (rnd1,rnd2) = splitImpl (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 + | isDiscard err -> localMinFound st res + | otherwise -> + 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 + + +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. diff --git a/src/Test/QuickCheck/Text.hs b/src/Test/QuickCheck/Text.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Text.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +{-# 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 (intersperse, transpose) +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 oldLen <- readIORef tmp + let newLen = length s + maxLen = max newLen oldLen + err $ s ++ replicate (maxLen - newLen) ' ' ++ replicate maxLen '\b' + writeIORef tmp newLen + +-------------------------------------------------------------------------- +-- the end. diff --git a/test-hugs b/test-hugs new file mode 100644 --- /dev/null +++ b/test-hugs @@ -0,0 +1,29 @@ +#!/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 -q "$3" hugs.output || die +} + +# Simple tests +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/test-mhs b/test-mhs new file mode 100644 --- /dev/null +++ b/test-mhs @@ -0,0 +1,25 @@ +#!/bin/sh + +set -e + +mcabal -r install + +die() { + echo "TEST FAILED" + exit 1 +} + +dotest() { + cat >Main.hs < reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/tests/CollectDataTypes.hs b/tests/CollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/CollectDataTypes.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveLift, TupleSections, CPP, TypeOperators #-} +module CollectDataTypes where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Interpreter hiding (lift) +import Data.Maybe +import Data.List +import System.Process +import Data.List.Split +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Text.Printf +import Data.Either +import Data.Char +import Data.Function +import Test.QuickCheck +import Test.QuickCheck.Function + +data DataType = + DataType { + dt_package :: String, + dt_module :: String, + dt_type :: String } + deriving (Show, Lift) + +getPackageDataTypes :: String -> IO [DataType] +getPackageDataTypes pkg = do + mods <- filter isValidModule <$> getPackageModules pkg + typess <- mapM getModuleDataTypes mods + return [DataType pkg mod typ | (mod, types) <- zip mods typess, typ <- types] + +getPackageModules :: String -> IO [String] +getPackageModules pkg = + concatMap (parseWords . words) . splitOn ", " . unwords . words <$> readProcess cmd args "" + where + cmd:args = ["ghc-pkg", "field", pkg, "exposed-modules", "--simple-output"] + parseWords [mod, "from", _] = [mod] + parseWords xs = xs + +getModuleDataTypes :: String -> IO [String] +getModuleDataTypes mod = do + putStrLn mod + Right names <- runInterpreter $ getModuleExports mod + return [x | Data x _ <- names] + +haskellName :: DataType -> String +haskellName DataType{..} = printf "%s.%s" dt_module (stripParens dt_type) + where + stripParens = reverse . dropWhile (== ')') . reverse . dropWhile (== '(') + +dataTypeType :: DataType -> Q (Maybe Type) +dataTypeType dt = do + mname <- lookupTypeName (haskellName dt) + case mname of + Nothing -> return Nothing + Just name -> Just <$> reifyType name + +typeArity :: Type -> Maybe Int +typeArity (AppT (AppT ArrowT StarT) kind) = succ <$> typeArity kind +typeArity StarT = return 0 +typeArity _ = Nothing + +createProperties :: String -> Q [Dec] +createProperties pkg = do + datatypes0 <- runIO (getPackageDataTypes pkg) + let datatypes = [ dt | dt <- datatypes0, not $ haskellName dt `elem` typeBlacklist ] + let mkImport dt = printf "import %s -- for %s" (dt_module dt) (dt_type dt) + missingModules <- fmap (map mkImport . nubBy ((==) `on` dt_module)) $ filterM (\ dt -> isNothing <$> dataTypeType dt) datatypes + unless (null missingModules) $ error ("Missing the following imports:\n" ++ unlines missingModules) + namesAndDecs <- fmap concat $ mapM createProperty datatypes + let (allNames, props) = unzip namesAndDecs + allPropsDec <- [d| allProps = + $(pure $ ListE [ TupE [Just (LitE (StringL $ nameBase name)), Just (VarE name)] + | name <- allNames ] + ) + |] + return $ allPropsDec ++ props + +createProperty :: DataType -> Q [(Name, Dec)] +createProperty dt = do + mtype <- dataTypeType dt + -- TODO: monad?! + case mtype of + Nothing -> error $ "Can't find type in scope " ++ show dt + Just typ -> case typeArity typ of + Nothing -> pure [] + Just arity -> do + Just name <- lookupTypeName (haskellName dt) + Just int <- lookupTypeName "Int" + nm <- newName ("prop_" ++ filter isAlphaNum (haskellName dt)) + nmCo <- newName ("prop_co_" ++ filter isAlphaNum (haskellName dt)) + nmFunction <- newName ("prop_function_" ++ filter isAlphaNum (haskellName dt)) + let propName = pure $ VarP nm + let propNameCo = pure $ VarP nmCo + let propNameFunction = pure $ VarP nmFunction + let ty = pure $ foldl AppT (ConT name) $ replicate arity (ConT int) + dArbitrary <- map (nm,) <$> [d| $propName = forAllBlind (arbitrary :: Gen $ty) (\ x -> x `seq` True) |] + dCoArbitrary <- map (nmCo,) <$> [d| $propNameCo = forAllBlind (arbitrary :: Gen ($ty -> Integer)) (\ x -> x `seq` True) |] + dFunction <- map (nmFunction,) <$> [d| $propNameFunction = forAllBlind (arbitrary :: Gen ($ty :-> Integer)) (\ x -> x `seq` True) |] + return $ dArbitrary ++ dCoArbitrary ++ dFunction + +typeBlacklist :: [String] +typeBlacklist = [ "Prelude.IO" + , "Prelude.ReadS" + , "Prelude.ShowS" + , "System.IO.IO" + , "System.IO.Error.IOError" + , "Prelude.IOError" + , "Data.Kind.Type" + , "Data.Array.Byte.MutableByteArray" + , "Data.IORef.IORef" + , "Data.Kind.Constraint" + , "Data.Unique.Unique" + , "Data.STRef.STRef" + , "Data.STRef.Lazy.STRef" + , "Data.STRef.Strict.STRef" + , "Data.Void.Void" + , "Data.Proxy.KProxy" + , "Data.Monoid.Endo" + , "Data.Semigroup.Endo" + , "Data.List.[]" -- This is buggy and annoying + , "System.IO.HandlePosn" + , "System.IO.Handle" + , "Text.Printf.FieldFormatter" -- This is a function type and it + -- requires an annoying coarbitrary instance + , "Text.Printf.ModifierParser" + , "Text.Show.ShowS" + ] ++ + -- These are phantom types used for indexing + [ "Data.Fixed.E" ++ show i | i <- [0,1,2,3,6,9,12] ] ++ +#if MIN_VERSION_base(4,15,0) + -- Exists but is deprecated + [ "Data.Semigroup.Option" ] ++ +#endif + -- TODO: Some controversial ones? + [ "System.IO.Error.IOErrorType" ] ++ + -- Some higher order types we ignore for the sake of CoArbitrary and Function issues + [ "System.Console.GetOpt.OptDescr" + , "System.Console.GetOpt.ArgOrder" + , "System.Console.GetOpt.ArgDescr" + ] ++ + -- System specific and, likewise, not easily doable in Function + [ "System.IO.TextEncoding" ] ++ + -- Ignored for `Function` because the test monomorphises to `Int`. fixme. + [ "Data.Complex.Complex" ] + + + + +modulePrefixBlacklist :: [String] +modulePrefixBlacklist = [ "GHC" + , "Foreign" + , "Control.Exception" + -- Exports things like MVar etc + , "Control.Concurrent" + -- Exports ST and RealWorld that we can't support + , "Control.Monad.ST" + -- Existential wrapper around a Typeable thing, could + -- be supported but would be a bit artificially + -- limited to wrapping a bunch of types we can list + , "Data.Dynamic" + -- We _could_ support this, but it would result in + -- the same problem as with Dynamic + , "Data.Typeable" + , "Type.Reflection" + -- System.Mem.Weak and System.Mem.Stable export + -- pointer types we don't support + , "System.Mem" + -- Exports an exception + , "System.Timeout" + -- Exports types, but not the constructors (or ways of + -- creating them, e.g. Number). No feasible way to + -- create meaningful generator + , "Text.Read" + -- Old generics implementation that doesn't fit nicely + -- with arbitrary, as it has the same kind of problem + -- that Typeable and Dynamic face + , "Data.Data" + -- Platform specific types that one could implement but + -- would be tricky to keep consistent and correct + -- across a number of platforms, esp. since we don't + -- have good CI tests for them + , "System.Posix" + -- This exports a bunch of combinators whose only real + -- role is to build a parser of an opaque type, + -- consequently there isn't some super-interesting + -- useful work you can do with it and it should be OK + -- not to provide instances for it + , "Text.ParserCombinators.ReadP" + -- Slightly controversial, but this is only ignored for + -- the sake of CoArbitrary and Function + , "Data.Functor.Contravariant" + ] + +isValidModule :: String -> Bool +isValidModule mod = not $ any (`isPrefixOf` mod) modulePrefixBlacklist diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs new file mode 100644 --- /dev/null +++ b/tests/DiscardRatio.hs @@ -0,0 +1,56 @@ +module Main where + +import Control.Monad +import System.Exit +import Test.QuickCheck + +assert :: String -> Bool -> IO () +assert s False = do + putStrLn $ s ++ " failed!" + exitFailure +assert _ _ = return () + +quickCheckYesWith, quickCheckNoWith :: Testable p => Args -> p -> IO () +quickCheckYesWith args p = do + res <- quickCheckWithResult args p + unless (isSuccess res) exitFailure +quickCheckNoWith args p = do + res <- quickCheckWithResult args p + when (isSuccess res) exitFailure +quickCheckYes, quickCheckNo :: Testable p => p -> IO () +quickCheckYes = quickCheckYesWith stdArgs +quickCheckNo = quickCheckNoWith stdArgs + +check :: Result -> Int -> Int -> IO () +check res n d = do + quickCheckYes $ once $ n === numTests res + quickCheckYes $ once $ d === numDiscarded res + +main :: IO () +main = do + putStrLn "Expecting gave up after 200 tries: False ==> True" + res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True + check res 0 200 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ False ==> True + check res 0 200 + + putStrLn "\nExpecting success after 100 tests: x == x" + res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x + check res 100 0 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ \ x -> (x :: Int) == x + check res 100 0 + + -- The real ratio is 20, if 1 works or 40 doesn't it's + -- probably because we broke something! + let p50 = forAll (choose (1, 1000)) $ \ x -> (x :: Int) < 50 ==> True + putStrLn "\nExpecting failure (discard ratio 1): x < 50 ==> True" + quickCheckNo $ withDiscardRatio 1 p50 + quickCheckNoWith stdArgs{maxDiscardRatio = 1} p50 + putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True" + quickCheckYes $ withDiscardRatio 40 p50 + quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50 + + -- Annoying interactions of discard and cover + quickCheckYes $ forAllBlind (oneof [return True, return discard]) $ \ b -> cover 10 b "b" True + quickCheck $ cover 10 discard "b" True + quickCheck $ classify discard "b" True diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs --- a/tests/GCoArbitraryExample.hs +++ b/tests/GCoArbitraryExample.hs @@ -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 @@ -17,7 +17,7 @@ prop_coarbitrary (Fun _ f) = expectFailure $ - withMaxSuccess 1000 $ + withNumTests 1000 $ f (C1 (2::Int)) `elem` [0, 1 :: Int] return [] diff --git a/tests/GShrinkExample.hs b/tests/GShrinkExample.hs --- a/tests/GShrinkExample.hs +++ b/tests/GShrinkExample.hs @@ -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] .&&. diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe -import Data.List +import Data.List (inits, sort, nub) import Data.Int import Data.Word import Data.Version @@ -29,7 +29,7 @@ path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property -somePath p = expectFailure . withMaxSuccess 1000 . path (not . p) +somePath p = expectFailure . withNumTests 1000 . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) @@ -105,8 +105,8 @@ Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)), Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)), Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) => - (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property -pathInt f p = + Bool -> (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property +pathInt word f p = conjoin [counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)), counterexample "Integer" (path ((p :: Integer -> Bool) . f)), @@ -114,26 +114,32 @@ counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)), counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)), counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)), - counterexample "Word" (path ((p :: Word -> Bool) . getExtremal . f)), - counterexample "Word8" (path ((p :: Word8 -> Bool) . getExtremal . f)), - counterexample "Word16" (path ((p :: Word16 -> Bool) . getExtremal . f)), - counterexample "Word32" (path ((p :: Word32 -> Bool) . getExtremal . f)), - counterexample "Word64" (path ((p :: Word64 -> Bool) . getExtremal . f))] -somePathInt f p = expectFailure (pathInt f (not . p)) + counterexample "Word" (not word .||. path ((p :: Word -> Bool) . getExtremal . f)), + counterexample "Word8" (not word .||. path ((p :: Word8 -> Bool) . getExtremal . f)), + counterexample "Word16" (not word .||. path ((p :: Word16 -> Bool) . getExtremal . f)), + counterexample "Word32" (not word .||. path ((p :: Word32 -> Bool) . getExtremal . f)), + counterexample "Word64" (not word .||. path ((p :: Word64 -> Bool) . getExtremal . f))] +somePathInt word f p = expectFailure (pathInt word f (not . p)) -prop_positive = pathInt getPositive (> 0) -prop_positive_bound = somePathInt getPositive (== 1) +prop_positive = pathInt True getPositive (> 0) +prop_positive_bound = somePathInt True getPositive (== 1) -prop_nonzero = pathInt getNonZero (/= 0) -prop_nonzero_bound_1 = somePathInt getNonZero (== 1) -prop_nonzero_bound_2 = somePathInt getNonZero (== -1) +prop_nonzero = pathInt True getNonZero (/= 0) +prop_nonzero_bound_1 = somePathInt True getNonZero (== 1) +prop_nonzero_bound_2 = somePathInt True getNonZero (== -1) -prop_nonnegative = pathInt getNonNegative (>= 0) -prop_nonnegative_bound = somePathInt getNonNegative (== 0) +prop_nonnegative = pathInt True getNonNegative (>= 0) +prop_nonnegative_bound = somePathInt True getNonNegative (== 0) +prop_negative = pathInt False getNegative (< 0) +prop_negative_bound = somePathInt False getNegative (== -1) + +prop_nonpositive = pathInt True getNonPositive (<= 0) +prop_nonpositive_bound = somePathInt True getNonPositive (== 0) + reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property -reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) +reachesBound x = withNumTests 1000 (expectFailure (x < 3 * (maxBound `div` 4))) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property @@ -176,6 +182,16 @@ prop_no_shrinking_loop_Version = noShrinkingLoop :: Path Version -> Bool prop_no_shrinking_loop_ExitCode = noShrinkingLoop :: Path ExitCode -> Bool +-- Check that shrinking a Double always produces a shrinking candidate. +prop_shrink_candidate_double :: Property +prop_shrink_candidate_double = + forAllShrink gen shrink $ \x -> + x > 0 ==> + not (null (shrink x)) + where + gen :: Gen Double + gen = oneof [arbitrary, fmap fromInteger arbitrary] + -- Bad shrink: infinite list -- -- remove unexpectedFailure in prop_B1, shrinking should not loop forever. @@ -187,6 +203,18 @@ prop_B1 :: B1 -> Property prop_B1 (B1 n) = expectFailure $ n === n + 1 + +-- Double properties: + +-- We occasionaly generate duplicates. +prop_double_duplicate_list :: [Double] -> Property +prop_double_duplicate_list xs = expectFailure $ nub xs === xs where + sorted = sort xs + +-- And enough numbers to show basic IEEE pit falls. +prop_double_assoc :: Double -> Double -> Double -> Property +prop_double_assoc x y z = expectFailure $ x + (y + z) === (x + y) + z + return [] main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return () diff --git a/tests/Misc.hs b/tests/Misc.hs new file mode 100644 --- /dev/null +++ b/tests/Misc.hs @@ -0,0 +1,50 @@ +-- Miscellaneous tests. + +{-# LANGUAGE TemplateHaskell #-} +import Test.QuickCheck +import Test.QuickCheck.Random +import Data.Map +import Control.Monad + +prop_verbose :: Blind (Int -> Int -> Bool) -> Property +prop_verbose (Blind p) = + forAll (mkQCGen <$> arbitrary) $ \g -> + ioProperty $ do + res1 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} p + res2 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} (verbose p) + return $ + numTests res1 === numTests res2 .&&. + failingTestCase res1 === failingTestCase res2 + +prop_failingTestCase :: Blind (Int -> Int -> Int -> Bool) -> Property +prop_failingTestCase (Blind p) = ioProperty $ do + res <- quickCheckWithResult stdArgs{chatty = False} p + let [x, y, z] = failingTestCase res + return (not (p (read x) (read y) (read z))) + +prop_maxSize :: Property +prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10) + +prop_cover :: Property +prop_cover = withNumTests 1000 + $ checkCoverage + $ forAll (arbitrary :: Gen Int) + $ \ x -> cover 5 (x > 0) "positive" True + +-- Issue #382 +prop_discardCoverage :: Property +prop_discardCoverage = checkCoverage $ forAll (sized $ \ n -> pure n) $ \ x -> cover 10 True "label" $ x /= 99 ==> True + +return [] +main = do + True <- $quickCheckAll + Success{classes=cls} <- quickCheckResult $ classify False "A" $ classify True "B" True + [("A",0),("B",100)] <- return $ toList cls + Success{numTests=1000} <- quickCheckResult prop_cover + forM_ [const discard, const [discard], \ x -> discard : shrink x] $ \ shr -> do + Failure{reason="Falsified"} <- quickCheckResult $ forAllShrink arbitrary shr (odd :: Int -> Bool) + return () + -- These shouldn't crash + sample (discard :: Gen Int) + sample (oneof [discard, return 1] :: Gen Int) + sample (oneof [return (1, discard), return (1, 1)] :: Gen (Int, Int)) diff --git a/tests/Monoids.hs b/tests/Monoids.hs new file mode 100644 --- /dev/null +++ b/tests/Monoids.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif +{-# LANGUAGE FlexibleInstances #-} + +module Main (main) where + +#ifndef NO_SEMIGROUP_CLASS +import Data.List.NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..), (<>)) +#endif + +import Test.QuickCheck + +#ifdef NO_SEMIGROUP_CLASS +type Semigroup = Monoid +sconcat :: Monoid a => [a] -> a +sconcat = mconcat +#endif + +instance Arbitrary Every where + arbitrary = oneof [ pure $ Every True + , pure $ Every False + , pure $ Every (counterexample "False" False) + , pure $ Every (counterexample "True" True) + , pure $ Every (ioProperty (return True)) + , pure $ Every (ioProperty (return False)) + , pure $ Every (checkCoverage $ cover 100 True "" True) + , pure $ Every (checkCoverage $ cover 100 True "" False) + , pure $ Every (checkCoverage $ cover 100 False "" False) + ] + + +instance Arbitrary Some where + arbitrary = oneof [ pure $ Some True + , pure $ Some False + , pure $ Some (counterexample "False" False) + , pure $ Some (counterexample "True" True) + , pure $ Some (ioProperty (return True)) + , pure $ Some (ioProperty (return False)) + , pure $ Some (checkCoverage $ cover 100 True "" True) + , pure $ Some (checkCoverage $ cover 100 True "" False) + , pure $ Some (checkCoverage $ cover 100 False "" True) + , pure $ Some (checkCoverage $ cover 100 False "" False) + ] + + +newtype Fail a = Fail a + +instance Arbitrary (Fail Every) where + arbitrary = oneof [ Fail <$> (arbitrary :: Gen Every) + , pure $ Fail $ Every (checkCoverage $ cover 100 False "" True) + ] + + +check_associative_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Blind p -> Property +check_associative_law (Blind a) (Blind b) (Blind c) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> (b <> c)) + y <- isSuccess <$> quickCheckWithResult args ((a <> b) <> c) + return (x == y) + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_unit_law :: (Testable p, Monoid p) => Blind p -> Property +#else +check_unit_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Property +#endif +check_unit_law (Blind a) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> mempty) + y <- isSuccess <$> quickCheckWithResult args (mempty <> a) + z <- isSuccess <$> quickCheckWithResult args a + return (x == y .&&. y == z) + + +#ifndef NO_SEMIGROUP_CLASS +check_sconcat_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Property +check_sconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (sconcat $ a :| [b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) +#endif + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property +#else +check_mconcat_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Blind p -> Property +#endif +check_mconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (mconcat [a, b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) + + +-- +-- Auxiliary definitions +-- + +args :: Args +args = stdArgs { chatty = False, maxShrinks = 0 } + +-- +-- Properties +-- + +prop_every_associative :: Blind Every -> Blind Every -> Blind Every -> Property +prop_every_associative = check_associative_law + +prop_every_unit :: Blind Every -> Property +prop_every_unit = check_unit_law + +prop_every_unit_fail :: Blind (Fail Every) -> Property +prop_every_unit_fail (Blind (Fail a)) = + expectFailure $ check_unit_law (Blind a) + +#ifndef NO_SEMIGROUP_CLASS +prop_every_sconcat_law :: Blind Every -> Blind Every -> Property +prop_every_sconcat_law = check_sconcat_law +#endif + +prop_every_mconcat_law :: Blind Every -> Blind Every -> Property +prop_every_mconcat_law = check_mconcat_law + +prop_some_associative :: Blind Some -> Blind Some -> Blind Some -> Property +prop_some_associative = check_associative_law + +prop_some_unit :: Blind Some -> Property +prop_some_unit = check_unit_law + +#ifndef NO_SEMIGROUP_CLASS +prop_some_sconcat_law :: Blind Some -> Blind Some -> Property +prop_some_sconcat_law = check_sconcat_law +#endif + +prop_some_mconcat_law :: Blind Some -> Blind Some -> Property +prop_some_mconcat_law = check_mconcat_law + +return [] +main = do True <- $quickCheckAll; return () + diff --git a/tests/RunCollectDataTypes.hs b/tests/RunCollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/RunCollectDataTypes.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -ddump-splices #-} +import CollectDataTypes +import Language.Haskell.TH +import Test.QuickCheck.All +import Test.QuickCheck + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Exception +import Control.Exception.Base +import Control.Monad.ST +import Control.Monad.ST.Lazy +import Control.Monad.ST.Strict +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte +#endif +#endif +import Data.Bits +import Data.Bool +import Data.Char +import Data.Complex +import Data.Data +import Data.Dynamic +import Data.Either +import Data.Fixed +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Contravariant +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.IORef +import Data.Int +import Data.Kind +import Data.List.NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.STRef +import Data.STRef.Lazy +import Data.STRef.Strict +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Type.Bool +import Data.Type.Coercion +import Data.Type.Equality +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,16,0) +import Data.Type.Ord +#endif +#endif +import Data.Typeable +import Data.Unique +import Data.Version +import Data.Void +import Data.Word +import Numeric.Natural +import System.Console.GetOpt +import System.Exit +import System.IO +import System.IO.Error +import System.Mem.StableName +import System.Mem.Weak +import System.Posix.Internals +import System.Posix.Types +import System.Timeout +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec +import Text.Printf +import Text.Read +import Text.Read.Lex +import Text.Show +import Type.Reflection +import Type.Reflection.Unsafe +import Unsafe.Coerce + +$(createProperties "base") + +main = runQuickCheckAll allProps quickCheckResult diff --git a/tests/Split.hs b/tests/Split.hs new file mode 100644 --- /dev/null +++ b/tests/Split.hs @@ -0,0 +1,28 @@ +import Test.QuickCheck +import Test.QuickCheck.Random +import Data.List (group, isPrefixOf, sort) + +-- This type allows us to run integerVariant and get a list of bits out. +newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show) + +instance Splittable Splits where + left (Splits xs) = Splits (xs ++ [False]) + right (Splits xs) = Splits (xs ++ [True]) + +-- Check that integerVariant gives a prefix-free code, +-- i.e., if m /= n then integerVariant m is not a prefix of integerVariant n. +prop_split_prefix :: Property +prop_split_prefix = + once $ forAllShrink (return [-10000..10000]) shrink $ \ns -> + map head (group (sort ns)) == sort ns ==> -- no duplicates + let + codes :: [Splits] + codes = sort [integerVariant n (Splits []) | n <- ns] + + ok (Splits xs) (Splits ys) = not (xs `isPrefixOf` ys) + in + -- After sorting, any prefix will end up immediately before + -- one of its suffixes + and (zipWith ok codes (drop 1 codes)) + +main = do Success{} <- quickCheckResult prop_split_prefix; return () diff --git a/tests/Strictness.hs b/tests/Strictness.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness.hs @@ -0,0 +1,42 @@ +-- Strictness tests. + +{-# LANGUAGE CPP, TemplateHaskell #-} +import Test.QuickCheck + +import Control.Exception (Exception (..), throw) + +#if MIN_VERSION_containers(0,5,0) +import Control.Exception (evaluate, try) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +#endif + +data Thunk + +instance Arbitrary Thunk where + arbitrary = throw ThunkError + +instance Show Thunk where + show _ = "Thunk" + +data ThunkError = ThunkError deriving Show + +instance Exception ThunkError + +prop_strictMap :: Property +#if MIN_VERSION_containers(0,5,0) +prop_strictMap = again . ioProperty $ do + m <- generate arbitrary + result <- try $ evaluate m :: IO (Either ThunkError (Map Int Thunk)) + pure $ case result of + Right _ | not (Map.null m) -> counterexample ("Thunks in Map: " ++ show m) False + _ -> property True +#else +prop_strictMap = once $ property True +#endif + +return [] +main :: IO () +main = do + True <- $quickCheckAll + return () diff --git a/tests/Terminal.hs b/tests/Terminal.hs --- a/tests/Terminal.hs +++ b/tests/Terminal.hs @@ -63,7 +63,7 @@ -- * Anything written to stderr (presumably by putTemp) is erased prop_terminal :: [Command] -> Property prop_terminal cmds = - withMaxSuccess 1000 $ ioProperty $ + withNumTests 1000 $ ioProperty $ withPipe $ \stdout_read stdout_write -> withPipe $ \stderr_read stderr_write -> do out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do diff --git a/tests/WithProgress.hs b/tests/WithProgress.hs new file mode 100644 --- /dev/null +++ b/tests/WithProgress.hs @@ -0,0 +1,68 @@ +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Data.IORef +import System.Exit (exitSuccess, exitFailure) +import Control.Monad (when) + +main :: IO () +main = do + succ <- newIORef 0 + disc <- newIORef 0 + + -- test 1 + quickCheck (propTestWithProgress succ) + i <- readIORef succ + when (i /= 99) exitFailure + + modifyIORef succ (const 0) + + -- test 2 + quickCheck (proptestWithProgressDiscard succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 999) exitFailure + + modifyIORef succ (const 0) + modifyIORef disc (const 0) + + -- test 3 + quickCheck (proptestWithProgressNotInstalled succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 0) exitFailure + + exitSuccess + +-- all these tests succeed, incrementing the counter every time +propTestWithProgress :: IORef Int -> Property +propTestWithProgress ref = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> modifyIORef ref (\_ -> currentPassed p)) + $ n == n + +-- all of these tests are discarded, never updating the currentPassed counter, but always +-- the currentDiscarded one. +proptestWithProgressDiscard :: IORef Int -> IORef Int -> Property +proptestWithProgressDiscard succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n > 1000 ==> + n == n + +-- The callback is installed after the test on n, meaning that since all tests are +-- discarded, it will never be called. It will never be executed. +proptestWithProgressNotInstalled :: IORef Int -> IORef Int -> Property +proptestWithProgressNotInstalled succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + n > 1000 ==> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n == n