diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,6 +1,6 @@ Name: QuickCheck -Version: 2.14 -Cabal-Version: >= 1.8 +Version: 2.14.1 +Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE @@ -8,7 +8,7 @@ Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC >= 7.0 +Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -48,6 +48,7 @@ examples/Set.hs examples/Simple.hs make-hugs + test-hugs source-repository head type: git @@ -56,23 +57,37 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.14 + tag: 2.14.1 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. Default: True +flag old-random + Description: Build against a pre-1.2.0 version of the random package. + Default: False + library - Build-depends: base >=4.3 && <5, random >=1.0.0.3 && <1.2, containers + Hs-source-dirs: src + Build-depends: base >=4.3 && <5, containers + Default-language: Haskell2010 - -- random is explicitly Trustworthy since 1.0.1.0 - -- similar constraint for containers - -- Note: QuickCheck is Safe only with GHC >= 7.4 (see below) - if impl(ghc >= 7.2) - Build-depends: random >=1.0.1.0 - if impl(ghc >= 7.4) - Build-depends: containers >=0.4.2.1 + -- New vs old random. + if flag(old-random) + Build-depends: random >= 1.0.0.3 && < 1.2.0 + cpp-options: -DOLD_RANDOM + else + Build-depends: random >= 1.2.0 && < 1.3 + -- We always use splitmix directly rather than going through StdGen + -- (it's somewhat more efficient). + -- However, Hugs traps overflow on Word64, so we have to stick + -- with StdGen there. + if impl(hugs) + cpp-options: -DNO_SPLITMIX + else + Build-depends: splitmix >= 0.1 && <0.2 + -- Modules that are always built. Exposed-Modules: Test.QuickCheck, @@ -118,11 +133,12 @@ if impl (ghc < 7.4) cpp-options: -DNO_SAFE_HASKELL - -- Use splitmix on newer GHCs. - if impl(ghc >= 7.0) - Build-depends: splitmix >= 0.0.4 - else - cpp-options: -DNO_SPLITMIX + -- random is explicitly Trustworthy since 1.0.1.0 + -- similar constraint for containers + if impl(ghc >= 7.2) + Build-depends: random >=1.0.1.0 + if impl(ghc >= 7.4) + Build-depends: containers >=0.4.2.1 if !impl(ghc >= 7.6) cpp-options: -DNO_POLYKINDS @@ -134,13 +150,15 @@ if !impl(ghc) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! - cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS -DNO_EXTRA_METHODS_IN_APPLICATIVE + cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS + -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS + -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES -- LANGUAGE pragmas don't have any effect in Hugs. if impl(hugs) - Extensions: CPP + Default-Extensions: CPP if impl(uhc) -- Cabal under UHC needs pointing out all the dependencies of the @@ -151,6 +169,7 @@ Test-Suite test-quickcheck type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: examples main-is: Heap.hs @@ -160,6 +179,7 @@ Test-Suite test-quickcheck-gcoarbitrary type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck @@ -170,6 +190,7 @@ Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Generators.hs build-depends: base, QuickCheck @@ -178,6 +199,7 @@ Test-Suite test-quickcheck-gshrink type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: GShrinkExample.hs build-depends: base, QuickCheck @@ -188,6 +210,7 @@ Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Terminal.hs build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck @@ -196,6 +219,7 @@ Test-Suite test-quickcheck-monadfix type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: MonadFix.hs build-depends: base, QuickCheck @@ -204,12 +228,14 @@ Test-Suite test-quickcheck-split type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Split.hs build-depends: base, QuickCheck Test-Suite test-quickcheck-misc type: exitcode-stdio-1.0 + Default-language: Haskell2010 hs-source-dirs: tests main-is: Misc.hs build-depends: base, QuickCheck diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs deleted file mode 100644 --- a/Test/QuickCheck.hs +++ /dev/null @@ -1,326 +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 - , chooseInt - , chooseInteger - , chooseBoundedIntegral - , chooseEnum - , chooseAny - , oneof - , frequency - , elements - , growingElements - , sized - , getSize - , resize - , scale - , suchThat - , suchThatMap - , suchThatMaybe - , applyArbitrary2 - , applyArbitrary3 - , applyArbitrary4 - -- ** Generators for lists - , listOf - , listOf1 - , vectorOf - , vector - , infiniteListOf - , infiniteList - , shuffle - , sublistOf - , orderedList - -- ** Generators for particular types - , arbitrarySizedIntegral - , arbitrarySizedNatural - , arbitrarySizedFractional - , arbitrarySizedBoundedIntegral - , arbitraryBoundedIntegral - , arbitraryBoundedRandom - , arbitraryBoundedEnum - , arbitraryUnicodeChar - , arbitraryASCIIChar - , arbitraryPrintableChar - -- ** Running generators - , generate - -- ** Debugging generators - , sample - , sample' - -#ifndef NO_GADTS - -- * The 'Function' typeclass: generation of random shrinkable, showable functions - - -- | Example of use: - -- - -- >>> :{ - -- >>> let prop :: Fun String Integer -> Bool - -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" - -- >>> :} - -- >>> quickCheck prop - -- *** Failed! Falsified (after 3 tests and 134 shrinks): - -- {"elephant"->1, "monkey"->1, _->0} - -- - -- To generate random values of type @'Fun' a b@, - -- you must have an instance @'Function' a@. - -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, - -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. - -- See the @'Function' [a]@ instance for an example of the latter. - -- - -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. - , Fun (..) - , applyFun - , applyFun2 - , applyFun3 -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , pattern Fn - , pattern Fn2 - , pattern Fn3 -#endif - , Function (..) - , functionMap - , functionShow - , functionIntegral - , functionRealFrac - , functionBoundedEnum - , functionVoid -#endif - - -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way - , CoArbitrary(..) -#ifndef NO_GENERICS - , genericCoarbitrary -#endif - , variant - , coarbitraryIntegral - , coarbitraryReal - , coarbitraryShow - , coarbitraryEnum - , (><) - - -- * Type-level modifiers for changing generator behavior - - -- | These types do things such as restricting the kind of test data that can be generated. - -- They can be pattern-matched on in properties as a stylistic - -- alternative to using explicit quantification. - -- - -- Examples: - -- - -- @ - -- -- Functions cannot be shown (but see 'Function') - -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = - -- takeWhile p xs ++ dropWhile p xs == xs - -- @ - -- - -- @ - -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = - -- take n xs ++ drop n xs == xs - -- @ - -- - -- @ - -- -- cycle does not work for empty lists - -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = - -- take n (cycle xs) == take n (xs ++ cycle xs) - -- @ - -- - -- @ - -- -- Instead of 'forAll' 'orderedList' - -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = - -- sort xs == xs - -- @ - , Blind(..) - , Fixed(..) - , OrderedList(..) - , NonEmptyList(..) - , InfiniteList(..) - , SortedList(..) - , Positive(..) - , Negative(..) - , NonZero(..) - , NonNegative(..) - , NonPositive(..) - , Large(..) - , Small(..) - , Smart(..) - , Shrink2(..) -#ifndef NO_MULTI_PARAM_TYPE_CLASSES - , Shrinking(..) - , ShrinkState(..) -#endif - , ASCIIString(..) - , UnicodeString(..) - , PrintableString(..) - - -- * Property combinators - , Property, Testable(..) - , forAll - , forAllShrink - , forAllShow - , forAllShrinkShow - , forAllBlind - , forAllShrinkBlind - , shrinking - , (==>) - , Discard(..) - , discard - , (===) - , (=/=) -#ifndef NO_DEEPSEQ - , total -#endif - , ioProperty - , idempotentIOProperty - -- ** Controlling property execution - , verbose - , verboseShrinking - , noShrinking - , withMaxSuccess - , within - , once - , again - , mapSize - -- ** Conjunction and disjunction - , (.&.) - , (.&&.) - , conjoin - , (.||.) - , disjoin - -- ** What to do on failure - , counterexample - , printTestCase - , whenFail - , whenFail' - , expectFailure - -- * Analysing test case distribution - , label - , collect - , classify - , tabulate - -- ** Checking test case distribution - , cover - , coverTable - , checkCoverage - , checkCoverageWith - , Confidence(..) - , stdConfidence - -- ** Generating example test cases - , labelledExamples - , labelledExamplesWith - , labelledExamplesWithResult - , labelledExamplesResult - ) - where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Gen -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Modifiers -import Test.QuickCheck.Property hiding ( Result(..) ) -import Test.QuickCheck.Test -import Test.QuickCheck.Exception -#ifndef NO_GADTS -import Test.QuickCheck.Function -#endif -import Test.QuickCheck.Features -import Test.QuickCheck.State -#ifndef NO_TEMPLATE_HASKELL -import Test.QuickCheck.All -#endif - --------------------------------------------------------------------------- --- the end. 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,1454 +0,0 @@ --- | Type classes for random generation of values. --- --- __Note__: the contents of this module are re-exported by --- "Test.QuickCheck". You do not need to import it directly. -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -#ifndef NO_GENERICS -{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} -{-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPING_ -#endif -#endif -#ifndef NO_POLYKINDS -{-# LANGUAGE PolyKinds #-} -#endif -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Trustworthy #-} -#endif -#ifndef NO_NEWTYPE_DERIVING -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -#endif -module Test.QuickCheck.Arbitrary - ( - -- * Arbitrary and CoArbitrary classes - Arbitrary(..) - , CoArbitrary(..) - - -- ** Unary and Binary classes - , Arbitrary1(..) - , arbitrary1 - , shrink1 - , Arbitrary2(..) - , arbitrary2 - , shrink2 - - -- ** Helper functions for implementing arbitrary - , applyArbitrary2 - , applyArbitrary3 - , applyArbitrary4 - , arbitrarySizedIntegral -- :: Integral a => Gen a - , arbitrarySizedNatural -- :: Integral a => Gen a - , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a - , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a - , arbitrarySizedFractional -- :: Fractional a => Gen a - , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a - , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a - -- ** Generators for various kinds of character - , arbitraryUnicodeChar -- :: Gen Char - , arbitraryASCIIChar -- :: Gen Char - , arbitraryPrintableChar -- :: Gen Char - -- ** Helper functions for implementing shrink -#ifndef NO_GENERICS - , RecursivelyShrink - , GSubterms - , genericShrink -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] - , subterms -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] - , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] - , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b -#endif - , shrinkNothing -- :: a -> [a] - , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] - , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] - , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] - , shrinkIntegral -- :: Integral a => a -> [a] - , shrinkRealFrac -- :: RealFrac a => a -> [a] - , shrinkDecimal -- :: RealFrac a => a -> [a] - -- ** Helper functions for implementing coarbitrary - , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b - , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b - , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b - , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b - , (><) - - -- ** Generators which use arbitrary - , vector -- :: Arbitrary a => Int -> Gen [a] - , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] - , infiniteList -- :: Arbitrary a => Gen [a] - ) - where - --------------------------------------------------------------------------- --- imports - -import Control.Applicative -import Data.Foldable(toList) -import System.Random(Random) -import Test.QuickCheck.Gen -import Test.QuickCheck.Random -import Test.QuickCheck.Gen.Unsafe - -{- -import Data.Generics - ( (:*:)(..) - , (:+:)(..) - , Unit(..) - ) --} - -import Data.Char - ( ord - , isLower - , isUpper - , toLower - , isDigit - , isSpace - , isPrint - , generalCategory - , GeneralCategory(..) - ) - -#ifndef NO_FIXED -import Data.Fixed - ( Fixed - , HasResolution - ) -#endif - -import Data.Ratio - ( Ratio - , (%) - , numerator - , denominator - ) - -import Data.Complex - ( Complex((:+)) ) - -import Data.List - ( sort - , nub - ) - -import Data.Version (Version (..)) - -import Control.Monad - ( liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - ) - -import Data.Int(Int8, Int16, Int32, Int64) -import Data.Word(Word, Word8, Word16, Word32, Word64) -import System.Exit (ExitCode(..)) -import Foreign.C.Types - -#ifndef NO_GENERICS -import GHC.Generics -#endif - -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntSet as IntSet -import qualified Data.IntMap as IntMap -import qualified Data.Sequence as Sequence -import Data.Bits - -import qualified Data.Monoid as Monoid - -#ifndef NO_TRANSFORMERS -import Data.Functor.Identity -import Data.Functor.Constant -import Data.Functor.Compose -import Data.Functor.Product -#endif - --------------------------------------------------------------------------- --- ** class Arbitrary - --- | Random generation and shrinking of values. --- --- QuickCheck provides @Arbitrary@ instances for most types in @base@, --- except those which incur extra dependencies. --- For a wider range of @Arbitrary@ instances see the --- --- 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 = chooseEnum (False,True) - shrink True = [False] - shrink False = [] - -instance Arbitrary Ordering where - arbitrary = elements [LT, EQ, GT] - shrink GT = [EQ, LT] - shrink LT = [EQ] - shrink EQ = [] - -instance Arbitrary1 Maybe where - liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] - - liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] - liftShrink _ Nothing = [] - -instance Arbitrary a => Arbitrary (Maybe a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance Arbitrary2 Either where - liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] - - liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] - liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] - -instance Arbitrary a => Arbitrary1 (Either a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink - -instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where - arbitrary = arbitrary2 - shrink = shrink2 - -instance Arbitrary1 [] where - liftArbitrary = listOf - liftShrink = shrinkList - -instance Arbitrary a => Arbitrary [a] where - arbitrary = arbitrary1 - shrink = shrink1 - --- | Shrink a list of values given a shrinking function for individual values. -shrinkList :: (a -> [a]) -> [a] -> [[a]] -shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ] - ++ shrinkOne xs - where - n = length xs - - shrinkOne [] = [] - shrinkOne (x:xs) = [ x':xs | x' <- shr x ] - ++ [ x:xs' | xs' <- shrinkOne xs ] - - removes k n xs - | k > n = [] - | null xs2 = [[]] - | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2) - where - xs1 = take k xs - xs2 = drop k xs - -{- - -- "standard" definition for lists: - shrink [] = [] - shrink (x:xs) = [ xs ] - ++ [ x:xs' | xs' <- shrink xs ] - ++ [ x':xs | x' <- shrink x ] --} - -instance Integral a => Arbitrary (Ratio a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac - -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) -instance Arbitrary a => Arbitrary (Complex a) where -#else -instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where -#endif - arbitrary = liftM2 (:+) arbitrary arbitrary - shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ - [ x :+ y' | y' <- shrink y ] - -#ifndef NO_FIXED -instance HasResolution a => Arbitrary (Fixed a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal -#endif - -instance Arbitrary2 (,) where - liftArbitrary2 = liftM2 (,) - liftShrink2 shrA shrB (x, y) = - [ (x', y) | x' <- shrA x ] - ++ [ (x, y') | y' <- shrB y ] - -instance (Arbitrary a) => Arbitrary1 ((,) a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink - -instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where - arbitrary = arbitrary2 - shrink = shrink2 - -instance (Arbitrary a, Arbitrary b, Arbitrary c) - => Arbitrary (a,b,c) - where - arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary - - shrink (x, y, z) = - [ (x', y', z') - | (x', (y', z')) <- shrink (x, (y, z)) ] - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) - => Arbitrary (a,b,c,d) - where - arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary - - shrink (w, x, y, z) = - [ (w', x', y', z') - | (w', (x', (y', z'))) <- shrink (w, (x, (y, z))) ] - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) - => Arbitrary (a,b,c,d,e) - where - arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary - - shrink (v, w, x, y, z) = - [ (v', w', x', y', z') - | (v', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f - ) - => Arbitrary (a,b,c,d,e,f) - where - arbitrary = return (,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - - shrink (u, v, w, x, y, z) = - [ (u', v', w', x', y', z') - | (u', (v', (w', (x', (y', z'))))) <- shrink (u, (v, (w, (x, (y, z))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g - ) - => Arbitrary (a,b,c,d,e,f,g) - where - arbitrary = return (,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - - shrink (t, u, v, w, x, y, z) = - [ (t', u', v', w', x', y', z') - | (t', (u', (v', (w', (x', (y', z')))))) <- shrink (t, (u, (v, (w, (x, (y, z)))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h - ) - => Arbitrary (a,b,c,d,e,f,g,h) - where - arbitrary = return (,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - - shrink (s, t, u, v, w, x, y, z) = - [ (s', t', u', v', w', x', y', z') - | (s', (t', (u', (v', (w', (x', (y', z'))))))) - <- shrink (s, (t, (u, (v, (w, (x, (y, z))))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i - ) - => Arbitrary (a,b,c,d,e,f,g,h,i) - where - arbitrary = return (,,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary - - shrink (r, s, t, u, v, w, x, y, z) = - [ (r', s', t', u', v', w', x', y', z') - | (r', (s', (t', (u', (v', (w', (x', (y', z')))))))) - <- shrink (r, (s, (t, (u, (v, (w, (x, (y, z)))))))) ] - -instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e - , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j - ) - => Arbitrary (a,b,c,d,e,f,g,h,i,j) - where - arbitrary = return (,,,,,,,,,) - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - - shrink (q, r, s, t, u, v, w, x, y, z) = - [ (q', r', s', t', u', v', w', x', y', z') - | (q', (r', (s', (t', (u', (v', (w', (x', (y', z'))))))))) - <- shrink (q, (r, (s, (t, (u, (v, (w, (x, (y, z))))))))) ] - --- typical instance for primitive (numerical) types - -instance Arbitrary Integer where - arbitrary = arbitrarySizedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int where - arbitrary = arbitrarySizedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int8 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int16 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int32 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Int64 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word where - arbitrary = arbitrarySizedNatural - shrink = shrinkIntegral - -instance Arbitrary Word8 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word16 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word32 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Word64 where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary Char where - arbitrary = - frequency - [(3, arbitraryASCIIChar), - (1, arbitraryUnicodeChar)] - - shrink c = filter (<. c) $ nub - $ ['a','b','c'] - ++ [ toLower c | isUpper c ] - ++ ['A','B','C'] - ++ ['1','2','3'] - ++ [' ','\n'] - where - a <. b = stamp a < stamp b - stamp a = ( (not (isLower a) - , not (isUpper a) - , not (isDigit a)) - , (not (a==' ') - , not (isSpace a) - , a) - ) - -instance Arbitrary Float where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary Double where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary CChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUChar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CShort where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUShort where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CInt where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUInt where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CULong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CPtrdiff where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSize where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CWchar where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CSigAtomic where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CLLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CULLong where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CIntPtr where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUIntPtr where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CIntMax where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -instance Arbitrary CUIntMax where - arbitrary = arbitrarySizedBoundedIntegral - shrink = shrinkIntegral - -#ifndef NO_CTYPES_CONSTRUCTORS --- The following four types have no Bounded instance, --- so we fake it by discovering the bounds at runtime. -instance Arbitrary CClock where - arbitrary = fmap CClock arbitrary - shrink (CClock x) = map CClock (shrink x) - -instance Arbitrary CTime where - arbitrary = fmap CTime arbitrary - shrink (CTime x) = map CTime (shrink x) - -#ifndef NO_FOREIGN_C_USECONDS -instance Arbitrary CUSeconds where - arbitrary = fmap CUSeconds arbitrary - shrink (CUSeconds x) = map CUSeconds (shrink x) - -instance Arbitrary CSUSeconds where - arbitrary = fmap CSUSeconds arbitrary - shrink (CSUSeconds x) = map CSUSeconds (shrink x) -#endif -#endif - -instance Arbitrary CFloat where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - -instance Arbitrary CDouble where - arbitrary = arbitrarySizedFractional - shrink = shrinkDecimal - --- Arbitrary instances for container types -instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where - arbitrary = fmap Set.fromList arbitrary - shrink = map Set.fromList . shrink . Set.toList -instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where - liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary - liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList -instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where - arbitrary = arbitrary1 - shrink = shrink1 -instance Arbitrary IntSet.IntSet where - arbitrary = fmap IntSet.fromList arbitrary - shrink = map IntSet.fromList . shrink . IntSet.toList -instance Arbitrary1 IntMap.IntMap where - liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary - liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList -instance Arbitrary a => Arbitrary (IntMap.IntMap a) where - arbitrary = arbitrary1 - shrink = shrink1 -instance Arbitrary1 Sequence.Seq where - liftArbitrary = fmap Sequence.fromList . liftArbitrary - liftShrink shr = map Sequence.fromList . liftShrink shr . toList -instance Arbitrary a => Arbitrary (Sequence.Seq a) where - arbitrary = arbitrary1 - shrink = shrink1 - --- Arbitrary instance for Ziplist -instance Arbitrary1 ZipList where - liftArbitrary = fmap ZipList . liftArbitrary - liftShrink shr = map ZipList . liftShrink shr . getZipList -instance Arbitrary a => Arbitrary (ZipList a) where - arbitrary = arbitrary1 - shrink = shrink1 - -#ifndef NO_TRANSFORMERS --- Arbitrary instance for transformers' Functors -instance Arbitrary1 Identity where - liftArbitrary = fmap Identity - liftShrink shr = map Identity . shr . runIdentity -instance Arbitrary a => Arbitrary (Identity a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance Arbitrary2 Constant where - liftArbitrary2 arbA _ = fmap Constant arbA - liftShrink2 shrA _ = fmap Constant . shrA . getConstant -instance Arbitrary a => Arbitrary1 (Constant a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink --- Have to be defined explicitly, as Constant is kind polymorphic -instance Arbitrary a => Arbitrary (Constant a b) where - arbitrary = fmap Constant arbitrary - shrink = map Constant . shrink . getConstant - -instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where - liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) - liftShrink shr (Pair f g) = - [ Pair f' g | f' <- liftShrink shr f ] ++ - [ Pair f g' | g' <- liftShrink shr g ] -instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where - arbitrary = arbitrary1 - shrink = shrink1 - -instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where - liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary - liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose -instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where - arbitrary = arbitrary1 - shrink = shrink1 -#endif - --- Arbitrary instance for Const -instance Arbitrary2 Const where - liftArbitrary2 arbA _ = fmap Const arbA - liftShrink2 shrA _ = fmap Const . shrA . getConst -instance Arbitrary a => Arbitrary1 (Const a) where - liftArbitrary = liftArbitrary2 arbitrary - liftShrink = liftShrink2 shrink --- Have to be defined explicitly, as Const is kind polymorphic -instance Arbitrary a => Arbitrary (Const a b) where - arbitrary = fmap Const arbitrary - shrink = map Const . shrink . getConst - -instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where - arbitrary = WrapMonad <$> arbitrary - shrink (WrapMonad a) = map WrapMonad (shrink a) - -instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where - arbitrary = WrapArrow <$> arbitrary - shrink (WrapArrow a) = map WrapArrow (shrink a) - --- Arbitrary instances for Monoid -instance Arbitrary a => Arbitrary (Monoid.Dual a) where - arbitrary = fmap Monoid.Dual arbitrary - shrink = map Monoid.Dual . shrink . Monoid.getDual - -instance (Arbitrary a, CoArbitrary a) => Arbitrary (Monoid.Endo a) where - arbitrary = fmap Monoid.Endo arbitrary - shrink = map Monoid.Endo . shrink . Monoid.appEndo - -instance Arbitrary Monoid.All where - arbitrary = fmap Monoid.All arbitrary - shrink = map Monoid.All . shrink . Monoid.getAll - -instance Arbitrary Monoid.Any where - arbitrary = fmap Monoid.Any arbitrary - shrink = map Monoid.Any . shrink . Monoid.getAny - -instance Arbitrary a => Arbitrary (Monoid.Sum a) where - arbitrary = fmap Monoid.Sum arbitrary - shrink = map Monoid.Sum . shrink . Monoid.getSum - -instance Arbitrary a => Arbitrary (Monoid.Product a) where - arbitrary = fmap Monoid.Product arbitrary - shrink = map Monoid.Product . shrink . Monoid.getProduct - -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) -instance Arbitrary a => Arbitrary (Monoid.First a) where - arbitrary = fmap Monoid.First arbitrary - shrink = map Monoid.First . shrink . Monoid.getFirst - -instance Arbitrary a => Arbitrary (Monoid.Last a) where - arbitrary = fmap Monoid.Last arbitrary - shrink = map Monoid.Last . shrink . Monoid.getLast -#endif - -#if MIN_VERSION_base(4,8,0) -instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where - arbitrary = fmap Monoid.Alt arbitrary - shrink = map Monoid.Alt . shrink . Monoid.getAlt -#endif -#endif - --- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ -instance Arbitrary Version where - arbitrary = sized $ \n -> - do k <- chooseInt (0, log2 n) - xs <- vectorOf (k+1) arbitrarySizedNatural - return (Version xs []) - where - log2 :: Int -> Int - log2 n | n <= 1 = 0 - | otherwise = 1 + log2 (n `div` 2) - - shrink (Version xs _) = - [ Version xs' [] - | xs' <- shrink xs - , length xs' > 0 - , all (>=0) xs' - ] - -instance Arbitrary QCGen where - arbitrary = MkGen (\g _ -> g) - -instance Arbitrary ExitCode where - arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] - - shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] - shrink _ = [] - - - --- ** Helper functions for implementing arbitrary - --- | Apply a binary function to random arguments. -applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r -applyArbitrary2 f = liftA2 f arbitrary arbitrary - --- | Apply a ternary function to random arguments. -applyArbitrary3 - :: (Arbitrary a, Arbitrary b, Arbitrary c) - => (a -> b -> c -> r) -> Gen r -applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary - --- | Apply a function of arity 4 to random arguments. -applyArbitrary4 - :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) - => (a -> b -> c -> d -> r) -> Gen r -applyArbitrary4 f = applyArbitrary3 (uncurry f) - --- | Generates an integral number. The number can be positive or negative --- and its maximum absolute value depends on the size parameter. -arbitrarySizedIntegral :: Integral a => Gen a -arbitrarySizedIntegral = - sized $ \n -> - inBounds fromIntegral (chooseInt (-n, n)) - --- | Generates a natural number. The number's maximum value depends on --- the size parameter. -arbitrarySizedNatural :: Integral a => Gen a -arbitrarySizedNatural = - sized $ \n -> - inBounds fromIntegral (chooseInt (0, n)) - -inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a -inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x))) - --- | Generates a fractional number. The number can be positive or negative --- and its maximum absolute value depends on the size parameter. -arbitrarySizedFractional :: Fractional a => Gen a -arbitrarySizedFractional = - sized $ \n -> - let n' = toInteger n in - do b <- chooseInteger (1, precision) - a <- chooseInteger ((-n') * b, n' * b) - return (fromRational (a % b)) - where - precision = 9999999999999 :: Integer - --- Useful for getting at minBound and maxBound without having to --- fiddle around with asTypeOf. -{-# INLINE withBounds #-} -withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a -withBounds k = k minBound maxBound - --- | Generates an integral number. The number is chosen uniformly from --- the entire range of the type. You may want to use --- 'arbitrarySizedBoundedIntegral' instead. -arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a -arbitraryBoundedIntegral = chooseBoundedIntegral (minBound, maxBound) - --- | Generates an element of a bounded type. The element is --- chosen from the entire range of the type. -arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a -arbitraryBoundedRandom = choose (minBound,maxBound) - --- | Generates an element of a bounded enumeration. -arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a -arbitraryBoundedEnum = chooseEnum (minBound, maxBound) - --- | Generates an integral number from a bounded domain. The number is --- chosen from the entire range of the type, but small numbers are --- generated more often than big numbers. Inspired by demands from --- Phil Wadler. -arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a --- INLINEABLE so that this combinator gets specialised at each type, --- which means that the constant 'bits' in the let-block below will --- only be computed once. -{-# INLINEABLE arbitrarySizedBoundedIntegral #-} -arbitrarySizedBoundedIntegral = - withBounds $ \mn mx -> - let ilog2 1 = 0 - ilog2 n | n > 0 = 1 + ilog2 (n `div` 2) - - -- How many bits are needed to represent this type? - -- (This number is an upper bound, not exact.) - bits = ilog2 (toInteger mx - toInteger mn + 1) in - sized $ \k -> - let - -- Reach maximum size by k=80, or quicker for small integer types - power = ((bits `max` 40) * k) `div` 80 - - -- Bounds should be 2^power, but: - -- * clamp the result to minBound/maxBound - -- * clamp power to 'bits', in case k is a huge number - lo = toInteger mn `max` (-1 `shiftL` (power `min` bits)) - hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in - fmap fromInteger (chooseInteger (lo, hi)) - --- ** Generators for various kinds of character - --- | Generates any Unicode character (but not a surrogate) -arbitraryUnicodeChar :: Gen Char -arbitraryUnicodeChar = - arbitraryBoundedEnum `suchThat` isValidUnicode - where - isValidUnicode c = case generalCategory c of - Surrogate -> False - NotAssigned -> False - _ -> True - --- | Generates a random ASCII character (0-127). -arbitraryASCIIChar :: Gen Char -arbitraryASCIIChar = chooseEnum ('\0', '\127') - --- | Generates a printable Unicode character. -arbitraryPrintableChar :: Gen Char -arbitraryPrintableChar = arbitrary `suchThat` isPrint - --- ** Helper functions for implementing shrink - --- | Returns no shrinking alternatives. -shrinkNothing :: a -> [a] -shrinkNothing _ = [] - --- | Map a shrink function to another domain. This is handy if your data type --- has special invariants, but is /almost/ isomorphic to some other type. --- --- @ --- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] --- shrinkOrderedList = shrinkMap sort id --- --- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] --- shrinkSet = shrinkMap fromList toList --- @ -shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] -shrinkMap f g = shrinkMapBy f g shrink - --- | Non-overloaded version of `shrinkMap`. -shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] -shrinkMapBy f g shr = map f . shr . g - --- | Shrink an integral number. -shrinkIntegral :: Integral a => a -> [a] -shrinkIntegral x = - nub $ - [ -x - | x < 0, -x > x - ] ++ - [ x' - | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) - ] - where - -- a << b is "morally" abs a < abs b, but taking care of overflow. - a << b = case (a >= 0, b >= 0) of - (True, True) -> a < b - (False, False) -> a > b - (True, False) -> a + b < 0 - (False, True) -> a + b > 0 - --- | Shrink a fraction, preferring numbers with smaller --- numerators or denominators. See also 'shrinkDecimal'. -shrinkRealFrac :: RealFrac a => a -> [a] -shrinkRealFrac x - | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN - | not (2*x+1>x) = 0 : takeWhile ( abs y < abs x) $ - -- Try shrinking to an integer first - map fromInteger (shrink (truncate x) ++ [truncate x]) ++ - -- Shrink the numerator - [fromRational (num' % denom) | num' <- shrink num] ++ - -- Shrink the denominator, and keep the fraction as close - -- to the original as possible, rounding towards zero - [fromRational (truncate (num * denom' % denom) % denom') - | denom' <- shrink denom, denom' /= 0 ] - where - num = numerator (toRational x) - denom = denominator (toRational x) - --- | Shrink a real number, preferring numbers with shorter --- decimal representations. See also 'shrinkRealFrac'. -shrinkDecimal :: RealFrac a => a -> [a] -shrinkDecimal x - | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN - | not (2*abs x+1>abs x) = 0 : takeWhile ( instance CoArbitrary MyType --- --- You should only use 'genericCoarbitrary' for data types where --- equality is structural, i.e. if you can't have two different --- representations of the same value. An example where it's not --- safe is sets implemented using binary search trees: the same --- set can be represented as several different trees. --- Here you would have to explicitly define --- @coarbitrary s = coarbitrary (toList s)@. -#else --- | Used for random generation of functions. -#endif -class CoArbitrary a where - -- | Used to generate a function of type @a -> b@. - -- The first argument is a value, the second a generator. - -- You should use 'variant' to perturb the random generator; - -- the goal is that different values for the first argument will - -- lead to different calls to 'variant'. An example will help: - -- - -- @ - -- instance CoArbitrary a => CoArbitrary [a] where - -- coarbitrary [] = 'variant' 0 - -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) - -- @ - coarbitrary :: a -> Gen b -> Gen b -#ifndef NO_GENERICS - default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b - coarbitrary = genericCoarbitrary - --- | Generic CoArbitrary implementation. -genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b -genericCoarbitrary = gCoarbitrary . from - -class GCoArbitrary f where - gCoarbitrary :: f a -> Gen b -> Gen b - -instance GCoArbitrary U1 where - gCoarbitrary U1 = id - -instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where - -- Like the instance for tuples. - gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r - -instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where - -- Like the instance for Either. - gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x - gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x - -instance GCoArbitrary f => GCoArbitrary (M1 i c f) where - gCoarbitrary (M1 x) = gCoarbitrary x - -instance CoArbitrary a => GCoArbitrary (K1 i a) where - gCoarbitrary (K1 x) = coarbitrary x -#endif - -{-# DEPRECATED (><) "Use ordinary function composition instead" #-} --- | Combine two generator perturbing functions, for example the --- results of calls to 'variant' or 'coarbitrary'. -(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) -(><) = (.) - -instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where - coarbitrary f gen = - do xs <- arbitrary - coarbitrary (map f xs) gen - -instance CoArbitrary () where - coarbitrary _ = id - -instance CoArbitrary Bool where - coarbitrary False = variant 0 - coarbitrary True = variant 1 - -instance CoArbitrary Ordering where - coarbitrary GT = variant 0 - coarbitrary EQ = variant 1 - coarbitrary LT = variant 2 - -instance CoArbitrary a => CoArbitrary (Maybe a) where - coarbitrary Nothing = variant 0 - coarbitrary (Just x) = variant 1 . coarbitrary x - -instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where - coarbitrary (Left x) = variant 0 . coarbitrary x - coarbitrary (Right y) = variant 1 . coarbitrary y - -instance CoArbitrary a => CoArbitrary [a] where - coarbitrary [] = variant 0 - coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) - -instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where - coarbitrary r = coarbitrary (numerator r,denominator r) - -#ifndef NO_FIXED -instance HasResolution a => CoArbitrary (Fixed a) where - coarbitrary = coarbitraryReal -#endif - -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) -instance CoArbitrary a => CoArbitrary (Complex a) where -#else -instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where -#endif - coarbitrary (x :+ y) = coarbitrary x . coarbitrary y - -instance (CoArbitrary a, CoArbitrary b) - => CoArbitrary (a,b) - where - coarbitrary (x,y) = coarbitrary x - . coarbitrary y - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) - => CoArbitrary (a,b,c) - where - coarbitrary (x,y,z) = coarbitrary x - . coarbitrary y - . coarbitrary z - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) - => CoArbitrary (a,b,c,d) - where - coarbitrary (x,y,z,v) = coarbitrary x - . coarbitrary y - . coarbitrary z - . coarbitrary v - -instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) - => CoArbitrary (a,b,c,d,e) - where - coarbitrary (x,y,z,v,w) = coarbitrary x - . coarbitrary y - . coarbitrary z - . coarbitrary v - . coarbitrary w - --- typical instance for primitive (numerical) types - -instance CoArbitrary Integer where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int8 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int16 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int32 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Int64 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word8 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word16 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word32 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Word64 where - coarbitrary = coarbitraryIntegral - -instance CoArbitrary Char where - coarbitrary = coarbitrary . ord - -instance CoArbitrary Float where - coarbitrary = coarbitraryReal - -instance CoArbitrary Double where - coarbitrary = coarbitraryReal - --- Coarbitrary instances for container types -instance CoArbitrary a => CoArbitrary (Set.Set a) where - coarbitrary = coarbitrary. Set.toList -instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where - coarbitrary = coarbitrary . Map.toList -instance CoArbitrary IntSet.IntSet where - coarbitrary = coarbitrary . IntSet.toList -instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where - coarbitrary = coarbitrary . IntMap.toList -instance CoArbitrary a => CoArbitrary (Sequence.Seq a) where - coarbitrary = coarbitrary . toList - --- CoArbitrary instance for Ziplist -instance CoArbitrary a => CoArbitrary (ZipList a) where - coarbitrary = coarbitrary . getZipList - -#ifndef NO_TRANSFORMERS --- CoArbitrary instance for transformers' Functors -instance CoArbitrary a => CoArbitrary (Identity a) where - coarbitrary = coarbitrary . runIdentity - -instance CoArbitrary a => CoArbitrary (Constant a b) where - coarbitrary = coarbitrary . getConstant -#endif - --- CoArbitrary instance for Const -instance CoArbitrary a => CoArbitrary (Const a b) where - coarbitrary = coarbitrary . getConst - --- CoArbitrary instances for Monoid -instance CoArbitrary a => CoArbitrary (Monoid.Dual a) where - coarbitrary = coarbitrary . Monoid.getDual - -instance (Arbitrary a, CoArbitrary a) => CoArbitrary (Monoid.Endo a) where - coarbitrary = coarbitrary . Monoid.appEndo - -instance CoArbitrary Monoid.All where - coarbitrary = coarbitrary . Monoid.getAll - -instance CoArbitrary Monoid.Any where - coarbitrary = coarbitrary . Monoid.getAny - -instance CoArbitrary a => CoArbitrary (Monoid.Sum a) where - coarbitrary = coarbitrary . Monoid.getSum - -instance CoArbitrary a => CoArbitrary (Monoid.Product a) where - coarbitrary = coarbitrary . Monoid.getProduct - -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) -instance CoArbitrary a => CoArbitrary (Monoid.First a) where - coarbitrary = coarbitrary . Monoid.getFirst - -instance CoArbitrary a => CoArbitrary (Monoid.Last a) where - coarbitrary = coarbitrary . Monoid.getLast -#endif - -#if MIN_VERSION_base(4,8,0) -instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where - coarbitrary = coarbitrary . Monoid.getAlt -#endif -#endif - -instance CoArbitrary Version where - coarbitrary (Version a b) = coarbitrary (a, b) - --- ** Helpers for implementing coarbitrary - --- | A 'coarbitrary' implementation for integral numbers. -coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b -coarbitraryIntegral = variant - --- | A 'coarbitrary' implementation for real numbers. -coarbitraryReal :: Real a => a -> Gen b -> Gen b -coarbitraryReal x = coarbitrary (toRational x) - --- | 'coarbitrary' helper for lazy people :-). -coarbitraryShow :: Show a => a -> Gen b -> Gen b -coarbitraryShow x = coarbitrary (show x) - --- | A 'coarbitrary' implementation for enums. -coarbitraryEnum :: Enum a => a -> Gen b -> Gen b -coarbitraryEnum = variant . fromEnum - --------------------------------------------------------------------------- --- ** arbitrary generators - --- these are here and not in Gen because of the Arbitrary class constraint - --- | Generates a list of a given length. -vector :: Arbitrary a => Int -> Gen [a] -vector k = vectorOf k arbitrary - --- | Generates an ordered list. -orderedList :: (Ord a, Arbitrary a) => Gen [a] -orderedList = sort `fmap` arbitrary - --- | Generates an infinite list. -infiniteList :: Arbitrary a => Gen [a] -infiniteList = infiniteListOf arbitrary - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs deleted file mode 100644 --- a/Test/QuickCheck/Exception.hs +++ /dev/null @@ -1,117 +0,0 @@ --- | Throwing and catching exceptions. Internal QuickCheck module. - --- Hide away the nasty implementation-specific ways of catching --- exceptions behind a nice API. The main trouble is catching ctrl-C. - -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE CPP #-} -module Test.QuickCheck.Exception where - -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) -#define OLD_EXCEPTIONS -#endif - -#if defined(NO_EXCEPTIONS) -#else -import qualified Control.Exception as E -#endif - -#if defined(NO_EXCEPTIONS) -type AnException = () -#elif defined(OLD_EXCEPTIONS) -type AnException = E.Exception -#else -type AnException = E.SomeException -#endif - -#ifdef NO_EXCEPTIONS -tryEvaluate :: a -> IO (Either AnException a) -tryEvaluate x = return (Right x) - -tryEvaluateIO :: IO a -> IO (Either AnException a) -tryEvaluateIO m = fmap Right m - -evaluate :: a -> IO a -evaluate x = x `seq` return x - -isInterrupt :: AnException -> Bool -isInterrupt _ = False - -discard :: a -discard = error "'discard' not supported, since your Haskell system can't catch exceptions" - -isDiscard :: AnException -> Bool -isDiscard _ = False - -finally :: IO a -> IO b -> IO a -finally mx my = do - x <- mx - my - return x - -#else --------------------------------------------------------------------------- --- try evaluate - -tryEvaluate :: a -> IO (Either AnException a) -tryEvaluate x = tryEvaluateIO (return x) - -tryEvaluateIO :: IO a -> IO (Either AnException a) -tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) - where - notAsync :: AnException -> Maybe AnException -#if MIN_VERSION_base(4,7,0) - notAsync e = case E.fromException e of - Just (E.SomeAsyncException _) -> Nothing - Nothing -> Just e -#elif !defined(OLD_EXCEPTIONS) - notAsync e = case E.fromException e :: Maybe E.AsyncException of - Just _ -> Nothing - Nothing -> Just e -#else - notAsync e = Just e -#endif - ---tryEvaluateIO m = Right `fmap` m - -evaluate :: a -> IO a -evaluate = E.evaluate - --- | Test if an exception was a @^C@. --- QuickCheck won't try to shrink an interrupted test case. -isInterrupt :: AnException -> Bool - -#if defined(OLD_EXCEPTIONS) -isInterrupt _ = False -#else -isInterrupt e = E.fromException e == Just E.UserInterrupt -#endif - --- | A special error value. If a property evaluates 'discard', it --- causes QuickCheck to discard the current test case. --- This can be useful if you want to discard the current test case, --- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a --- generator. -discard :: a - -isDiscard :: AnException -> Bool -(discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) - where - msg = "DISCARD. " ++ - "You should not see this exception, it is internal to QuickCheck." -#if defined(OLD_EXCEPTIONS) - isDiscard (E.ErrorCall msg') = msg' == msg - isDiscard _ = False -#else - isDiscard e = - case E.fromException e of - Just (E.ErrorCall msg') -> msg' == msg - _ -> False -#endif - -finally :: IO a -> IO b -> IO a -finally = E.finally -#endif - --------------------------------------------------------------------------- --- the end. 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 " ++ - concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) - mapM_ (putLine (terminal state)) (failingTestCase res) - putStrLn "" - loop (Set.union feats feats') - state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} - _ -> do - out <- terminalOutput nullterm - putStr out - return res - at0 f s 0 0 = s - at0 f s n d = f n d - loop Set.empty state diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs deleted file mode 100644 --- a/Test/QuickCheck/Function.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -#endif - -#ifndef NO_GENERICS -{-# LANGUAGE DefaultSignatures, FlexibleContexts #-} -#endif - -#ifndef NO_POLYKINDS -{-# LANGUAGE PolyKinds #-} -#endif - --- | Generation of random shrinkable, showable functions. --- See the paper \"Shrinking and showing functions\" by Koen Claessen. --- --- __Note__: most of the contents of this module are re-exported by --- "Test.QuickCheck". You probably do not need to import it directly. --- --- Example of use: --- --- >>> :{ --- >>> let prop :: Fun String Integer -> Bool --- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" --- >>> :} --- >>> quickCheck prop --- *** Failed! Falsified (after 3 tests and 134 shrinks): --- {"elephant"->1, "monkey"->1, _->0} --- --- To generate random values of type @'Fun' a b@, --- you must have an instance @'Function' a@. --- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, --- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. --- See the @'Function' [a]@ instance for an example of the latter. -module Test.QuickCheck.Function - ( Fun(..) - , applyFun - , apply - , applyFun2 - , applyFun3 - , (:->) - , Function(..) - , functionMap - , functionShow - , functionIntegral - , functionRealFrac - , functionBoundedEnum - , functionVoid - , functionMapWith - , functionEitherWith - , functionPairWith -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 - , pattern Fn - , pattern Fn2 - , pattern Fn3 -#endif - ) - where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Poly - -import Control.Applicative -import Data.Char -import Data.Word -import Data.List( intersperse ) -import Data.Ratio -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Sequence as Sequence -import Data.Int -import Data.Complex -import Data.Foldable(toList) -import Data.Functor.Identity -import qualified Data.Monoid as Monoid - -#ifndef NO_FIXED -import Data.Fixed -#endif - -#ifndef NO_GENERICS -import GHC.Generics hiding (C) -#endif - --------------------------------------------------------------------------- --- concrete functions - --- | The type of possibly partial concrete functions -data a :-> c where - Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c) - (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) - Unit :: c -> (() :-> c) - Nil :: a :-> c - Table :: Eq a => [(a,c)] -> (a :-> c) - Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c) - -instance Functor ((:->) a) where - fmap f (Pair p) = Pair (fmap (fmap f) p) - fmap f (p:+:q) = fmap f p :+: fmap f q - fmap f (Unit c) = Unit (f c) - fmap f Nil = Nil - fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ] - fmap f (Map g h p) = Map g h (fmap f p) - -instance (Show a, Show b) => Show (a:->b) where - show p = showFunction p Nothing - --- only use this on finite functions -showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String -showFunction p md = - "{" ++ concat (intersperse ", " ( [ show x ++ "->" ++ show c - | (x,c) <- table p - ] - ++ [ "_->" ++ show d - | Just d <- [md] - ] )) ++ "}" - --- turning a concrete function into an abstract function (with a default result) -abstract :: (a :-> c) -> c -> (a -> c) -abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x -abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy -abstract (Unit c) _ _ = c -abstract Nil d _ = d -abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d]) -abstract (Map g _ p) d x = abstract p d (g x) - --- generating a table from a concrete function -table :: (a :-> c) -> [(a,c)] -table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ] -table (p :+: q) = [ (Left x, c) | (x,c) <- table p ] - ++ [ (Right y,c) | (y,c) <- table q ] -table (Unit c) = [ ((), c) ] -table Nil = [] -table (Table xys) = xys -table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] - --------------------------------------------------------------------------- --- Function - --- | The class @Function a@ is used for random generation of showable --- functions of type @a -> b@. --- --- There is a default implementation for 'function', which you can use --- if your type has structural equality. Otherwise, you can normally --- use 'functionMap' or 'functionShow'. -class Function a where - function :: (a->b) -> (a:->b) -#ifndef NO_GENERICS - default function :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) - function = genericFunction -#endif - --- basic instances - --- | Provides a 'Function' instance for types with 'Bounded' and 'Enum'. --- Use only for small types (i.e. not integers): creates --- the list @['minBound'..'maxBound']@! -functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b) -functionBoundedEnum f = Table [(x,f x) | x <- [minBound..maxBound]] - --- | Provides a 'Function' instance for types with 'RealFrac'. -functionRealFrac :: RealFrac a => (a->b) -> (a:->b) -functionRealFrac = functionMap toRational fromRational - --- | Provides a 'Function' instance for types with 'Integral'. -functionIntegral :: Integral a => (a->b) -> (a:->b) -functionIntegral = functionMap fromIntegral fromInteger - --- | Provides a 'Function' instance for types with 'Show' and 'Read'. -functionShow :: (Show a, Read a) => (a->c) -> (a:->c) -functionShow f = functionMap show read f - --- | Provides a 'Function' instance for types isomorphic to 'Data.Void.Void'. --- --- An actual @'Function' 'Data.Void.Void'@ instance is defined in --- @quickcheck-instances@. -functionVoid :: (forall b. void -> b) -> void :-> c -functionVoid _ = Nil - --- | The basic building block for 'Function' instances. --- Provides a 'Function' instance by mapping to and from a type that --- already has a 'Function' instance. -functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) -functionMap = functionMapWith function - --- | @since 2.13.3 -functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) -functionMapWith function g h f = Map g h (function (\b -> f (h b))) - -instance Function () where - function f = Unit (f ()) - -instance Function a => Function (Const a b) where - function = functionMap getConst Const - -instance Function a => Function (Identity a) where - function = functionMap runIdentity Identity - -instance (Function a, Function b) => Function (a,b) where - function = functionPairWith function function - --- | @since 2.13.3 -functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) -functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) - -instance (Function a, Function b) => Function (Either a b) where - function = functionEitherWith function function - --- | @since 2.13.3 -functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) -functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (f . Right) - --- tuple convenience instances - -instance (Function a, Function b, Function c) => Function (a,b,c) where - function = functionMap (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c)) - -instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where - function = functionMap (\(a,b,c,d) -> (a,(b,c,d))) (\(a,(b,c,d)) -> (a,b,c,d)) - -instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where - function = functionMap (\(a,b,c,d,e) -> (a,(b,c,d,e))) (\(a,(b,c,d,e)) -> (a,b,c,d,e)) - -instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where - function = functionMap (\(a,b,c,d,e,f) -> (a,(b,c,d,e,f))) (\(a,(b,c,d,e,f)) -> (a,b,c,d,e,f)) - -instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where - function = functionMap (\(a,b,c,d,e,f,g) -> (a,(b,c,d,e,f,g))) (\(a,(b,c,d,e,f,g)) -> (a,b,c,d,e,f,g)) - --- other instances - -instance Function a => Function [a] where - function = functionMap g h - where - g [] = Left () - g (x:xs) = Right (x,xs) - - h (Left _) = [] - h (Right (x,xs)) = x:xs - -instance Function a => Function (Maybe a) where - function = functionMap g h - where - g Nothing = Left () - g (Just x) = Right x - - h (Left _) = Nothing - h (Right x) = Just x - -instance Function Bool where - function = functionMap g h - where - g False = Left () - g True = Right () - - h (Left _) = False - h (Right _) = True - -instance Function Integer where - function = functionMap gInteger hInteger - where - gInteger n | n < 0 = Left (gNatural (abs n - 1)) - | otherwise = Right (gNatural n) - - hInteger (Left ws) = -(hNatural ws + 1) - hInteger (Right ws) = hNatural ws - - gNatural 0 = [] - gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256) - - hNatural [] = 0 - hNatural (w:ws) = fromIntegral w + 256 * hNatural ws - -instance Function Int where - function = functionIntegral - -instance Function Word where - function = functionIntegral - -instance Function Char where - function = functionMap ord chr - -instance Function Float where - function = functionRealFrac - -instance Function Double where - function = functionRealFrac - --- instances for assorted types in the base package - -instance Function Ordering where - function = functionMap g h - where - g LT = Left False - g EQ = Left True - g GT = Right () - - h (Left False) = LT - h (Left True) = EQ - h (Right _) = GT - -instance (Integral a, Function a) => Function (Ratio a) where - function = functionMap g h - where - g r = (numerator r, denominator r) - h (n, d) = n % d - -#ifndef NO_FIXED -instance HasResolution a => Function (Fixed a) where - function = functionRealFrac -#endif - -instance (RealFloat a, Function a) => Function (Complex a) where - function = functionMap g h - where - g (x :+ y) = (x, y) - h (x, y) = x :+ y - -instance (Ord a, Function a) => Function (Set.Set a) where - function = functionMap Set.toList Set.fromList - -instance (Ord a, Function a, Function b) => Function (Map.Map a b) where - function = functionMap Map.toList Map.fromList - -instance Function IntSet.IntSet where - function = functionMap IntSet.toList IntSet.fromList - -instance Function a => Function (IntMap.IntMap a) where - function = functionMap IntMap.toList IntMap.fromList - -instance Function a => Function (Sequence.Seq a) where - function = functionMap toList Sequence.fromList - -instance Function Int8 where - function = functionBoundedEnum - -instance Function Int16 where - function = functionIntegral - -instance Function Int32 where - function = functionIntegral - -instance Function Int64 where - function = functionIntegral - -instance Function Word8 where - function = functionBoundedEnum - -instance Function Word16 where - function = functionIntegral - -instance Function Word32 where - function = functionIntegral - -instance Function Word64 where - function = functionIntegral - --- instances for Data.Monoid newtypes - -instance Function a => Function (Monoid.Dual a) where - function = functionMap Monoid.getDual Monoid.Dual - -instance Function Monoid.All where - function = functionMap Monoid.getAll Monoid.All - -instance Function Monoid.Any where - function = functionMap Monoid.getAny Monoid.Any - -instance Function a => Function (Monoid.Sum a) where - function = functionMap Monoid.getSum Monoid.Sum - -instance Function a => Function (Monoid.Product a) where - function = functionMap Monoid.getProduct Monoid.Product - -instance Function a => Function (Monoid.First a) where - function = functionMap Monoid.getFirst Monoid.First - -instance Function a => Function (Monoid.Last a) where - function = functionMap Monoid.getLast Monoid.Last - -#if MIN_VERSION_base(4,8,0) -instance Function (f a) => Function (Monoid.Alt f a) where - function = functionMap Monoid.getAlt Monoid.Alt -#endif - --- poly instances - -instance Function A where - function = functionMap unA A - -instance Function B where - function = functionMap unB B - -instance Function C where - function = functionMap unC C - -instance Function OrdA where - function = functionMap unOrdA OrdA - -instance Function OrdB where - function = functionMap unOrdB OrdB - -instance Function OrdC where - function = functionMap unOrdC OrdC - --- instance Arbitrary - -instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where - arbitrary = function `fmap` arbitrary - shrink = shrinkFun shrink - --------------------------------------------------------------------------- --- generic function instances - -#ifndef NO_GENERICS --- | Generic 'Function' implementation. -genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) -genericFunction = functionMapWith gFunction from to - -class GFunction f where - gFunction :: (f a -> b) -> (f a :-> b) - -instance GFunction U1 where - gFunction = functionMap (\U1 -> ()) (\() -> U1) - -instance (GFunction f, GFunction g) => GFunction (f :*: g) where - gFunction = functionMapWith (functionPairWith gFunction gFunction) g h - where - g (x :*: y) = (x, y) - h (x, y) = x :*: y - -instance (GFunction f, GFunction g) => GFunction (f :+: g) where - gFunction = functionMapWith (functionEitherWith gFunction gFunction) g h - where - g (L1 x) = Left x - g (R1 x) = Right x - h (Left x) = L1 x - h (Right x) = R1 x - -instance GFunction f => GFunction (M1 i c f) where - gFunction = functionMapWith gFunction (\(M1 x) -> x) M1 - -instance Function a => GFunction (K1 i a) where - gFunction = functionMap (\(K1 x) -> x) K1 -#endif - --------------------------------------------------------------------------- --- shrinking - -shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] -shrinkFun shr (Pair p) = - [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] - where - pair Nil = Nil - pair p = Pair p - -shrinkFun shr (p :+: q) = - [ p .+. Nil | not (isNil q) ] ++ - [ Nil .+. q | not (isNil p) ] ++ - [ p .+. q' | q' <- shrinkFun shr q ] ++ - [ p' .+. q | p' <- shrinkFun shr p ] - where - isNil :: (a :-> b) -> Bool - isNil Nil = True - isNil _ = False - - Nil .+. Nil = Nil - p .+. q = p :+: q - -shrinkFun shr (Unit c) = - [ Nil ] ++ - [ Unit c' | c' <- shr c ] - -shrinkFun shr (Table xys) = - [ table xys' | xys' <- shrinkList shrXy xys ] - where - shrXy (x,y) = [(x,y') | y' <- shr y] - - table [] = Nil - table xys = Table xys - -shrinkFun shr Nil = - [] - -shrinkFun shr (Map g h p) = - [ mapp g h p' | p' <- shrinkFun shr p ] - where - mapp g h Nil = Nil - mapp g h p = Map g h p - --------------------------------------------------------------------------- --- the Fun modifier - --- | Generation of random shrinkable, showable functions. --- --- To generate random values of type @'Fun' a b@, --- you must have an instance @'Function' a@. --- --- See also 'applyFun', and 'Fn' with GHC >= 7.8. -data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) -data Shrunk = Shrunk | NotShrunk deriving Eq - -instance Functor (Fun a) where - fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g) - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 --- | A modifier for testing functions. --- --- > prop :: Fun String Integer -> Bool --- > prop (Fn f) = f "banana" == f "monkey" --- > || f "banana" == f "elephant" -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn :: (a -> b) -> Fun a b -#endif -pattern Fn f <- (applyFun -> f) - --- | A modifier for testing binary functions. --- --- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool --- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c -#endif -pattern Fn2 f <- (applyFun2 -> f) - --- | A modifier for testing ternary functions. -#if __GLASGOW_HASKELL__ >= 800 -pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d -#endif -pattern Fn3 f <- (applyFun3 -> f) -#endif - -mkFun :: (a :-> b) -> b -> Fun a b -mkFun p d = Fun (p, d, NotShrunk) (abstract p d) - --- | Alias to 'applyFun'. -apply :: Fun a b -> (a -> b) -apply = applyFun - --- | Extracts the value of a function. --- --- 'Fn' is the pattern equivalent of this function. --- --- > prop :: Fun String Integer -> Bool --- > prop f = applyFun f "banana" == applyFun f "monkey" --- > || applyFun f "banana" == applyFun f "elephant" -applyFun :: Fun a b -> (a -> b) -applyFun (Fun _ f) = f - --- | Extracts the value of a binary function. --- --- 'Fn2' is the pattern equivalent of this function. --- --- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool --- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] --- -applyFun2 :: Fun (a, b) c -> (a -> b -> c) -applyFun2 (Fun _ f) a b = f (a, b) - --- | Extracts the value of a ternary function. 'Fn3' is the --- pattern equivalent of this function. -applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) -applyFun3 (Fun _ f) a b c = f (a, b, c) - -instance (Show a, Show b) => Show (Fun a b) where - show (Fun (_, _, NotShrunk) _) = "" - 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,352 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifndef NO_ST_MONAD -{-# LANGUAGE Rank2Types #-} -#endif --- | Test case generation. --- --- __Note__: the contents of this module (except for the definition of --- 'Gen') are re-exported by "Test.QuickCheck". You probably do not --- need to import it directly. -module Test.QuickCheck.Gen where - --------------------------------------------------------------------------- --- imports - -import System.Random - ( Random - , random - , randomR - , split - ) - -import Control.Monad - ( ap - , replicateM - , filterM - ) - -import Control.Monad.Fix - ( MonadFix(..) ) - -import Control.Applicative - ( Applicative(..) ) - -import Test.QuickCheck.Random -import Data.List -import Data.Ord -import Data.Maybe -#ifndef NO_SPLITMIX -import System.Random.SplitMix(bitmaskWithRejection64', SMGen) -#endif -import Data.Word -import Data.Int -import Data.Bits -import Control.Applicative - --------------------------------------------------------------------------- --- ** Generator type - --- | A generator for values of type @a@. --- --- The third-party packages --- --- and --- --- provide monad transformer versions of @Gen@. -newtype Gen a = MkGen{ - unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. - -- If you just want to get a random value out, consider using 'generate'. - } - -instance Functor Gen where - fmap f (MkGen h) = - MkGen (\r n -> f (h r n)) - -instance Applicative Gen where - pure x = - MkGen (\_ _ -> x) - (<*>) = ap - -#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE - -- We don't need to split the seed for these. - _ *> m = m - m <* _ = m -#endif - -instance Monad Gen where - return = pure - - MkGen m >>= k = - MkGen (\r n -> - case split r of - (r1, r2) -> - let MkGen m' = k (m r1 n) - in m' r2 n - ) - - (>>) = (*>) - -instance MonadFix Gen where - mfix f = - MkGen $ \r n -> - let a = unGen (f a) r n - in a - --------------------------------------------------------------------------- --- ** Primitive generator combinators - --- | Modifies a generator using an integer seed. -variant :: Integral n => n -> Gen a -> Gen a -variant k (MkGen g) = MkGen (\r n -> g (integerVariant (toInteger k) $! r) n) - --- | Used to construct generators that depend on the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = sized $ \n -> --- > do k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'getSize'. -sized :: (Int -> Gen a) -> Gen a -sized f = MkGen (\r n -> let MkGen m = f n in m r n) - --- | Returns the size parameter. Used to construct generators that depend on --- the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = do --- > n <- getSize --- > k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'sized'. -getSize :: Gen Int -getSize = sized pure - --- | Overrides the size parameter. Returns a generator which uses --- the given size instead of the runtime-size parameter. -resize :: Int -> Gen a -> Gen a -resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" -resize n (MkGen g) = MkGen (\r _ -> g r n) - --- | Adjust the size parameter, by transforming it with the given --- function. -scale :: (Int -> Int) -> Gen a -> Gen a -scale f g = sized (\n -> resize (f n) g) - --- | Generates a random element in the given inclusive range. --- For integral and enumerated types, the specialised variants of --- 'choose' below run much quicker. -choose :: Random a => (a,a) -> Gen a -choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) - --- | Generates a random element over the natural range of `a`. -chooseAny :: Random a => Gen a -chooseAny = MkGen (\r _ -> let (x,_) = random r in x) - --- | A fast implementation of 'choose' for enumerated types. -chooseEnum :: Enum a => (a, a) -> Gen a -chooseEnum (lo, hi) = - fmap toEnum (chooseInt (fromEnum lo, fromEnum hi)) - --- | A fast implementation of 'choose' for 'Int'. -chooseInt :: (Int, Int) -> Gen Int -chooseInt = chooseBoundedIntegral - --- Note about INLINEABLE: we specialise chooseBoundedIntegral --- for each concrete type, so that all the bounds checks get --- simplified away. -{-# INLINEABLE chooseBoundedIntegral #-} --- | A fast implementation of 'choose' for bounded integral types. -chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a -chooseBoundedIntegral (lo, hi) -#ifndef NO_SPLITMIX - | toInteger mn >= toInteger (minBound :: Int64) && - toInteger mx <= toInteger (maxBound :: Int64) = - fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi)) - | toInteger mn >= toInteger (minBound :: Word64) && - toInteger mx <= toInteger (maxBound :: Word64) = - fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi)) -#endif - | otherwise = - fmap fromInteger (chooseInteger (toInteger lo, toInteger hi)) -#ifndef NO_SPLITMIX - where - mn = minBound `asTypeOf` lo - mx = maxBound `asTypeOf` hi -#endif - --- | A fast implementation of 'choose' for 'Integer'. -chooseInteger :: (Integer, Integer) -> Gen Integer -#ifdef NO_SPLITMIX -chooseInteger = choose -#else -chooseInteger (lo, hi) - | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) && - hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) = - fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi)) - | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) && - hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) = - fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi)) - | otherwise = choose (lo, hi) - -chooseWord64 :: (Word64, Word64) -> Gen Word64 -chooseWord64 (lo, hi) - | lo <= hi = chooseWord64' (lo, hi) - | otherwise = chooseWord64' (hi, lo) - where - chooseWord64' :: (Word64, Word64) -> Gen Word64 - chooseWord64' (lo, hi) = - fmap (+ lo) (chooseUpTo (hi - lo)) - -chooseInt64 :: (Int64, Int64) -> Gen Int64 -chooseInt64 (lo, hi) - | lo <= hi = chooseInt64' (lo, hi) - | otherwise = chooseInt64' (hi, lo) - where - chooseInt64' :: (Int64, Int64) -> Gen Int64 - chooseInt64' (lo, hi) = do - w <- chooseUpTo (fromIntegral hi - fromIntegral lo) - return (fromIntegral (w + fromIntegral lo)) - -chooseUpTo :: Word64 -> Gen Word64 -chooseUpTo n = - MkGen $ \(QCGen g) _ -> - fst (bitmaskWithRejection64' n g) -#endif - --- | Run a generator. The size passed to the generator is always 30; --- if you want another size then you should explicitly use 'resize'. -generate :: Gen a -> IO a -generate (MkGen g) = - do r <- newQCGen - return (g r 30) - --- | Generates some example values. -sample' :: Gen a -> IO [a] -sample' g = - generate (sequence [ resize n g | n <- [0,2..20] ]) - --- | Generates some example values and prints them to 'stdout'. -sample :: Show a => Gen a -> IO () -sample g = - do cases <- sample' g - mapM_ print cases - --------------------------------------------------------------------------- --- ** Common generator combinators - --- | Generates a value that satisfies a predicate. -suchThat :: Gen a -> (a -> Bool) -> Gen a -gen `suchThat` p = - do mx <- gen `suchThatMaybe` p - case mx of - Just x -> return x - Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) - --- | Generates a value for which the given function returns a 'Just', and then --- applies the function. -suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b -gen `suchThatMap` f = - fmap fromJust $ fmap f gen `suchThat` isJust - --- | Tries to generate a value that satisfies a predicate. --- If it fails to do so after enough attempts, returns @Nothing@. -suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) -gen `suchThatMaybe` p = sized (\n -> try n (2*n)) - where - try m n - | m > n = return Nothing - | otherwise = do - x <- resize m gen - if p x then return (Just x) else try (m+1) n - --- | Randomly uses one of the given generators. The input list --- must be non-empty. -oneof :: [Gen a] -> Gen a -oneof [] = error "QuickCheck.oneof used with empty list" -oneof gs = chooseInt (0,length gs - 1) >>= (gs !!) - --- | Chooses one of the given generators, with a weighted random distribution. --- The input list must be non-empty. -frequency :: [(Int, Gen a)] -> Gen a -frequency [] = error "QuickCheck.frequency used with empty list" -frequency xs - | any (< 0) (map fst xs) = - error "QuickCheck.frequency: negative weight" - | all (== 0) (map fst xs) = - error "QuickCheck.frequency: all weights were zero" -frequency xs0 = chooseInt (1, tot) >>= (`pick` xs0) - where - tot = sum (map fst xs0) - - pick n ((k,x):xs) - | n <= k = x - | otherwise = pick (n-k) xs - pick _ _ = error "QuickCheck.pick used with empty list" - --- | Generates one of the given values. The input list must be non-empty. -elements :: [a] -> Gen a -elements [] = error "QuickCheck.elements used with empty list" -elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) - --- | Generates a random subsequence of the given list. -sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs - --- | Generates a random permutation of the given list. -shuffle :: [a] -> Gen [a] -shuffle xs = do - ns <- vectorOf (length xs) (chooseInt (minBound :: Int, maxBound)) - return (map snd (sortBy (comparing fst) (zip ns xs))) - --- | Takes a list of elements of increasing size, and chooses --- among an initial segment of the list. The size of this initial --- segment increases with the size parameter. --- The input list must be non-empty. -growingElements :: [a] -> Gen a -growingElements [] = error "QuickCheck.growingElements used with empty list" -growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) - where - k = length xs - mx = 100 - log' = round . log . toDouble - size n = (log' n + 1) * k `div` log' mx - toDouble = fromIntegral :: Int -> Double - -{- WAS: -growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) - where - k = length xs --} - --- | Generates a list of random length. The maximum length depends on the --- size parameter. -listOf :: Gen a -> Gen [a] -listOf gen = sized $ \n -> - do k <- chooseInt (0,n) - vectorOf k gen - --- | Generates a non-empty list of random length. The maximum length --- depends on the size parameter. -listOf1 :: Gen a -> Gen [a] -listOf1 gen = sized $ \n -> - do k <- chooseInt (1,1 `max` n) - vectorOf k gen - --- | Generates a list of the given length. -vectorOf :: Int -> Gen a -> Gen [a] -vectorOf = replicateM - --- | Generates an infinite list. -infiniteListOf :: Gen a -> Gen [a] -infiniteListOf gen = sequence (repeat gen) - --------------------------------------------------------------------------- --- the end. 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,531 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Trustworthy #-} -#endif -#ifndef NO_MULTI_PARAM_TYPE_CLASSES -{-# LANGUAGE MultiParamTypeClasses #-} -#endif -#ifndef NO_NEWTYPE_DERIVING -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -#endif -#ifndef NO_TYPEABLE -{-# LANGUAGE DeriveDataTypeable #-} -#endif --- | Modifiers for test data. --- --- These types do things such as restricting the kind of test data that can be generated. --- They can be pattern-matched on in properties as a stylistic --- alternative to using explicit quantification. --- --- __Note__: the contents of this module are re-exported by --- "Test.QuickCheck". You do not need to import it directly. --- --- Examples: --- --- @ --- -- Functions cannot be shown (but see "Test.QuickCheck.Function") --- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = --- takeWhile p xs ++ dropWhile p xs == xs --- @ --- --- @ --- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = --- take n xs ++ drop n xs == xs --- @ --- --- @ --- -- cycle does not work for empty lists --- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = --- take n (cycle xs) == take n (xs ++ cycle xs) --- @ --- --- @ --- -- Instead of 'forAll' 'orderedList' --- prop_Sort ('Ordered' (xs :: ['OrdA'])) = --- sort xs == xs --- @ -module Test.QuickCheck.Modifiers - ( - -- ** Type-level modifiers for changing generator behavior - Blind(..) - , Fixed(..) - , OrderedList(..) - , NonEmptyList(..) - , InfiniteList(..) - , SortedList(..) - , Positive(..) - , Negative(..) - , NonZero(..) - , NonNegative(..) - , NonPositive(..) - , Large(..) - , Small(..) - , Smart(..) - , Shrink2(..) -#ifndef NO_MULTI_PARAM_TYPE_CLASSES - , Shrinking(..) - , ShrinkState(..) -#endif - , ASCIIString(..) - , UnicodeString(..) - , PrintableString(..) - ) - where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Gen -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Exception - -import Data.List - ( sort - ) -import Data.Ix (Ix) - -#ifndef NO_TYPEABLE -import Data.Typeable (Typeable) -#endif - --------------------------------------------------------------------------- --- | @Blind x@: as x, but x does not have to be in the 'Show' class. -newtype Blind a = Blind {getBlind :: a} - deriving ( Eq, Ord -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Blind where - fmap f (Blind x) = Blind (f x) - -instance Show (Blind a) where - show _ = "(*)" - -instance Arbitrary a => Arbitrary (Blind a) where - arbitrary = Blind `fmap` arbitrary - - shrink (Blind x) = [ Blind x' | x' <- shrink x ] - --------------------------------------------------------------------------- --- | @Fixed x@: as x, but will not be shrunk. -newtype Fixed a = Fixed {getFixed :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Fixed where - fmap f (Fixed x) = Fixed (f x) - -instance Arbitrary a => Arbitrary (Fixed a) where - arbitrary = Fixed `fmap` arbitrary - - -- no shrink function - --------------------------------------------------------------------------- --- | @Ordered xs@: guarantees that xs is ordered. -newtype OrderedList a = Ordered {getOrdered :: [a]} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor OrderedList where - fmap f (Ordered x) = Ordered (map f x) - -instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where - arbitrary = Ordered `fmap` orderedList - - shrink (Ordered xs) = - [ Ordered xs' - | xs' <- shrink xs - , sort xs' == xs' - ] - --------------------------------------------------------------------------- --- | @NonEmpty xs@: guarantees that xs is non-empty. -newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor NonEmptyList where - fmap f (NonEmpty x) = NonEmpty (map f x) - -instance Arbitrary a => Arbitrary (NonEmptyList a) where - arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) - - shrink (NonEmpty xs) = - [ NonEmpty xs' - | xs' <- shrink xs - , not (null xs') - ] - ----------------------------------------------------------------------- --- | @InfiniteList xs _@: guarantees that xs is an infinite list. --- When a counterexample is found, only prints the prefix of xs --- that was used by the program. --- --- Here is a contrived example property: --- --- > prop_take_10 :: InfiniteList Char -> Bool --- > prop_take_10 (InfiniteList xs _) = --- > or [ x == 'a' | x <- take 10 xs ] --- --- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but --- the remaining (infinite) part can contain anything: --- --- >>> quickCheck prop_take_10 --- *** Failed! Falsified (after 1 test and 14 shrinks): --- "bbbbbbbbbb" ++ ... -data InfiniteList a = - InfiniteList { - getInfiniteList :: [a], - infiniteListInternalData :: InfiniteListInternalData a } - --- Uses a similar trick to Test.QuickCheck.Function: --- the Arbitrary instance generates an infinite list, which is --- reduced to a finite prefix by shrinking. We use discard to --- check that nothing coming after the finite prefix is used --- (see infiniteListFromData). -data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] - -infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a -infiniteListFromData info@(Infinite xs) = InfiniteList xs info -infiniteListFromData info@(FinitePrefix xs) = - InfiniteList (xs ++ discard) info - -instance Show a => Show (InfiniteList a) where - showsPrec _ (InfiniteList _ (Infinite _)) = - ("" ++) - showsPrec n (InfiniteList _ (FinitePrefix xs)) = - (if n > 10 then ('(':) else id) . - showsPrec 0 xs . - (" ++ ..." ++) . - (if n > 10 then (')':) else id) - -instance Arbitrary a => Arbitrary (InfiniteList a) where - arbitrary = fmap infiniteListFromData arbitrary - shrink (InfiniteList _ info) = - map infiniteListFromData (shrink info) - -instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where - arbitrary = fmap Infinite infiniteList - shrink (Infinite xs) = - [FinitePrefix (take n xs) | n <- map (2^) [0..]] - shrink (FinitePrefix xs) = - map FinitePrefix (shrink xs) - --------------------------------------------------------------------------- --- | @Sorted xs@: guarantees that xs is sorted. -newtype SortedList a = Sorted {getSorted :: [a]} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor SortedList where - fmap f (Sorted x) = Sorted (map f x) - -instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where - arbitrary = fmap (Sorted . sort) arbitrary - - shrink (Sorted xs) = - [ Sorted xs' - | xs' <- map sort (shrink xs) - ] - --------------------------------------------------------------------------- --- | @Positive x@: guarantees that @x \> 0@. -newtype Positive a = Positive {getPositive :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Positive where - fmap f (Positive x) = Positive (f x) - -instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where - arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) - shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] - --------------------------------------------------------------------------- --- | @Negative x@: guarantees that @x \< 0@. -newtype Negative a = Negative {getNegative :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Negative where - fmap f (Negative x) = Negative (f x) - -instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where - arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) - shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] - --------------------------------------------------------------------------- --- | @NonZero x@: guarantees that @x \/= 0@. -newtype NonZero a = NonZero {getNonZero :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor NonZero where - fmap f (NonZero x) = NonZero (f x) - -instance (Num a, Eq a, Arbitrary a) => Arbitrary (NonZero a) where - arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) - - shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] - --------------------------------------------------------------------------- --- | @NonNegative x@: guarantees that @x \>= 0@. -newtype NonNegative a = NonNegative {getNonNegative :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor NonNegative where - fmap f (NonNegative x) = NonNegative (f x) - -instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where - arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0)) - shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] - --------------------------------------------------------------------------- --- | @NonPositive x@: guarantees that @x \<= 0@. -newtype NonPositive a = NonPositive {getNonPositive :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor NonPositive where - fmap f (NonPositive x) = NonPositive (f x) - -instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where - arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0)) - shrink (NonPositive x) = [ NonPositive x' | x' <- shrink x , x' <= 0 ] - --------------------------------------------------------------------------- --- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small --- range. @Large Int@ gives you values drawn from the entire range instead. -newtype Large a = Large {getLarge :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum, Ix -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Large where - fmap f (Large x) = Large (f x) - -instance (Integral a, Bounded a) => Arbitrary (Large a) where - arbitrary = fmap Large arbitrarySizedBoundedIntegral - shrink (Large x) = fmap Large (shrinkIntegral x) - --------------------------------------------------------------------------- --- | @Small x@: generates values of @x@ drawn from a small range. --- The opposite of 'Large'. -newtype Small a = Small {getSmall :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum, Ix -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Small where - fmap f (Small x) = Small (f x) - -instance Integral a => Arbitrary (Small a) where - arbitrary = fmap Small arbitrarySizedIntegral - shrink (Small x) = map Small (shrinkIntegral x) - --------------------------------------------------------------------------- --- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x -newtype Shrink2 a = Shrink2 {getShrink2 :: a} - deriving ( Eq, Ord, Show, Read -#ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum -#endif -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Functor Shrink2 where - fmap f (Shrink2 x) = Shrink2 (f x) - -instance Arbitrary a => Arbitrary (Shrink2 a) where - arbitrary = - Shrink2 `fmap` arbitrary - - shrink (Shrink2 x) = - [ Shrink2 y | y <- shrink_x ] ++ - [ Shrink2 z - | y <- shrink_x - , z <- shrink y - ] - where - shrink_x = shrink x - --------------------------------------------------------------------------- --- | @Smart _ x@: tries a different order when shrinking. -data Smart a = - Smart Int a - -instance Functor Smart where - fmap f (Smart n x) = Smart n (f x) - -instance Show a => Show (Smart a) where - showsPrec n (Smart _ x) = showsPrec n x - -instance Arbitrary a => Arbitrary (Smart a) where - arbitrary = - do x <- arbitrary - return (Smart 0 x) - - shrink (Smart i x) = take i' ys `ilv` drop i' ys - where - ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] - i' = 0 `max` (i-2) - - [] `ilv` bs = bs - as `ilv` [] = as - (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) - -{- - shrink (Smart i x) = part0 ++ part2 ++ part1 - where - ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] - i' = 0 `max` (i-2) - k = i `div` 10 - - part0 = take k ys - part1 = take (i'-k) (drop k ys) - part2 = drop i' ys --} - - -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 - -- take a (take b xs) == take (a `min` b) xs - -- take a xs ++ drop a xs == xs - - -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys - -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) - -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) - -- == take k ys ++ drop k ys - -- == ys - -#ifndef NO_MULTI_PARAM_TYPE_CLASSES --------------------------------------------------------------------------- --- | @Shrinking _ x@: allows for maintaining a state during shrinking. -data Shrinking s a = - Shrinking s a - -class ShrinkState s a where - shrinkInit :: a -> s - shrinkState :: a -> s -> [(a,s)] - -instance Functor (Shrinking s) where - fmap f (Shrinking s x) = Shrinking s (f x) - -instance Show a => Show (Shrinking s a) where - showsPrec n (Shrinking _ x) = showsPrec n x - -instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where - arbitrary = - do x <- arbitrary - return (Shrinking (shrinkInit x) x) - - shrink (Shrinking s x) = - [ Shrinking s' x' - | (x',s') <- shrinkState x s - ] - -#endif /* NO_MULTI_PARAM_TYPE_CLASSES */ - --------------------------------------------------------------------------- --- | @ASCIIString@: generates an ASCII string. -newtype ASCIIString = ASCIIString {getASCIIString :: String} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Arbitrary ASCIIString where - arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar - shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs - --------------------------------------------------------------------------- --- | @UnicodeString@: generates a unicode String. --- The string will not contain surrogate pairs. -newtype UnicodeString = UnicodeString {getUnicodeString :: String} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Arbitrary UnicodeString where - arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar - shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs - --------------------------------------------------------------------------- --- | @PrintableString@: generates a printable unicode String. --- The string will not contain surrogate pairs. -newtype PrintableString = PrintableString {getPrintableString :: String} - deriving ( Eq, Ord, Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - -instance Arbitrary PrintableString where - arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar - shrink (PrintableString xs) = PrintableString `fmap` shrink xs - --- the end. diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs deleted file mode 100644 --- a/Test/QuickCheck/Monadic.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifndef NO_SAFE_HASKELL -#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) -{-# LANGUAGE Trustworthy #-} -#else -{-# LANGUAGE Safe #-} -#endif -#endif -#ifndef NO_ST_MONAD -{-# LANGUAGE Rank2Types #-} -#endif -{-| -Module : Test.QuickCheck.Monadic - -Allows testing of monadic values. Will generally follow this form: - -@ -prop_monadic a b = 'monadicIO' $ do - a\' \<- 'run' (f a) - b\' \<- 'run' (f b) - -- ... - 'assert' someBoolean -@ - -Example using the @FACTOR(1)@ command-line utility: - -@ -import System.Process -import Test.QuickCheck -import Test.QuickCheck.Monadic - --- $ factor 16 --- 16: 2 2 2 2 -factor :: Integer -> IO [Integer] -factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where - - parse :: String -> [Integer] - parse = map read . tail . words - -prop_factor :: Positive Integer -> Property -prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do - factors \<- 'run' (factor n) - - 'assert' (product factors == n) -@ - ->>> quickCheck prop_factor -+++ OK, passed 100 tests. - -See the paper \"\". --} -module Test.QuickCheck.Monadic ( - -- * Property monad - PropertyM(..) - - -- * Monadic specification combinators - , run - , assert - , pre - , wp - , pick - , forAllM - , monitor - , stop - - -- * Run functions - , monadic - , monadic' - , monadicIO -#ifndef NO_ST_MONAD - , monadicST - , runSTGen -#endif - ) where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Gen -import Test.QuickCheck.Gen.Unsafe -import Test.QuickCheck.Property - -import Control.Monad(liftM, liftM2) - -import Control.Monad.ST -import Control.Applicative - -#ifndef NO_TRANSFORMERS -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -#endif - -#ifndef NO_MONADFAIL -import qualified Control.Monad.Fail as Fail -#endif - --------------------------------------------------------------------------- --- type PropertyM - --- | The property monad is really a monad transformer that can contain --- monadic computations in the monad @m@ it is parameterized by: --- --- * @m@ - the @m@-computations that may be performed within @PropertyM@ --- --- Elements of @PropertyM m a@ may mix property operations and @m@-computations. -newtype PropertyM m a = - MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } - -bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b -MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) - -fail_ :: Monad m => String -> PropertyM m a -fail_ s = stop (failed { reason = s }) - -instance Functor (PropertyM m) where - fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) - -instance Applicative (PropertyM m) where - pure x = MkPropertyM (\k -> k x) - mf <*> mx = - mf `bind` \f -> mx `bind` \x -> pure (f x) - -instance Monad m => Monad (PropertyM m) where - return = pure - (>>=) = bind -#if !MIN_VERSION_base(4,13,0) - fail = fail_ -#endif - -#ifndef NO_MONADFAIL -instance Monad m => Fail.MonadFail (PropertyM m) where - fail = fail_ -#endif - -#ifndef NO_TRANSFORMERS -instance MonadTrans PropertyM where - lift = run - -instance MonadIO m => MonadIO (PropertyM m) where - liftIO = run . liftIO -#endif - -stop :: (Testable prop, Monad m) => prop -> PropertyM m a -stop p = MkPropertyM (\_k -> return (return (property p))) - --- should think about strictness/exceptions here --- assert :: Testable prop => prop -> PropertyM m () --- | Allows embedding non-monadic properties into monadic ones. -assert :: Monad m => Bool -> PropertyM m () -assert True = return () -assert False = fail "Assertion failed" - --- should think about strictness/exceptions here --- | Tests preconditions. Unlike 'assert' this does not cause the --- property to fail, rather it discards them just like using the --- implication combinator 'Test.QuickCheck.Property.==>'. --- --- This allows representing the --- --- > {p} x ← e{q} --- --- as --- --- @ --- pre p --- x \<- run e --- assert q --- @ --- -pre :: Monad m => Bool -> PropertyM m () -pre True = return () -pre False = stop rejected - --- should be called lift? --- | The lifting operation of the property monad. Allows embedding --- monadic\/'IO'-actions in properties: --- --- @ --- log :: Int -> IO () --- --- prop_foo n = monadicIO $ do --- run (log n) --- -- ... --- @ -run :: Monad m => m a -> PropertyM m a -run m = MkPropertyM (liftM (m >>=) . promote) - --- | Quantification in a monadic property, fits better with --- /do-notation/ than 'forAllM'. --- __Note__: values generated by 'pick' do not shrink. -pick :: (Monad m, Show a) => Gen a -> PropertyM m a -pick gen = MkPropertyM $ \k -> - do a <- gen - mp <- k a - return (do p <- mp - return (forAll (return a) (const p))) - --- | The --- --- > wp(x ← e, p) --- --- can be expressed as in code as @wp e (\\x -> p)@. -wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b -wp m k = run m >>= k - --- | Quantification in monadic properties to 'pick', with a notation similar to --- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. - -forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b -forAllM gen k = pick gen >>= k - --- | Allows making observations about the test data: --- --- @ --- monitor ('collect' e) --- @ --- --- collects the distribution of value of @e@. --- --- @ --- monitor ('counterexample' "Failure!") --- @ --- --- Adds @"Failure!"@ to the counterexamples. -monitor :: Monad m => (Property -> Property) -> PropertyM m () -monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) - --- run functions - -monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property -monadic runner m = property (fmap runner (monadic' m)) - -monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) -monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) - --- | Runs the property monad for 'IO'-computations. --- --- @ --- prop_cat msg = monadicIO $ do --- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) --- --- pre ('System.Exit.ExitSuccess' == exitCode) --- --- assert (stdout == msg) --- @ --- --- >>> quickCheck prop_cat --- +++ OK, passed 100 tests. --- -monadicIO :: Testable a => PropertyM IO a -> Property -monadicIO = monadic ioProperty - -#ifndef NO_ST_MONAD --- | Runs the property monad for 'ST'-computations. --- --- @ --- -- Your mutable sorting algorithm here --- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) --- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' --- --- prop_sortST xs = monadicST $ do --- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) --- assert ('Data.Vector.toList' sorted == sort xs) --- @ --- --- >>> quickCheck prop_sortST --- +++ OK, passed 100 tests. --- -monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property -monadicST m = property (runSTGen (monadic' m)) - -runSTGen :: (forall s. Gen (ST s a)) -> Gen a -runSTGen f = do - Capture eval <- capture - return (runST (eval f)) -#endif - --------------------------------------------------------------------------- --- the end. 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,973 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | Combinators for constructing properties. -{-# LANGUAGE CPP #-} -#ifndef NO_TYPEABLE -{-# LANGUAGE DeriveDataTypeable #-} -#endif -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} -#endif -module Test.QuickCheck.Property where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Gen -import Test.QuickCheck.Gen.Unsafe -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Text( isOneLine, putLine ) -import Test.QuickCheck.Exception -import Test.QuickCheck.State( State(terminal), Confidence(..) ) - -#ifndef NO_TIMEOUT -import System.Timeout(timeout) -#endif -import Data.Maybe -import Control.Applicative -import Control.Monad -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -#ifndef NO_DEEPSEQ -import Control.DeepSeq -#endif -#ifndef NO_TYPEABLE -import Data.Typeable (Typeable) -#endif -import Data.Maybe - --------------------------------------------------------------------------- --- fixities - -infixr 0 ==> -infixr 1 .&. -infixr 1 .&&. -infixr 1 .||. - --- The story for exception handling: --- --- To avoid insanity, we have rules about which terms can throw --- exceptions when we evaluate them: --- * A rose tree must evaluate to WHNF without throwing an exception --- * The 'ok' component of a Result must evaluate to Just True or --- Just False or Nothing rather than raise an exception --- * IORose _ must never throw an exception when executed --- --- Both rose trees and Results may loop when we evaluate them, though, --- so we have to be careful not to force them unnecessarily. --- --- We also have to be careful when we use fmap or >>= in the Rose --- monad that the function we supply is total, or else use --- protectResults afterwards to install exception handlers. The --- mapResult function on Properties installs an exception handler for --- us, though. --- --- Of course, the user is free to write "error "ha ha" :: Result" if --- they feel like it. We have to make sure that any user-supplied Rose --- Results or Results get wrapped in exception handlers, which we do by: --- * Making the 'property' function install an exception handler --- round its argument. This function always gets called in the --- right places, because all our Property-accepting functions are --- actually polymorphic over the Testable class so they have to --- call 'property'. --- * Installing an exception handler round a Result before we put it --- in a rose tree (the only place Results can end up). - --------------------------------------------------------------------------- --- * Property and Testable types - --- | The type of properties. -newtype Property = MkProperty { unProperty :: Gen Prop } -#ifndef NO_TYPEABLE - deriving (Typeable) -#endif - --- | The class of properties, i.e., types which QuickCheck knows how to test. --- Typically a property will be a function returning 'Bool' or 'Property'. --- --- If a property does no quantification, i.e. has no --- parameters and doesn't use 'forAll', it will only be tested once. --- This may not be what you want if your property is an @IO Bool@. --- You can change this behaviour using the 'again' combinator. -class Testable prop where - -- | Convert the thing to a property. - property :: prop -> Property - - -- | Optional; used internally in order to improve shrinking. - -- Tests a property but also quantifies over an extra value - -- (with a custom shrink and show function). - -- The 'Testable' instance for functions defines - -- @propertyForAllShrinkShow@ in a way that improves shrinking. - propertyForAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property - propertyForAllShrinkShow gen shr shw f = - forAllShrinkBlind gen shr $ - \x -> foldr counterexample (property (f x)) (shw x) - --- | If a property returns 'Discard', the current test case is discarded, --- the same as if a precondition was false. --- --- An example is the definition of '==>': --- --- > (==>) :: Testable prop => Bool -> prop -> Property --- > False ==> _ = property Discard --- > True ==> p = property p -data Discard = Discard - -instance Testable Discard where - property _ = property rejected - --- This instance is here to make it easier to turn IO () into a Property. -instance Testable () where - property = property . liftUnit - where - -- N.B. the unit gets forced only inside 'property', - -- so that we turn exceptions into test failures - liftUnit () = succeeded - -instance Testable prop => Testable (Maybe prop) where - property = property . liftMaybe - where - -- See comment for liftUnit above - liftMaybe Nothing = property Discard - liftMaybe (Just prop) = property prop - -instance Testable Bool where - property = property . liftBool - -instance Testable Result where - property = MkProperty . return . MkProp . protectResults . return - -instance Testable Prop where - property p = MkProperty . return . protectProp $ p - -instance Testable prop => Testable (Gen prop) where - property mp = MkProperty $ do p <- mp; unProperty (again p) - -instance Testable Property where - property (MkProperty mp) = MkProperty (fmap protectProp mp) - --- | Do I/O inside a property. -{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} -morallyDubiousIOProperty :: Testable prop => IO prop -> Property -morallyDubiousIOProperty = ioProperty - --- | Do I/O inside a property. --- --- Warning: any random values generated inside of the argument to @ioProperty@ --- will not currently be shrunk. For best results, generate all random values --- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. --- --- Note: if your property does no quantification, it will only be tested once. --- To test it repeatedly, use 'again'. -ioProperty :: Testable prop => IO prop -> Property -ioProperty prop = idempotentIOProperty (fmap noShrinking prop) - --- | Do I/O inside a property. --- --- Warning: during shrinking, the I/O may not always be re-executed. --- Instead, the I/O may be executed once and then its result retained. --- If this is not acceptable, use 'ioProperty' instead. -idempotentIOProperty :: Testable prop => IO prop -> Property -idempotentIOProperty = - MkProperty . fmap (MkProp . ioRose . fmap unProp) . - promote . fmap (unProperty . property) - -instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where - property f = - propertyForAllShrinkShow arbitrary shrink (return . show) f - propertyForAllShrinkShow gen shr shw f = - -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop - -- Idea: Generate and shrink (b, a) as a pair - propertyForAllShrinkShow - (liftM2 (,) gen arbitrary) - (liftShrink2 shr shrink) - (\(x, y) -> shw x ++ [show y]) - (uncurry f) - --- ** Exception handling -protect :: (AnException -> a) -> IO a -> IO a -protect f x = either f id `fmap` tryEvaluateIO x - --------------------------------------------------------------------------- --- ** Type Prop - -newtype Prop = MkProp{ unProp :: Rose Result } - --- ** type Rose - -data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) --- Only use IORose if you know that the argument is not going to throw an exception! --- Otherwise, try ioRose. -ioRose :: IO (Rose Result) -> Rose Result -ioRose = IORose . protectRose - -joinRose :: Rose (Rose a) -> Rose a -joinRose (IORose rs) = IORose (fmap joinRose rs) -joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) -joinRose (MkRose (MkRose x ts) tts) = - -- first shrinks outer quantification; makes most sense - MkRose x (map joinRose tts ++ ts) - -- first shrinks inner quantification: terrible - --MkRose x (ts ++ map joinRose tts) - -instance Functor Rose where - -- f must be total - fmap f (IORose rs) = IORose (fmap (fmap f) rs) - fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] - -instance Applicative Rose where - pure = return - -- f must be total - (<*>) = liftM2 ($) - -instance Monad Rose where - return x = MkRose x [] - -- k must be total - m >>= k = joinRose (fmap k m) - --- | Execute the "IORose" bits of a rose tree, returning a tree --- constructed by MkRose. -reduceRose :: Rose Result -> IO (Rose Result) -reduceRose r@(MkRose _ _) = return r -reduceRose (IORose m) = m >>= reduceRose - --- | Apply a function to the outermost MkRose constructor of a rose tree. --- The function must be total! -onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a -onRose f (MkRose x rs) = f x rs -onRose f (IORose m) = IORose (fmap (onRose f) m) - --- | Wrap a rose tree in an exception handler. -protectRose :: IO (Rose Result) -> IO (Rose Result) -protectRose = protect (return . exception "Exception") - --- | Wrap the top level of a 'Prop' in an exception handler. -protectProp :: Prop -> Prop -protectProp (MkProp r) = MkProp (IORose . protectRose . return $ r) - --- | Wrap all the Results in a rose tree in exception handlers. -protectResults :: Rose Result -> Rose Result -protectResults = onRose $ \x rs -> - IORose $ do - y <- protectResult (return x) - return (MkRose y (map protectResults rs)) - --- ** Result type - --- | Different kinds of callbacks -data Callback - = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test - | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case -data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator - | NotCounterexample -- ^ Not affected by the 'verbose' combinator - --- | The result of a single test. -data Result - = MkResult - { ok :: Maybe Bool - -- ^ result of the test case; Nothing = discard - , expect :: Bool - -- ^ indicates what the expected result of the property is - , reason :: String - -- ^ a message indicating what went wrong - , theException :: Maybe AnException - -- ^ the exception thrown, if any - , abort :: Bool - -- ^ if True, the test should not be repeated - , maybeNumTests :: Maybe Int - -- ^ stop after this many tests - , maybeCheckCoverage :: Maybe Confidence - -- ^ required coverage confidence - , labels :: [String] - -- ^ test case labels - , classes :: [String] - -- ^ test case classes - , tables :: [(String, String)] - -- ^ test case tables - , requiredCoverage :: [(Maybe String, String, Double)] - -- ^ required coverage - , callbacks :: [Callback] - -- ^ the callbacks for this test case - , testCase :: [String] - -- ^ the generated test case - } - -exception :: String -> AnException -> Result -exception msg err - | isDiscard err = rejected - | otherwise = failed{ reason = formatException msg err, - theException = Just err } - -formatException :: String -> AnException -> String -formatException msg err = msg ++ ":" ++ format (show err) - where format xs | isOneLine xs = " '" ++ xs ++ "'" - | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] - -protectResult :: IO Result -> IO Result -protectResult = protect (exception "Exception") - -succeeded, failed, rejected :: Result -(succeeded, failed, rejected) = - (result{ ok = Just True }, - result{ ok = Just False }, - result{ ok = Nothing }) - where - result = - MkResult - { ok = undefined - , expect = True - , reason = "" - , theException = Nothing - , abort = True - , maybeNumTests = Nothing - , maybeCheckCoverage = Nothing - , labels = [] - , classes = [] - , tables = [] - , requiredCoverage = [] - , callbacks = [] - , testCase = [] - } - --------------------------------------------------------------------------- --- ** Lifting and mapping functions - -liftBool :: Bool -> Result -liftBool True = succeeded -liftBool False = failed { reason = "Falsified" } - -mapResult :: Testable prop => (Result -> Result) -> prop -> Property -mapResult f = mapRoseResult (protectResults . fmap f) - -mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property -mapTotalResult f = mapRoseResult (fmap f) - --- f here mustn't throw an exception (rose tree invariant). -mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property -mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) - -mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property -mapProp f = MkProperty . fmap f . unProperty . property - --------------------------------------------------------------------------- --- ** Property combinators - --- | Adjust the test case size for a property, by transforming it with the given --- function. -mapSize :: Testable prop => (Int -> Int) -> prop -> Property -mapSize f = property . scale f . unProperty . property - --- | Shrinks the argument to a property if it fails. Shrinking is done --- automatically for most types. This function is only needed when you want to --- override the default behavior. -shrinking :: Testable prop => - (a -> [a]) -- ^ 'shrink'-like function. - -> a -- ^ The original argument - -> (a -> prop) -> Property -shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0))) - where - props x = - MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] - --- | Disables shrinking for a property altogether. --- Only quantification /inside/ the call to 'noShrinking' is affected. -noShrinking :: Testable prop => prop -> Property -noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) - --- | Adds a callback -callback :: Testable prop => Callback -> prop -> Property -callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) - --- | Adds the given string to the counterexample if the property fails. -counterexample :: Testable prop => String -> prop -> Property -counterexample s = - mapTotalResult (\res -> res{ testCase = s:testCase res }) . - callback (PostFinalFailure Counterexample $ \st _res -> do - s <- showCounterexample s - putLine (terminal st) s) - -showCounterexample :: String -> IO String -showCounterexample s = do - let force [] = return () - force (x:xs) = x `seq` force xs - res <- tryEvaluateIO (force s) - return $ - case res of - Left err -> - formatException "Exception thrown while showing test case" err - Right () -> - s - --- | Adds the given string to the counterexample if the property fails. -{-# DEPRECATED printTestCase "Use counterexample instead" #-} -printTestCase :: Testable prop => String -> prop -> Property -printTestCase = counterexample - --- | Performs an 'IO' action after the last failure of a property. -whenFail :: Testable prop => IO () -> prop -> Property -whenFail m = - callback $ PostFinalFailure NotCounterexample $ \_st _res -> - m - --- | Performs an 'IO' action every time a property fails. Thus, --- if shrinking is done, this can be used to keep track of the --- failures along the way. -whenFail' :: Testable prop => IO () -> prop -> Property -whenFail' m = - callback $ PostTest NotCounterexample $ \_st res -> - if ok res == Just False - then m - else return () - --- | Prints out the generated testcase every time the property is tested. --- Only variables quantified over /inside/ the 'verbose' are printed. -verbose :: Testable prop => prop -> Property -verbose = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) - where newCallback cbs = - PostTest Counterexample $ \st res -> do - putLine (terminal st) (status res ++ ":") - sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] - putLine (terminal st) "" - status MkResult{ok = Just True} = "Passed" - status MkResult{ok = Just False} = "Failed" - status MkResult{ok = Nothing} = "Skipped (precondition false)" - --- | Prints out the generated testcase every time the property fails, including during shrinking. --- Only variables quantified over /inside/ the 'verboseShrinking' are printed. -verboseShrinking :: Testable prop => prop -> Property -verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) - where newCallback cbs = - PostTest Counterexample $ \st res -> - when (ok res == Just False) $ do - putLine (terminal st) "Failed:" - sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] - putLine (terminal st) "" - --- | Indicates that a property is supposed to fail. --- QuickCheck will report an error if it does not fail. -expectFailure :: Testable prop => prop -> Property -expectFailure = mapTotalResult (\res -> res{ expect = False }) - --- | Modifies a property so that it only will be tested once. --- Opposite of 'again'. -once :: Testable prop => prop -> Property -once = mapTotalResult (\res -> res{ abort = True }) - --- | Modifies a property so that it will be tested repeatedly. --- Opposite of 'once'. -again :: Testable prop => prop -> Property -again = mapTotalResult (\res -> res{ abort = False }) - --- | Configures how many times a property will be tested. --- --- For example, --- --- > quickCheck (withMaxSuccess 1000 p) --- --- will test @p@ up to 1000 times. -withMaxSuccess :: Testable prop => Int -> prop -> Property -withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) - --- | Check that all coverage requirements defined by 'cover' and 'coverTable' --- are met, using a statistically sound test, and fail if they are not met. --- --- Ordinarily, a failed coverage check does not cause the property to fail. --- This is because the coverage requirement is not tested in a statistically --- sound way. If you use 'cover' to express that a certain value must appear 20% --- of the time, QuickCheck will warn you if the value only appears in 19 out of --- 100 test cases - but since the coverage varies randomly, you may have just --- been unlucky, and there may not be any real problem with your test --- generation. --- --- When you use 'checkCoverage', QuickCheck uses a statistical test to account --- for the role of luck in coverage failures. It will run as many tests as --- needed until it is sure about whether the coverage requirements are met. If a --- coverage requirement is not met, the property fails. --- --- Example: --- --- > quickCheck (checkCoverage prop_foo) -checkCoverage :: Testable prop => prop -> Property -checkCoverage = checkCoverageWith stdConfidence - --- | Check coverage requirements using a custom confidence level. --- See 'stdConfidence'. --- --- An example of making the statistical test less stringent in order to improve --- performance: --- --- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo) -checkCoverageWith :: Testable prop => Confidence -> prop -> Property -checkCoverageWith confidence = - certainty confidence `seq` - tolerance confidence `seq` - mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence }) - --- | The standard parameters used by 'checkCoverage': @certainty = 10^9@, --- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters. -stdConfidence :: Confidence -stdConfidence = - Confidence { - certainty = 10^9, - tolerance = 0.9 } - --- | Attaches a label to a test case. This is used for reporting --- test case distribution. --- --- For example: --- --- > prop_reverse_reverse :: [Int] -> Property --- > prop_reverse_reverse xs = --- > label ("length of input is " ++ show (length xs)) $ --- > reverse (reverse xs) === xs --- --- >>> quickCheck prop_reverse_reverse --- +++ OK, passed 100 tests: --- 7% length of input is 7 --- 6% length of input is 3 --- 5% length of input is 4 --- 4% length of input is 6 --- ... --- --- Each use of 'label' in your property results in a separate --- table of test case distribution in the output. If this is --- not what you want, use 'tabulate'. -label :: Testable prop => String -> prop -> Property -label s = -#ifndef NO_DEEPSEQ - s `deepseq` -#endif - mapTotalResult $ - \res -> res { labels = s:labels res } - --- | Attaches a label to a test case. This is used for reporting --- test case distribution. --- --- > collect x = label (show x) --- --- For example: --- --- > prop_reverse_reverse :: [Int] -> Property --- > prop_reverse_reverse xs = --- > collect (length xs) $ --- > reverse (reverse xs) === xs --- --- >>> quickCheck prop_reverse_reverse --- +++ OK, passed 100 tests: --- 7% 7 --- 6% 3 --- 5% 4 --- 4% 6 --- ... --- --- Each use of 'collect' in your property results in a separate --- table of test case distribution in the output. If this is --- not what you want, use 'tabulate'. -collect :: (Show a, Testable prop) => a -> prop -> Property -collect x = label (show x) - --- | Reports how many test cases satisfy a given condition. --- --- For example: --- --- > prop_sorted_sort :: [Int] -> Property --- > prop_sorted_sort xs = --- > sorted xs ==> --- > classify (length xs > 1) "non-trivial" $ --- > sort xs === xs --- --- >>> quickCheck prop_sorted_sort --- +++ OK, passed 100 tests (22% non-trivial). -classify :: Testable prop => - Bool -- ^ @True@ if the test case should be labelled. - -> String -- ^ Label. - -> prop -> Property -classify False _ = property -classify True s = -#ifndef NO_DEEPSEQ - s `deepseq` -#endif - mapTotalResult $ - \res -> res { classes = s:classes res } - --- | Checks that at least the given proportion of /successful/ test --- cases belong to the given class. Discarded tests (i.e. ones --- with a false precondition) do not affect coverage. --- --- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but --- the property does /not/ fail. To make the property fail, use 'checkCoverage'. --- --- For example: --- --- > prop_sorted_sort :: [Int] -> Property --- > prop_sorted_sort xs = --- > sorted xs ==> --- > cover 50 (length xs > 1) "non-trivial" $ --- > sort xs === xs --- --- >>> quickCheck prop_sorted_sort --- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). --- --- Only 26% non-trivial, but expected 50% -cover :: Testable prop => - Double -- ^ The required percentage (0-100) of test cases. - -> Bool -- ^ @True@ if the test case belongs to the class. - -> String -- ^ Label for the test case class. - -> prop -> Property -cover p x s = mapTotalResult f . classify x s - where - f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res } - --- | Collects information about test case distribution into a table. --- The arguments to 'tabulate' are the table's name and a list of values --- associated with the current test case. After testing, QuickCheck prints the --- frequency of all collected values. The frequencies are expressed as a --- percentage of the total number of values collected. --- --- You should prefer 'tabulate' to 'label' when each test case is associated --- with a varying number of values. Here is a (not terribly useful) example, --- where the test data is a list of integers and we record all values that --- occur in the list: --- --- > prop_sorted_sort :: [Int] -> Property --- > prop_sorted_sort xs = --- > sorted xs ==> --- > tabulate "List elements" (map show xs) $ --- > sort xs === xs --- --- >>> quickCheck prop_sorted_sort --- +++ OK, passed 100 tests; 1684 discarded. --- --- List elements (109 in total): --- 3.7% 0 --- 3.7% 17 --- 3.7% 2 --- 3.7% 6 --- 2.8% -6 --- 2.8% -7 --- --- Here is a more useful example. We are testing a chatroom, where the user can --- log in, log out, or send a message: --- --- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) --- > instance Arbitrary Command where ... --- --- There are some restrictions on command sequences; for example, the user must --- log in before doing anything else. The function @valid :: [Command] -> Bool@ --- checks that a command sequence is allowed. Our property then has the form: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > valid cmds ==> --- > ... --- --- The use of '==>' may skew test case distribution. We use 'collect' to see the --- length of the command sequences, and 'tabulate' to get the frequencies of the --- individual commands: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > 'collect' (length cmds) $ --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... --- --- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom --- +++ OK, passed 100 tests; 2775 discarded: --- 60% 0 --- 20% 1 --- 15% 2 --- 3% 3 --- 1% 4 --- 1% 5 --- --- Commands (68 in total): --- 62% LogIn --- 22% SendMessage --- 16% LogOut -tabulate :: Testable prop => String -> [String] -> prop -> Property -tabulate key values = -#ifndef NO_DEEPSEQ - key `deepseq` values `deepseq` -#endif - mapTotalResult $ - \res -> res { tables = [(key, value) | value <- values] ++ tables res } - --- | Checks that the values in a given 'table' appear a certain proportion of --- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts --- that of the values in @table@, @x1@ should appear at least @p1@ percent of --- the time, @x2@ at least @p2@ percent of the time, and so on. --- --- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but --- the property does /not/ fail. To make the property fail, use 'checkCoverage'. --- --- Continuing the example from the 'tabular' combinator... --- --- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... --- --- ...we can add a coverage requirement as follows, which checks that @LogIn@, --- @LogOut@ and @SendMessage@ each occur at least 25% of the time: --- --- > prop_chatroom :: [Command] -> Property --- > prop_chatroom cmds = --- > wellFormed cmds LoggedOut ==> --- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ --- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ --- > ... property goes here ... --- --- >>> quickCheck prop_chatroom --- +++ OK, passed 100 tests; 2909 discarded: --- 56% 0 --- 17% 1 --- 10% 2 --- 6% 3 --- 5% 4 --- 3% 5 --- 3% 7 --- --- Commands (111 in total): --- 51.4% LogIn --- 30.6% SendMessage --- 18.0% LogOut --- --- Table 'Commands' had only 18.0% LogOut, but expected 25.0% -coverTable :: Testable prop => - String -> [(String, Double)] -> prop -> Property -coverTable table xs = -#ifndef NO_DEEPSEQ - table `deepseq` xs `deepseq` -#endif - mapTotalResult $ - \res -> res { requiredCoverage = ys ++ requiredCoverage res } - where - ys = [(Just table, x, p/100) | (x, p) <- xs] - --- | Implication for properties: The resulting property holds if --- the first argument is 'False' (in which case the test case is discarded), --- or if the given property holds. Note that using implication carelessly can --- severely skew test case distribution: consider using 'cover' to make sure --- that your test data is still good quality. -(==>) :: Testable prop => Bool -> prop -> Property -False ==> _ = property Discard -True ==> p = property p - --- | Considers a property failed if it does not complete within --- the given number of microseconds. --- --- Note: if the property times out, variables quantified inside the --- `within` will not be printed. Therefore, you should use `within` --- only in the body of your property. --- --- Good: @prop_foo a b c = within 1000000 ...@ --- --- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@ --- --- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@ -within :: Testable prop => Int -> prop -> Property -within n = mapRoseResult f - where - f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe x) m - MkRose res roses <- timeout n (reduceRose rose) `orError` - return timeoutResult - res' <- timeout n (protectResult (return res)) `orError` - timeoutResult - return (MkRose res' (map f roses)) - - timeoutResult = failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." } -#ifdef NO_TIMEOUT - timeout _ = fmap Just -#endif - --- | Explicit universal quantification: uses an explicitly given --- test case generator. -forAll :: (Show a, Testable prop) - => Gen a -> (a -> prop) -> Property -forAll gen pf = forAllShrink gen (\_ -> []) pf - --- | Like 'forAll', but with an explicitly given show function. -forAllShow :: Testable prop - => Gen a -> (a -> String) -> (a -> prop) -> Property -forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf - --- | Like 'forAll', but without printing the generated value. -forAllBlind :: Testable prop - => Gen a -> (a -> prop) -> Property -forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf - --- | Like 'forAll', but tries to shrink the argument for failing test cases. -forAllShrink :: (Show a, Testable prop) - => Gen a -> (a -> [a]) -> (a -> prop) -> Property -forAllShrink gen shrinker = forAllShrinkShow gen shrinker show - --- | Like 'forAllShrink', but with an explicitly given show function. -forAllShrinkShow - :: Testable prop - => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property -forAllShrinkShow gen shrinker shower pf = - forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x)) - --- | Like 'forAllShrink', but without printing the generated value. -forAllShrinkBlind - :: Testable prop - => Gen a -> (a -> [a]) -> (a -> prop) -> Property -forAllShrinkBlind gen shrinker pf = - again $ - MkProperty $ - gen >>= \x -> - unProperty $ - shrinking shrinker x pf - --- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of --- 'p1' and 'p2' to test. If you test the property 100 times it --- makes 100 random choices. -(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .&. p2 = - again $ - MkProperty $ - arbitrary >>= \b -> - unProperty $ - counterexample (if b then "LHS" else "RHS") $ - if b then property p1 else property p2 - --- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. -(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .&&. p2 = conjoin [property p1, property p2] - --- | Take the conjunction of several properties. -conjoin :: Testable prop => [prop] -> Property -conjoin ps = - again $ - MkProperty $ - do roses <- mapM (fmap unProp . unProperty . property) ps - return (MkProp (conj id roses)) - where - conj k [] = - MkRose (k succeeded) [] - - conj k (p : ps) = IORose $ do - rose@(MkRose result _) <- reduceRose p - case ok result of - _ | not (expect result) -> - return (return failed { reason = "expectFailure may not occur inside a conjunction" }) - Just True -> return (conj (addLabels result . addCallbacksAndCoverage result . k) ps) - Just False -> return rose - Nothing -> do - rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage result . k) ps) - return $ - -- Nasty work to make sure we use the right callbacks - case ok result2 of - Just True -> MkRose (result2 { ok = Nothing }) [] - Just False -> rose2 - Nothing -> rose2 - - addCallbacksAndCoverage result r = - r { callbacks = callbacks result ++ callbacks r, - requiredCoverage = requiredCoverage result ++ requiredCoverage r } - addLabels result r = - r { labels = labels result ++ labels r, - classes = classes result ++ classes r, - tables = tables result ++ tables r } - --- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. -(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property -p1 .||. p2 = disjoin [property p1, property p2] - --- | Take the disjunction of several properties. -disjoin :: Testable prop => [prop] -> Property -disjoin ps = - again $ - MkProperty $ - do roses <- mapM (fmap unProp . unProperty . property) ps - return (MkProp (foldr disj (MkRose failed []) roses)) - where - disj :: Rose Result -> Rose Result -> Rose Result - disj p q = - do result1 <- p - case ok result1 of - _ | not (expect result1) -> return expectFailureError - Just False -> do - result2 <- q - return $ - case ok result2 of - _ | not (expect result2) -> expectFailureError - Just True -> addCoverage result1 result2 - Just False -> - MkResult { - ok = Just False, - expect = True, - reason = sep (reason result1) (reason result2), - theException = theException result1 `mplus` theException result2, - -- The following few fields are not important because the - -- test case has failed anyway - abort = False, - maybeNumTests = Nothing, - maybeCheckCoverage = Nothing, - labels = [], - classes = [], - tables = [], - requiredCoverage = [], - callbacks = - callbacks result1 ++ - [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ - callbacks result2, - testCase = - testCase result1 ++ - testCase result2 } - Nothing -> result2 - -- The "obvious" semantics of .||. has: - -- discard .||. true = true - -- discard .||. discard = discard - -- but this implementation gives discard .||. true = discard. - -- This is reasonable because evaluating result2 in the case - -- that result1 discards is just busy-work - it won't ever - -- cause the property to fail. On the other hand, discarding - -- instead of returning true causes us to execute one more - -- test case - but assuming that preconditions are cheap to - -- evaluate, this is no more work than evaluating result2 - -- would be, while (unlike evaluating result2) it might catch - -- a bug. - _ -> return result1 - - expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } - sep [] s = s - sep s [] = s - sep s s' = s ++ ", " ++ s' - - addCoverage result r = - r { requiredCoverage = requiredCoverage result ++ requiredCoverage r } - --- | Like '==', but prints a counterexample when it fails. -infix 4 === -(===) :: (Eq a, Show a) => a -> a -> Property -x === y = - counterexample (show x ++ interpret res ++ show y) res - where - res = x == y - interpret True = " == " - interpret False = " /= " - --- | Like '/=', but prints a counterexample when it fails. -infix 4 =/= -(=/=) :: (Eq a, Show a) => a -> a -> Property -x =/= y = - counterexample (show x ++ interpret res ++ show y) res - where - res = x /= y - interpret True = " /= " - interpret False = " == " - -#ifndef NO_DEEPSEQ --- | Checks that a value is total, i.e., doesn't crash when evaluated. -total :: NFData a => a -> Property -total x = property (rnf x) -#endif - --------------------------------------------------------------------------- --- the end. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs deleted file mode 100644 --- a/Test/QuickCheck/Random.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | A wrapper around the system random number generator. Internal QuickCheck module. -{-# LANGUAGE CPP #-} -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Trustworthy #-} -#endif -module Test.QuickCheck.Random where - -import System.Random -#ifndef NO_SPLITMIX -import System.Random.SplitMix -#endif -import Data.Bits - --- | The "standard" QuickCheck random number generator. --- A wrapper around either 'SMGen' on GHC, or 'StdGen' --- on other Haskell systems. -#ifdef NO_SPLITMIX -newtype QCGen = QCGen StdGen -#else -newtype QCGen = QCGen SMGen -#endif - -instance Show QCGen where - showsPrec n (QCGen g) s = showsPrec n g s -instance Read QCGen where - readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] - -instance RandomGen QCGen where - split (QCGen g) = - case split g of - (g1, g2) -> (QCGen g1, QCGen g2) - genRange (QCGen g) = genRange g - next (QCGen g) = - case next g of - (x, g') -> (x, QCGen g') - -newQCGen :: IO QCGen -#ifdef NO_SPLITMIX -newQCGen = fmap QCGen newStdGen -#else -newQCGen = fmap QCGen newSMGen -#endif - -mkQCGen :: Int -> QCGen -#ifdef NO_SPLITMIX -mkQCGen n = QCGen (mkStdGen n) -#else -mkQCGen n = QCGen (mkSMGen (fromIntegral n)) -#endif - --- Parameterised in order to make this code testable. -class Splittable a where - left, right :: a -> a - -instance Splittable QCGen where - left = fst . split - right = snd . split - --- The logic behind 'variant'. Given a random number seed, and an integer, uses --- splitting to transform the seed according to the integer. We use a --- prefix-free code so that calls to integerVariant n g for different values of --- n are guaranteed to return independent seeds. -{-# INLINE integerVariant #-} -integerVariant :: Splittable a => Integer -> a -> a -integerVariant n g - -- Use one bit to encode the sign, then use Elias gamma coding - -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest. - -- Actually, the first bit encodes whether n >= 1 or not; - -- this has the advantage that both 0 and 1 get short codes. - | n >= 1 = gamma n $! left g - | otherwise = gamma (1-n) $! right g - where - gamma n = - encode k . zeroes k - where - k = ilog2 n - - encode (-1) g = g - encode k g - | testBit n k = - encode (k-1) $! right g - | otherwise = - encode (k-1) $! left g - - zeroes 0 g = g - zeroes k g = zeroes (k-1) $! left g - - ilog2 1 = 0 - ilog2 n = 1 + ilog2 (n `div` 2) 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,683 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- | The main test loop. -{-# LANGUAGE CPP #-} -#ifndef NO_TYPEABLE -{-# LANGUAGE DeriveDataTypeable #-} -#endif -#ifndef NO_SAFE_HASKELL -{-# LANGUAGE Trustworthy #-} -#endif -module Test.QuickCheck.Test where - --------------------------------------------------------------------------- --- imports - -import Test.QuickCheck.Gen -import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) -import qualified Test.QuickCheck.Property as P -import Test.QuickCheck.Text -import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) -import qualified Test.QuickCheck.State as S -import Test.QuickCheck.Exception -import Test.QuickCheck.Random -import System.Random(split) -#if defined(MIN_VERSION_containers) -#if MIN_VERSION_containers(0,5,0) -import qualified Data.Map.Strict as Map -#else -import qualified Data.Map as Map -#endif -#else -import qualified Data.Map as Map -#endif -import qualified Data.Set as Set -import Data.Set(Set) -import Data.Map(Map) - -import Data.Char - ( isSpace - ) - -import Data.List - ( sort - , sortBy - , group - , intersperse - ) - -import Data.Maybe(fromMaybe, isNothing, catMaybes) -import Data.Ord(comparing) -import Text.Printf(printf) -import Control.Monad -import Data.Bits - -#ifndef NO_TYPEABLE -import Data.Typeable (Typeable) -#endif - --------------------------------------------------------------------------- --- quickCheck - --- * Running tests - --- | Args specifies arguments to the QuickCheck driver -data Args - = Args - { replay :: Maybe (QCGen,Int) - -- ^ Should we replay a previous test? - -- Note: saving a seed from one version of QuickCheck and - -- replaying it in another is not supported. - -- If you want to store a test case permanently you should save - -- the test case itself. - , maxSuccess :: Int - -- ^ Maximum number of successful tests before succeeding. Testing stops - -- at the first failure. If all tests are passing and you want to run more tests, - -- increase this number. - , maxDiscardRatio :: Int - -- ^ Maximum number of discarded tests per successful test before giving up - , maxSize :: Int - -- ^ Size to use for the biggest test cases - , chatty :: Bool - -- ^ Whether to print anything - , maxShrinks :: Int - -- ^ Maximum number of shrinks to before giving up. Setting this to zero - -- turns shrinking off. - } - deriving ( Show, Read -#ifndef NO_TYPEABLE - , Typeable -#endif - ) - --- | Result represents the test result -data Result - -- | A successful test run - = Success - { numTests :: Int - -- ^ Number of tests performed - , numDiscarded :: Int - -- ^ Number of tests skipped - , labels :: !(Map [String] Int) - -- ^ The number of test cases having each combination of labels (see 'label') - , classes :: !(Map String Int) - -- ^ The number of test cases having each class (see 'classify') - , tables :: !(Map String (Map String Int)) - -- ^ Data collected by 'tabulate' - , output :: String - -- ^ Printed output - } - -- | Given up - | GaveUp - { numTests :: Int - , numDiscarded :: Int - -- ^ Number of tests skipped - , labels :: !(Map [String] Int) - , classes :: !(Map String Int) - , tables :: !(Map String (Map String Int)) - , output :: String - } - -- | A failed test run - | Failure - { numTests :: Int - , numDiscarded :: Int - -- ^ Number of tests skipped - , numShrinks :: Int - -- ^ Number of successful shrinking steps performed - , numShrinkTries :: Int - -- ^ Number of unsuccessful shrinking steps performed - , numShrinkFinal :: Int - -- ^ Number of unsuccessful shrinking steps performed since last successful shrink - , usedSeed :: QCGen - -- ^ What seed was used - , usedSize :: Int - -- ^ What was the test size - , reason :: String - -- ^ Why did the property fail - , theException :: Maybe AnException - -- ^ The exception the property threw, if any - , output :: String - , failingTestCase :: [String] - -- ^ The test case which provoked the failure - , failingLabels :: [String] - -- ^ The test case's labels (see 'label') - , failingClasses :: Set String - -- ^ The test case's classes (see 'classify') - } - -- | A property that should have failed did not - | NoExpectedFailure - { numTests :: Int - , numDiscarded :: Int - -- ^ Number of tests skipped - , labels :: !(Map [String] Int) - , classes :: !(Map String Int) - , tables :: !(Map String (Map String Int)) - , output :: String - } - deriving ( Show ) - --- | Check if the test run result was a success -isSuccess :: Result -> Bool -isSuccess Success{} = True -isSuccess _ = False - --- | The default test arguments -stdArgs :: Args -stdArgs = Args - { replay = Nothing - , maxSuccess = 100 - , maxDiscardRatio = 10 - , maxSize = 100 - , chatty = True - , maxShrinks = maxBound - } - --- | Tests a property and prints the results to 'stdout'. --- --- By default up to 100 tests are performed, which may not be enough --- to find all bugs. To run more tests, use 'withMaxSuccess'. --- --- If you want to get the counterexample as a Haskell value, --- rather than just printing it, try the --- --- package. - -quickCheck :: Testable prop => prop -> IO () -quickCheck p = quickCheckWith stdArgs p - --- | Tests a property, using test arguments, and prints the results to 'stdout'. -quickCheckWith :: Testable prop => Args -> prop -> IO () -quickCheckWith args p = quickCheckWithResult args p >> return () - --- | Tests a property, produces a test result, and prints the results to 'stdout'. -quickCheckResult :: Testable prop => prop -> IO Result -quickCheckResult p = quickCheckWithResult stdArgs p - --- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. -quickCheckWithResult :: Testable prop => Args -> prop -> IO Result -quickCheckWithResult a p = - withState a (\s -> test s (property p)) - -withState :: Args -> (State -> IO a) -> IO a -withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do - rnd <- case replay a of - Nothing -> newQCGen - Just (rnd,_) -> return rnd - test MkState{ terminal = tm - , maxSuccessTests = maxSuccess a - , coverageConfidence = Nothing - , maxDiscardedRatio = maxDiscardRatio a - , computeSize = case replay a of - Nothing -> computeSize' - Just (_,s) -> computeSize' `at0` s - , numTotMaxShrinks = maxShrinks a - , numSuccessTests = 0 - , numDiscardedTests = 0 - , numRecentlyDiscardedTests = 0 - , S.labels = Map.empty - , S.classes = Map.empty - , S.tables = Map.empty - , S.requiredCoverage = Map.empty - , expected = True - , randomSeed = rnd - , numSuccessShrinks = 0 - , numTryShrinks = 0 - , numTotTryShrinks = 0 - } - where computeSize' n d - -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: - -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. - | n `roundTo` maxSize a + maxSize a <= maxSuccess a || - n >= maxSuccess a || - maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a - | otherwise = - ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a - n `roundTo` m = (n `div` m) * m - at0 f s 0 0 = s - at0 f s n d = f n d - --- | Tests a property and prints the results and all test cases generated to 'stdout'. --- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. -verboseCheck :: Testable prop => prop -> IO () -verboseCheck p = quickCheck (verbose p) - --- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. --- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. -verboseCheckWith :: Testable prop => Args -> prop -> IO () -verboseCheckWith args p = quickCheckWith args (verbose p) - --- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. --- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. -verboseCheckResult :: Testable prop => prop -> IO Result -verboseCheckResult p = quickCheckResult (verbose p) - --- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. --- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. -verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result -verboseCheckWithResult a p = quickCheckWithResult a (verbose p) - --------------------------------------------------------------------------- --- main test loop - -test :: State -> Property -> IO Result -test st f - | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = - doneTesting st f - | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = - giveUp st f - | otherwise = - runATest st f - -doneTesting :: State -> Property -> IO Result -doneTesting st _f - | expected st == False = do - putPart (terminal st) - ( bold ("*** Failed!") - ++ " Passed " - ++ showTestCount st - ++ " (expected failure)" - ) - finished NoExpectedFailure - | otherwise = do - putPart (terminal st) - ( "+++ OK, passed " - ++ showTestCount st - ) - finished Success - where - finished k = do - success st - theOutput <- terminalOutput (terminal st) - return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) - -giveUp :: State -> Property -> IO Result -giveUp st _f = - do -- CALLBACK gave_up? - putPart (terminal st) - ( bold ("*** Gave up!") - ++ " Passed only " - ++ showTestCount st - ++ " tests" - ) - success st - theOutput <- terminalOutput (terminal st) - return GaveUp{ numTests = numSuccessTests st - , numDiscarded = numDiscardedTests st - , labels = S.labels st - , classes = S.classes st - , tables = S.tables st - , output = theOutput - } - -showTestCount :: State -> String -showTestCount st = - number (numSuccessTests st) "test" - ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" - | numDiscardedTests st > 0 - ] - -runATest :: State -> Property -> IO Result -runATest st f = - do -- CALLBACK before_test - putTemp (terminal st) - ( "(" - ++ showTestCount st - ++ ")" - ) - let powerOfTwo n = n .&. (n - 1) == 0 - let f_or_cov = - case coverageConfidence st of - Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> - addCoverageCheck confidence st f - _ -> f - let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) - MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) - res <- callbackPostTest st res - - let continue break st' | abort res = break st' - | otherwise = test st' - - let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st - , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) - , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) - , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) - , S.tables = - foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) - (S.tables st) (P.tables res) - , S.requiredCoverage = - foldr (\(key, value, p) -> Map.insertWith max (key, value) p) - (S.requiredCoverage st) (P.requiredCoverage res) - , expected = expect res } - - case res of - MkResult{ok = Just True} -> -- successful test - do continue doneTesting - st'{ numSuccessTests = numSuccessTests st' + 1 - , numRecentlyDiscardedTests = 0 - , randomSeed = rnd2 - } f - - MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test - do continue giveUp - -- Don't add coverage info from this test - st{ numDiscardedTests = numDiscardedTests st' + 1 - , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 - , randomSeed = rnd2 - } f - - MkResult{ok = Just False} -> -- failed test - do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts - theOutput <- terminalOutput (terminal st') - if not (expect res) then - return Success{ labels = S.labels st', - classes = S.classes st', - tables = S.tables st', - numTests = numSuccessTests st'+1, - numDiscarded = numDiscardedTests st', - output = theOutput } - else do - testCase <- mapM showCounterexample (P.testCase res) - return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) - , usedSize = size - , numTests = numSuccessTests st'+1 - , numDiscarded = numDiscardedTests st' - , numShrinks = numShrinks - , numShrinkTries = totFailed - , numShrinkFinal = lastFailed - , output = theOutput - , reason = P.reason res - , theException = P.theException res - , failingTestCase = testCase - , failingLabels = P.labels res - , failingClasses = Set.fromList (P.classes res) - } - where - (rnd1,rnd2) = split (randomSeed st) - -failureSummary :: State -> P.Result -> String -failureSummary st res = fst (failureSummaryAndReason st res) - -failureReason :: State -> P.Result -> [String] -failureReason st res = snd (failureSummaryAndReason st res) - -failureSummaryAndReason :: State -> P.Result -> (String, [String]) -failureSummaryAndReason st res = (summary, full) - where - summary = - header ++ - short 26 (oneLine theReason ++ " ") ++ - count True ++ "..." - - full = - (header ++ - (if isOneLine theReason then theReason ++ " " else "") ++ - count False ++ ":"): - if isOneLine theReason then [] else lines theReason - - theReason = P.reason res - - header = - if expect res then - bold "*** Failed! " - else "+++ OK, failed as expected. " - - count full = - "(after " ++ number (numSuccessTests st+1) "test" ++ - concat [ - " and " ++ - show (numSuccessShrinks st) ++ - concat [ "." ++ show (numTryShrinks st) | showNumTryShrinks ] ++ - " shrink" ++ - (if numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s") - | numSuccessShrinks st > 0 || showNumTryShrinks ] ++ - ")" - where - showNumTryShrinks = full && numTryShrinks st > 0 - -success :: State -> IO () -success st = do - mapM_ (putLine $ terminal st) (paragraphs [short, long]) - where - (short, long) = - case labelsAndTables st of - ([msg], long) -> - ([" (" ++ dropWhile isSpace msg ++ ")."], long) - ([], long) -> - (["."], long) - (short, long) -> - (":":short, long) - -labelsAndTables :: State -> ([String], [String]) -labelsAndTables st = (theLabels, theTables) - where - theLabels :: [String] - theLabels = - paragraphs $ - [ showTable (numSuccessTests st) Nothing m - | m <- S.classes st:Map.elems numberedLabels ] - - numberedLabels :: Map Int (Map String Int) - numberedLabels = - Map.fromListWith (Map.unionWith (+)) $ - [ (i, Map.singleton l n) - | (labels, n) <- Map.toList (S.labels st), - (i, l) <- zip [0..] labels ] - - theTables :: [String] - theTables = - paragraphs $ - [ showTable (sum (Map.elems m)) (Just table) m - | (table, m) <- Map.toList (S.tables st) ] ++ - [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ") - ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot - | (mtable, label, tot, n, p) <- allCoverage st, - insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] - -showTable :: Int -> Maybe String -> Map String Int -> [String] -showTable k mtable m = - [table ++ " " ++ total ++ ":" | Just table <- [mtable]] ++ - (map format . - -- Descending order of occurrences - reverse . sortBy (comparing snd) . - -- If #occurences the same, sort in increasing order of key - -- (note: works because sortBy is stable) - reverse . sortBy (comparing fst) $ Map.toList m) - where - format (key, v) = - rpercent v k ++ " " ++ key - - total = printf "(%d in total)" k - --------------------------------------------------------------------------- --- main shrinking loop - -foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) -foundFailure st res ts = - do localMin st{ numTryShrinks = 0 } res ts - -localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) --- Don't try to shrink for too long -localMin st res ts - | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = - localMinFound st res -localMin st res ts = do - r <- tryEvaluateIO $ - putTemp (terminal st) (failureSummary st res) - case r of - Left err -> - localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } - Right () -> do - r <- tryEvaluate ts - case r of - Left err -> - localMinFound st - (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } - Right ts' -> localMin' st res ts' - -localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) -localMin' st res [] = localMinFound st res -localMin' st res (t:ts) = - do -- CALLBACK before_test - MkRose res' ts' <- protectRose (reduceRose t) - res' <- callbackPostTest st res' - if ok res' == Just False - then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, - numTryShrinks = 0 } res' ts' - else localMin st{ numTryShrinks = numTryShrinks st + 1, - numTotTryShrinks = numTotTryShrinks st + 1 } res ts - -localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) -localMinFound st res = - do sequence_ [ putLine (terminal st) msg | msg <- failureReason st res ] - callbackPostFinalFailure st res - -- NB no need to check if callbacks threw an exception because - -- we are about to return to the user anyway - return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res) - --------------------------------------------------------------------------- --- callbacks - -callbackPostTest :: State -> P.Result -> IO P.Result -callbackPostTest st res = protect (exception "Exception running callback") $ do - sequence_ [ f st res | PostTest _ f <- callbacks res ] - return res - -callbackPostFinalFailure :: State -> P.Result -> IO () -callbackPostFinalFailure st res = do - x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ] - case x of - Left err -> do - putLine (terminal st) "*** Exception running callback: " - tryEvaluateIO $ putLine (terminal st) (show err) - return () - Right () -> return () - ----------------------------------------------------------------------- --- computing coverage - -sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool -sufficientlyCovered confidence n k p = - -- Accept the coverage if, with high confidence, the actual probability is - -- at least 0.9 times the required one. - wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p - where - err = certainty confidence - tol = tolerance confidence - -insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool -insufficientlyCovered Nothing n k p = - fromIntegral k < p * fromIntegral n -insufficientlyCovered (Just err) n k p = - wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p - --- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval --- Note: --- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf --- suggests we should use a instead of a/2 for a one-sided test. Look --- into this. -wilson :: Integer -> Integer -> Double -> Double -wilson k n z = - (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf) - where - nf = fromIntegral n - p = fromIntegral k / fromIntegral n - -wilsonLow :: Integer -> Integer -> Double -> Double -wilsonLow k n a = wilson k n (invnormcdf (a/2)) - -wilsonHigh :: Integer -> Integer -> Double -> Double -wilsonHigh k n a = wilson k n (invnormcdf (1-a/2)) - --- Algorithm taken from --- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/ --- Accurate to about one part in 10^9. --- --- The 'erf' package uses the same algorithm, but with an extra step --- to get a fully accurate result, which we skip because it requires --- the 'erfc' function. -invnormcdf :: Double -> Double -invnormcdf p - | p < 0 = 0/0 - | p > 1 = 0/0 - | p == 0 = -1/0 - | p == 1 = 1/0 - | p < p_low = - let - q = sqrt(-2*log(p)) - in - (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / - ((((d1*q+d2)*q+d3)*q+d4)*q+1) - | p <= p_high = - let - q = p - 0.5 - r = q*q - in - (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q / - (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1) - | otherwise = - let - q = sqrt(-2*log(1-p)) - in - -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / - ((((d1*q+d2)*q+d3)*q+d4)*q+1) - where - a1 = -3.969683028665376e+01 - a2 = 2.209460984245205e+02 - a3 = -2.759285104469687e+02 - a4 = 1.383577518672690e+02 - a5 = -3.066479806614716e+01 - a6 = 2.506628277459239e+00 - - b1 = -5.447609879822406e+01 - b2 = 1.615858368580409e+02 - b3 = -1.556989798598866e+02 - b4 = 6.680131188771972e+01 - b5 = -1.328068155288572e+01 - - c1 = -7.784894002430293e-03 - c2 = -3.223964580411365e-01 - c3 = -2.400758277161838e+00 - c4 = -2.549732539343734e+00 - c5 = 4.374664141464968e+00 - c6 = 2.938163982698783e+00 - - d1 = 7.784695709041462e-03 - d2 = 3.224671290700398e-01 - d3 = 2.445134137142996e+00 - d4 = 3.754408661907416e+00 - - p_low = 0.02425 - p_high = 1 - p_low - -addCoverageCheck :: Confidence -> State -> Property -> Property -addCoverageCheck confidence st prop - | and [ sufficientlyCovered confidence tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - -- Note: run prop once more so that we get labels for this test case run - once prop - | or [ insufficientlyCovered (Just (certainty confidence)) tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - let (theLabels, theTables) = labelsAndTables st in - foldr counterexample (property failed{P.reason = "Insufficient coverage"}) - (paragraphs [theLabels, theTables]) - | otherwise = prop - -allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] -allCoverage st = - [ (key, value, tot, n, p) - | ((key, value), p) <- Map.toList (S.requiredCoverage st), - let tot = - case key of - Just key -> Map.findWithDefault 0 key totals - Nothing -> numSuccessTests st, - let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ] - where - combinedCounts :: Map (Maybe String) (Map String Int) - combinedCounts = - Map.insert Nothing (S.classes st) - (Map.mapKeys Just (S.tables st)) - - totals :: Map String Int - totals = fmap (sum . Map.elems) (S.tables st) - --------------------------------------------------------------------------- --- the end. 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 = concat (intersperse " " (zipWith cell widths cells)) - cell n (LJust xs) = ljust n xs - cell n (RJust xs) = rjust n xs - cell n (Centred xs) = centre n xs - --- Draw a table given a header and contents -drawTable :: [String] -> [[Cell]] -> [String] -drawTable headers table = - [line] ++ - [border '|' ' ' header | header <- headers] ++ - [line | not (null headers) && not (null rows)] ++ - [border '|' ' ' row | row <- rows] ++ - [line] - where - rows = flattenRows table - - headerwidth = maximum (0:map length headers) - bodywidth = maximum (0:map length rows) - width = max headerwidth bodywidth - - line = border '+' '-' $ replicate width '-' - border x y xs = [x, y] ++ centre width xs ++ [y, x] - -paragraphs :: [[String]] -> [String] -paragraphs = concat . intersperse [""] . filter (not . null) - -bold :: String -> String --- not portable: ---bold s = "\ESC[1m" ++ s ++ "\ESC[0m" -bold s = s -- for now - --------------------------------------------------------------------------- --- putting strings - -data Terminal - = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) - -newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal -newTerminal out err = - do res <- newIORef (showString "") - tmp <- newIORef 0 - return (MkTerminal res tmp out err) - -withBuffering :: IO a -> IO a -withBuffering action = do - mode <- hGetBuffering stderr - -- By default stderr is unbuffered. This is very slow, hence we explicitly - -- enable line buffering. - hSetBuffering stderr LineBuffering - action `finally` hSetBuffering stderr mode - -withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a -withHandleTerminal outh merrh action = do - let - err = - case merrh of - Nothing -> const (return ()) - Just errh -> handle errh - newTerminal (handle outh) err >>= action - -withStdioTerminal :: (Terminal -> IO a) -> IO a -withStdioTerminal action = do - isatty <- hIsTerminalDevice stderr - if isatty then - withBuffering (withHandleTerminal stdout (Just stderr) action) - else - withBuffering (withHandleTerminal stdout Nothing action) - -withNullTerminal :: (Terminal -> IO a) -> IO a -withNullTerminal action = - newTerminal (const (return ())) (const (return ())) >>= action - -terminalOutput :: Terminal -> IO String -terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) - -handle :: Handle -> String -> IO () -handle h s = do - hPutStr h s - hFlush h - -putPart, putTemp, putLine :: Terminal -> String -> IO () -putPart tm@(MkTerminal res _ out _) s = - do putTemp tm "" - force s - out s - modifyIORef res (. showString s) - where - force :: [a] -> IO () - force = evaluate . seqList - - seqList :: [a] -> () - seqList [] = () - seqList (x:xs) = x `seq` seqList xs - -putLine tm s = putPart tm (s ++ "\n") - -putTemp tm@(MkTerminal _ tmp _ err) s = - do n <- readIORef tmp - err $ - replicate n ' ' ++ replicate n '\b' ++ - s ++ [ '\b' | _ <- s ] - writeIORef tmp (length s) - --------------------------------------------------------------------------- --- the end. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,4 +1,7 @@ -QuickCheck 2.14 (release 2020-03-28) +QuickCheck 2.14.1 (release 2020-07-05) + * Compatibility with random >= 1.2. + +QuickCheck 2.14 (released 2020-03-28) * QuickCheck is now much faster at generating test data! As a result, many properties can now be tested a lot faster; the examples distributed with QuickCheck run about twice as @@ -31,7 +34,7 @@ - When a call to 'within' fails, include the duration of the timeout in the failure report (thanks to William Rusnack). - In Gen, avoid splitting the seed in the implementation of - >>, *> and <- (thanks to David Feuer). + >>, *> and <* (thanks to David Feuer). - Fix a couple of bugs with shrinking of floating-point numbers. - Export functionMapWith, functionEitherWith and diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module Main where +import Data.Int + -------------------------------------------------------------------------- -- imports @@ -144,7 +146,7 @@ -- main return [] -main = $quickCheckAll +main = $forAllProperties (quickCheckWithResult stdArgs{maxSuccess = 10000}) -------------------------------------------------------------------------- -- the end. diff --git a/make-hugs b/make-hugs --- a/make-hugs +++ b/make-hugs @@ -1,16 +1,25 @@ #!/bin/bash -cd $(dirname $0) -for i in $(find Test -name '*.hs'); do - mkdir -p quickcheck-hugs/$(dirname $i) + +set -e + +TOPDIR=$(dirname "$0") +TARGETDIR=$TOPDIR/quickcheck-hugs + +find "$TOPDIR/src" -name '*.hs' | while read -r src; do + tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'//')" + + echo "Processing $src -> $tgt" + + mkdir -p "$(dirname "$tgt")" # If you want to switch on and off other features, look in # QuickCheck.cabal to see what's available, or submit a patch # adding a new -DNO_... flag. - cpphs --noline -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \ + cpphs --noline -DOLD_RANDOM -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \ -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \ -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \ -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \ -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE \ - $i > quickcheck-hugs/$i + "$src" > "$tgt" done echo "A Hugs-compatible version of QuickCheck is now" 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,326 @@ +{-| +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 + , chooseInt + , chooseInteger + , chooseBoundedIntegral + , chooseEnum + , chooseAny + , oneof + , frequency + , elements + , growingElements + , sized + , getSize + , resize + , scale + , suchThat + , suchThatMap + , suchThatMaybe + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 + -- ** Generators for lists + , listOf + , listOf1 + , vectorOf + , vector + , infiniteListOf + , infiniteList + , shuffle + , sublistOf + , orderedList + -- ** Generators for particular types + , arbitrarySizedIntegral + , arbitrarySizedNatural + , arbitrarySizedFractional + , arbitrarySizedBoundedIntegral + , arbitraryBoundedIntegral + , arbitraryBoundedRandom + , arbitraryBoundedEnum + , arbitraryUnicodeChar + , arbitraryASCIIChar + , arbitraryPrintableChar + -- ** Running generators + , generate + -- ** Debugging generators + , sample + , sample' + +#ifndef NO_GADTS + -- * The 'Function' typeclass: generation of random shrinkable, showable functions + + -- | Example of use: + -- + -- >>> :{ + -- >>> let prop :: Fun String Integer -> Bool + -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" + -- >>> :} + -- >>> quickCheck prop + -- *** Failed! Falsified (after 3 tests and 134 shrinks): + -- {"elephant"->1, "monkey"->1, _->0} + -- + -- To generate random values of type @'Fun' a b@, + -- you must have an instance @'Function' a@. + -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, + -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. + -- See the @'Function' [a]@ instance for an example of the latter. + -- + -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. + , Fun (..) + , applyFun + , applyFun2 + , applyFun3 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + , Function (..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum + , functionVoid +#endif + + -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way + , CoArbitrary(..) +#ifndef NO_GENERICS + , genericCoarbitrary +#endif + , variant + , coarbitraryIntegral + , coarbitraryReal + , coarbitraryShow + , coarbitraryEnum + , (><) + + -- * Type-level modifiers for changing generator behavior + + -- | These types do things such as restricting the kind of test data that can be generated. + -- They can be pattern-matched on in properties as a stylistic + -- alternative to using explicit quantification. + -- + -- Examples: + -- + -- @ + -- -- Functions cannot be shown (but see 'Function') + -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = + -- takeWhile p xs ++ dropWhile p xs == xs + -- @ + -- + -- @ + -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = + -- take n xs ++ drop n xs == xs + -- @ + -- + -- @ + -- -- cycle does not work for empty lists + -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = + -- take n (cycle xs) == take n (xs ++ cycle xs) + -- @ + -- + -- @ + -- -- Instead of 'forAll' 'orderedList' + -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = + -- sort xs == xs + -- @ + , Blind(..) + , Fixed(..) + , OrderedList(..) + , NonEmptyList(..) + , InfiniteList(..) + , SortedList(..) + , Positive(..) + , Negative(..) + , NonZero(..) + , NonNegative(..) + , NonPositive(..) + , Large(..) + , Small(..) + , Smart(..) + , Shrink2(..) +#ifndef NO_MULTI_PARAM_TYPE_CLASSES + , Shrinking(..) + , ShrinkState(..) +#endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) + + -- * Property combinators + , Property, Testable(..) + , forAll + , forAllShrink + , forAllShow + , forAllShrinkShow + , forAllBlind + , forAllShrinkBlind + , shrinking + , (==>) + , Discard(..) + , discard + , (===) + , (=/=) +#ifndef NO_DEEPSEQ + , total +#endif + , ioProperty + , idempotentIOProperty + -- ** Controlling property execution + , verbose + , verboseShrinking + , noShrinking + , withMaxSuccess + , within + , once + , again + , mapSize + -- ** Conjunction and disjunction + , (.&.) + , (.&&.) + , conjoin + , (.||.) + , disjoin + -- ** What to do on failure + , counterexample + , printTestCase + , whenFail + , whenFail' + , expectFailure + -- * Analysing test case distribution + , label + , collect + , classify + , tabulate + -- ** Checking test case distribution + , cover + , coverTable + , checkCoverage + , checkCoverageWith + , Confidence(..) + , stdConfidence + -- ** Generating example test cases + , labelledExamples + , labelledExamplesWith + , labelledExamplesWithResult + , labelledExamplesResult + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Modifiers +import Test.QuickCheck.Property hiding ( Result(..) ) +import Test.QuickCheck.Test +import Test.QuickCheck.Exception +#ifndef NO_GADTS +import Test.QuickCheck.Function +#endif +import Test.QuickCheck.Features +import Test.QuickCheck.State +#ifndef NO_TEMPLATE_HASKELL +import Test.QuickCheck.All +#endif + +-------------------------------------------------------------------------- +-- the end. 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,213 @@ +{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif + +-- | __Note__: the contents of this module are re-exported by +-- "Test.QuickCheck". You do not need to import it directly. +-- +-- Test all properties in the current module, using Template Haskell. +-- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in +-- your module for any of these to work. +module Test.QuickCheck.All( + -- ** Testing all properties in a module + quickCheckAll, + verboseCheckAll, + forAllProperties, + allProperties, + -- ** Testing polymorphic properties + polyQuickCheck, + polyVerboseCheck, + monomorphic) where + +import Language.Haskell.TH +import Test.QuickCheck.Property hiding (Result) +import Test.QuickCheck.Test +import Data.Char +import Data.List +import Control.Monad + +import qualified System.IO as S + +-- | Test a polymorphic property, defaulting all type variables to 'Integer'. +-- +-- Invoke as @$('polyQuickCheck' 'prop)@, where @prop@ is a property. +-- Note that just evaluating @'quickCheck' prop@ in GHCi will seem to +-- work, but will silently default all type variables to @()@! +-- +-- @$('polyQuickCheck' \'prop)@ means the same as +-- @'quickCheck' $('monomorphic' \'prop)@. +-- If you want to supply custom arguments to 'polyQuickCheck', +-- you will have to combine 'quickCheckWith' and 'monomorphic' yourself. +-- +-- If you want to use 'polyQuickCheck' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +polyQuickCheck :: Name -> ExpQ +polyQuickCheck x = [| quickCheck $(monomorphic x) |] + +-- | Test a polymorphic property, defaulting all type variables to 'Integer'. +-- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'. +-- +-- If you want to use 'polyVerboseCheck' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +polyVerboseCheck :: Name -> ExpQ +polyVerboseCheck x = [| verboseCheck $(monomorphic x) |] + +type Error = forall a. String -> a + +-- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'. +-- +-- For example, if @f@ has type @'Ord' a => [a] -> [a]@ +-- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@. +-- +-- If you want to use 'monomorphic' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +monomorphic :: Name -> ExpQ +monomorphic t = do + ty0 <- fmap infoType (reify t) + let err msg = error $ msg ++ ": " ++ pprint ty0 + (polys, ctx, ty) <- deconstructType err ty0 + case polys of + [] -> return (expName t) + _ -> do + integer <- [t| Integer |] + ty' <- monomorphiseType err integer ty + return (SigE (expName t) ty') + +expName :: Name -> Exp +expName n = if isVar n then VarE n else ConE n + +-- See section 2.4 of the Haskell 2010 Language Report, plus support for "[]" +isVar :: Name -> Bool +isVar = let isVar' (c:_) = not (isUpper c || c `elem` ":[") + isVar' _ = True + in isVar' . nameBase + +infoType :: Info -> Type +#if MIN_VERSION_template_haskell(2,11,0) +infoType (ClassOpI _ ty _) = ty +infoType (DataConI _ ty _) = ty +infoType (VarI _ ty _) = ty +#else +infoType (ClassOpI _ ty _ _) = ty +infoType (DataConI _ ty _ _) = ty +infoType (VarI _ ty _ _) = ty +#endif + +deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) +deconstructType err ty0@(ForallT xs ctx ty) = do + let plain (PlainTV _) = True +#if MIN_VERSION_template_haskell(2,8,0) + plain (KindedTV _ StarT) = True +#else + plain (KindedTV _ StarK) = True +#endif + plain _ = False + unless (all plain xs) $ err "Higher-kinded type variables in type" + return (map (\(PlainTV x) -> x) xs, ctx, ty) +deconstructType _ ty = return ([], [], ty) + +monomorphiseType :: Error -> Type -> Type -> TypeQ +monomorphiseType err mono ty@(VarT n) = return mono +monomorphiseType err mono (AppT t1 t2) = liftM2 AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2) +monomorphiseType err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" +monomorphiseType err mono ty = return ty + +-- | Test all properties in the current module, using a custom +-- 'quickCheck' function. The same caveats as with 'quickCheckAll' +-- apply. +-- +-- @$'forAllProperties'@ has type @('Property' -> 'IO' 'Result') -> 'IO' 'Bool'@. +-- An example invocation is @$'forAllProperties' 'quickCheckResult'@, +-- which does the same thing as @$'quickCheckAll'@. +-- +-- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool +forAllProperties = [| runQuickCheckAll $allProperties |] + +-- | List all properties in the current module. +-- +-- @$'allProperties'@ has type @[('String', 'Property')]@. +-- +-- 'allProperties' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +allProperties :: Q Exp +allProperties = do + Loc { loc_filename = filename } <- location + when (filename == "") $ 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/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,1454 @@ +-- | Type classes for random generation of values. +-- +-- __Note__: the contents of this module are re-exported by +-- "Test.QuickCheck". You do not need to import it directly. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +#ifndef NO_GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} +{-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPING_ +#endif +#endif +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +#ifndef NO_NEWTYPE_DERIVING +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif +module Test.QuickCheck.Arbitrary + ( + -- * Arbitrary and CoArbitrary classes + Arbitrary(..) + , CoArbitrary(..) + + -- ** Unary and Binary classes + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + + -- ** Helper functions for implementing arbitrary + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 + , arbitrarySizedIntegral -- :: Integral a => Gen a + , arbitrarySizedNatural -- :: Integral a => Gen a + , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a + , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a + , arbitrarySizedFractional -- :: Fractional a => Gen a + , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a + , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a + -- ** Generators for various kinds of character + , arbitraryUnicodeChar -- :: Gen Char + , arbitraryASCIIChar -- :: Gen Char + , arbitraryPrintableChar -- :: Gen Char + -- ** Helper functions for implementing shrink +#ifndef NO_GENERICS + , RecursivelyShrink + , GSubterms + , genericShrink -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] + , subterms -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] + , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] + , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b +#endif + , shrinkNothing -- :: a -> [a] + , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] + , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] + , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] + , shrinkIntegral -- :: Integral a => a -> [a] + , shrinkRealFrac -- :: RealFrac a => a -> [a] + , shrinkDecimal -- :: RealFrac a => a -> [a] + -- ** Helper functions for implementing coarbitrary + , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b + , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b + , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b + , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b + , (><) + + -- ** Generators which use arbitrary + , vector -- :: Arbitrary a => Int -> Gen [a] + , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] + , infiniteList -- :: Arbitrary a => Gen [a] + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Control.Applicative +import Data.Foldable(toList) +import System.Random(Random) +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Test.QuickCheck.Gen.Unsafe + +{- +import Data.Generics + ( (:*:)(..) + , (:+:)(..) + , Unit(..) + ) +-} + +import Data.Char + ( ord + , isLower + , isUpper + , toLower + , isDigit + , isSpace + , isPrint + , generalCategory + , GeneralCategory(..) + ) + +#ifndef NO_FIXED +import Data.Fixed + ( Fixed + , HasResolution + ) +#endif + +import Data.Ratio + ( Ratio + , (%) + , numerator + , denominator + ) + +import Data.Complex + ( Complex((:+)) ) + +import Data.List + ( sort + , nub + ) + +import Data.Version (Version (..)) + +import Control.Monad + ( liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + ) + +import Data.Int(Int8, Int16, Int32, Int64) +import Data.Word(Word, Word8, Word16, Word32, Word64) +import System.Exit (ExitCode(..)) +import Foreign.C.Types + +#ifndef NO_GENERICS +import GHC.Generics +#endif + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import qualified Data.Sequence as Sequence +import Data.Bits + +import qualified Data.Monoid as Monoid + +#ifndef NO_TRANSFORMERS +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Functor.Compose +import Data.Functor.Product +#endif + +-------------------------------------------------------------------------- +-- ** class Arbitrary + +-- | Random generation and shrinking of values. +-- +-- QuickCheck provides @Arbitrary@ instances for most types in @base@, +-- except those which incur extra dependencies. +-- For a wider range of @Arbitrary@ instances see the +-- +-- 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 = chooseEnum (False,True) + shrink True = [False] + shrink False = [] + +instance Arbitrary Ordering where + arbitrary = elements [LT, EQ, GT] + shrink GT = [EQ, LT] + shrink LT = [EQ] + shrink EQ = [] + +instance Arbitrary1 Maybe where + liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] + + liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] + liftShrink _ Nothing = [] + +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance Arbitrary2 Either where + liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] + + liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] + liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] + +instance Arbitrary a => Arbitrary1 (Either a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where + arbitrary = arbitrary2 + shrink = shrink2 + +instance Arbitrary1 [] where + liftArbitrary = listOf + liftShrink = shrinkList + +instance Arbitrary a => Arbitrary [a] where + arbitrary = arbitrary1 + shrink = shrink1 + +-- | Shrink a list of values given a shrinking function for individual values. +shrinkList :: (a -> [a]) -> [a] -> [[a]] +shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ] + ++ shrinkOne xs + where + n = length xs + + shrinkOne [] = [] + shrinkOne (x:xs) = [ x':xs | x' <- shr x ] + ++ [ x:xs' | xs' <- shrinkOne xs ] + + removes k n xs + | k > n = [] + | null xs2 = [[]] + | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2) + where + xs1 = take k xs + xs2 = drop k xs + +{- + -- "standard" definition for lists: + shrink [] = [] + shrink (x:xs) = [ xs ] + ++ [ x:xs' | xs' <- shrink xs ] + ++ [ x':xs | x' <- shrink x ] +-} + +instance Integral a => Arbitrary (Ratio a) where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) +instance Arbitrary a => Arbitrary (Complex a) where +#else +instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where +#endif + arbitrary = liftM2 (:+) arbitrary arbitrary + shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ + [ x :+ y' | y' <- shrink y ] + +#ifndef NO_FIXED +instance HasResolution a => Arbitrary (Fixed a) where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal +#endif + +instance Arbitrary2 (,) where + liftArbitrary2 = liftM2 (,) + liftShrink2 shrA shrB (x, y) = + [ (x', y) | x' <- shrA x ] + ++ [ (x, y') | y' <- shrB y ] + +instance (Arbitrary a) => Arbitrary1 ((,) a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where + arbitrary = arbitrary2 + shrink = shrink2 + +instance (Arbitrary a, Arbitrary b, Arbitrary c) + => Arbitrary (a,b,c) + where + arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary + + shrink (x, y, z) = + [ (x', y', z') + | (x', (y', z')) <- shrink (x, (y, z)) ] + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => Arbitrary (a,b,c,d) + where + arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary + + shrink (w, x, y, z) = + [ (w', x', y', z') + | (w', (x', (y', z'))) <- shrink (w, (x, (y, z))) ] + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) + => Arbitrary (a,b,c,d,e) + where + arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary + + shrink (v, w, x, y, z) = + [ (v', w', x', y', z') + | (v', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f + ) + => Arbitrary (a,b,c,d,e,f) + where + arbitrary = return (,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + + shrink (u, v, w, x, y, z) = + [ (u', v', w', x', y', z') + | (u', (v', (w', (x', (y', z'))))) <- shrink (u, (v, (w, (x, (y, z))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g + ) + => Arbitrary (a,b,c,d,e,f,g) + where + arbitrary = return (,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + + shrink (t, u, v, w, x, y, z) = + [ (t', u', v', w', x', y', z') + | (t', (u', (v', (w', (x', (y', z')))))) <- shrink (t, (u, (v, (w, (x, (y, z)))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h + ) + => Arbitrary (a,b,c,d,e,f,g,h) + where + arbitrary = return (,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + + shrink (s, t, u, v, w, x, y, z) = + [ (s', t', u', v', w', x', y', z') + | (s', (t', (u', (v', (w', (x', (y', z'))))))) + <- shrink (s, (t, (u, (v, (w, (x, (y, z))))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i + ) + => Arbitrary (a,b,c,d,e,f,g,h,i) + where + arbitrary = return (,,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + + shrink (r, s, t, u, v, w, x, y, z) = + [ (r', s', t', u', v', w', x', y', z') + | (r', (s', (t', (u', (v', (w', (x', (y', z')))))))) + <- shrink (r, (s, (t, (u, (v, (w, (x, (y, z)))))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j + ) + => Arbitrary (a,b,c,d,e,f,g,h,i,j) + where + arbitrary = return (,,,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + + shrink (q, r, s, t, u, v, w, x, y, z) = + [ (q', r', s', t', u', v', w', x', y', z') + | (q', (r', (s', (t', (u', (v', (w', (x', (y', z'))))))))) + <- shrink (q, (r, (s, (t, (u, (v, (w, (x, (y, z))))))))) ] + +-- typical instance for primitive (numerical) types + +instance Arbitrary Integer where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word where + arbitrary = arbitrarySizedNatural + shrink = shrinkIntegral + +instance Arbitrary Word8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Char where + arbitrary = + frequency + [(3, arbitraryASCIIChar), + (1, arbitraryUnicodeChar)] + + shrink c = filter (<. c) $ nub + $ ['a','b','c'] + ++ [ toLower c | isUpper c ] + ++ ['A','B','C'] + ++ ['1','2','3'] + ++ [' ','\n'] + where + a <. b = stamp a < stamp b + stamp a = ( (not (isLower a) + , not (isUpper a) + , not (isDigit a)) + , (not (a==' ') + , not (isSpace a) + , a) + ) + +instance Arbitrary Float where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +instance Arbitrary Double where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +instance Arbitrary CChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CShort where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUShort where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CInt where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUInt where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CULong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CPtrdiff where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSize where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CWchar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSigAtomic where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CLLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CULLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CIntPtr where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUIntPtr where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CIntMax where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUIntMax where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +#ifndef NO_CTYPES_CONSTRUCTORS +-- The following four types have no Bounded instance, +-- so we fake it by discovering the bounds at runtime. +instance Arbitrary CClock where + arbitrary = fmap CClock arbitrary + shrink (CClock x) = map CClock (shrink x) + +instance Arbitrary CTime where + arbitrary = fmap CTime arbitrary + shrink (CTime x) = map CTime (shrink x) + +#ifndef NO_FOREIGN_C_USECONDS +instance Arbitrary CUSeconds where + arbitrary = fmap CUSeconds arbitrary + shrink (CUSeconds x) = map CUSeconds (shrink x) + +instance Arbitrary CSUSeconds where + arbitrary = fmap CSUSeconds arbitrary + shrink (CSUSeconds x) = map CSUSeconds (shrink x) +#endif +#endif + +instance Arbitrary CFloat where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +instance Arbitrary CDouble where + arbitrary = arbitrarySizedFractional + shrink = shrinkDecimal + +-- Arbitrary instances for container types +instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where + arbitrary = fmap Set.fromList arbitrary + shrink = map Set.fromList . shrink . Set.toList +instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where + liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + shrink = map IntSet.fromList . shrink . IntSet.toList +instance Arbitrary1 IntMap.IntMap where + liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList +instance Arbitrary a => Arbitrary (IntMap.IntMap a) where + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary1 Sequence.Seq where + liftArbitrary = fmap Sequence.fromList . liftArbitrary + liftShrink shr = map Sequence.fromList . liftShrink shr . toList +instance Arbitrary a => Arbitrary (Sequence.Seq a) where + arbitrary = arbitrary1 + shrink = shrink1 + +-- Arbitrary instance for Ziplist +instance Arbitrary1 ZipList where + liftArbitrary = fmap ZipList . liftArbitrary + liftShrink shr = map ZipList . liftShrink shr . getZipList +instance Arbitrary a => Arbitrary (ZipList a) where + arbitrary = arbitrary1 + shrink = shrink1 + +#ifndef NO_TRANSFORMERS +-- Arbitrary instance for transformers' Functors +instance Arbitrary1 Identity where + liftArbitrary = fmap Identity + liftShrink shr = map Identity . shr . runIdentity +instance Arbitrary a => Arbitrary (Identity a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance Arbitrary2 Constant where + liftArbitrary2 arbA _ = fmap Constant arbA + liftShrink2 shrA _ = fmap Constant . shrA . getConstant +instance Arbitrary a => Arbitrary1 (Constant a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Constant is kind polymorphic +instance Arbitrary a => Arbitrary (Constant a b) where + arbitrary = fmap Constant arbitrary + shrink = map Constant . shrink . getConstant + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where + liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) + liftShrink shr (Pair f g) = + [ Pair f' g | f' <- liftShrink shr f ] ++ + [ Pair f g' | g' <- liftShrink shr g ] +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where + liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary + liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + +-- Arbitrary instance for Const +instance Arbitrary2 Const where + liftArbitrary2 arbA _ = fmap Const arbA + liftShrink2 shrA _ = fmap Const . shrA . getConst +instance Arbitrary a => Arbitrary1 (Const a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Const is kind polymorphic +instance Arbitrary a => Arbitrary (Const a b) where + arbitrary = fmap Const arbitrary + shrink = map Const . shrink . getConst + +instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where + arbitrary = WrapMonad <$> arbitrary + shrink (WrapMonad a) = map WrapMonad (shrink a) + +instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where + arbitrary = WrapArrow <$> arbitrary + shrink (WrapArrow a) = map WrapArrow (shrink a) + +-- Arbitrary instances for Monoid +instance Arbitrary a => Arbitrary (Monoid.Dual a) where + arbitrary = fmap Monoid.Dual arbitrary + shrink = map Monoid.Dual . shrink . Monoid.getDual + +instance (Arbitrary a, CoArbitrary a) => Arbitrary (Monoid.Endo a) where + arbitrary = fmap Monoid.Endo arbitrary + shrink = map Monoid.Endo . shrink . Monoid.appEndo + +instance Arbitrary Monoid.All where + arbitrary = fmap Monoid.All arbitrary + shrink = map Monoid.All . shrink . Monoid.getAll + +instance Arbitrary Monoid.Any where + arbitrary = fmap Monoid.Any arbitrary + shrink = map Monoid.Any . shrink . Monoid.getAny + +instance Arbitrary a => Arbitrary (Monoid.Sum a) where + arbitrary = fmap Monoid.Sum arbitrary + shrink = map Monoid.Sum . shrink . Monoid.getSum + +instance Arbitrary a => Arbitrary (Monoid.Product a) where + arbitrary = fmap Monoid.Product arbitrary + shrink = map Monoid.Product . shrink . Monoid.getProduct + +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(3,0,0) +instance Arbitrary a => Arbitrary (Monoid.First a) where + arbitrary = fmap Monoid.First arbitrary + shrink = map Monoid.First . shrink . Monoid.getFirst + +instance Arbitrary a => Arbitrary (Monoid.Last a) where + arbitrary = fmap Monoid.Last arbitrary + shrink = map Monoid.Last . shrink . Monoid.getLast +#endif + +#if MIN_VERSION_base(4,8,0) +instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where + arbitrary = fmap Monoid.Alt arbitrary + shrink = map Monoid.Alt . shrink . Monoid.getAlt +#endif +#endif + +-- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ +instance Arbitrary Version where + arbitrary = sized $ \n -> + do k <- chooseInt (0, log2 n) + xs <- vectorOf (k+1) arbitrarySizedNatural + return (Version xs []) + where + log2 :: Int -> Int + log2 n | n <= 1 = 0 + | otherwise = 1 + log2 (n `div` 2) + + shrink (Version xs _) = + [ Version xs' [] + | xs' <- shrink xs + , length xs' > 0 + , all (>=0) xs' + ] + +instance Arbitrary QCGen where + arbitrary = MkGen (\g _ -> g) + +instance Arbitrary ExitCode where + arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] + + shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] + shrink _ = [] + + + +-- ** Helper functions for implementing arbitrary + +-- | Apply a binary function to random arguments. +applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r +applyArbitrary2 f = liftA2 f arbitrary arbitrary + +-- | Apply a ternary function to random arguments. +applyArbitrary3 + :: (Arbitrary a, Arbitrary b, Arbitrary c) + => (a -> b -> c -> r) -> Gen r +applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary + +-- | Apply a function of arity 4 to random arguments. +applyArbitrary4 + :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => (a -> b -> c -> d -> r) -> Gen r +applyArbitrary4 f = applyArbitrary3 (uncurry f) + +-- | Generates an integral number. The number can be positive or negative +-- and its maximum absolute value depends on the size parameter. +arbitrarySizedIntegral :: Integral a => Gen a +arbitrarySizedIntegral = + sized $ \n -> + inBounds fromIntegral (chooseInt (-n, n)) + +-- | Generates a natural number. The number's maximum value depends on +-- the size parameter. +arbitrarySizedNatural :: Integral a => Gen a +arbitrarySizedNatural = + sized $ \n -> + inBounds fromIntegral (chooseInt (0, n)) + +inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a +inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x))) + +-- | Generates a fractional number. The number can be positive or negative +-- and its maximum absolute value depends on the size parameter. +arbitrarySizedFractional :: Fractional a => Gen a +arbitrarySizedFractional = + sized $ \n -> + let n' = toInteger n in + do b <- chooseInteger (1, precision) + a <- chooseInteger ((-n') * b, n' * b) + return (fromRational (a % b)) + where + precision = 9999999999999 :: Integer + +-- Useful for getting at minBound and maxBound without having to +-- fiddle around with asTypeOf. +{-# INLINE withBounds #-} +withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a +withBounds k = k minBound maxBound + +-- | Generates an integral number. The number is chosen uniformly from +-- the entire range of the type. You may want to use +-- 'arbitrarySizedBoundedIntegral' instead. +arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a +arbitraryBoundedIntegral = chooseBoundedIntegral (minBound, maxBound) + +-- | Generates an element of a bounded type. The element is +-- chosen from the entire range of the type. +arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a +arbitraryBoundedRandom = choose (minBound,maxBound) + +-- | Generates an element of a bounded enumeration. +arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a +arbitraryBoundedEnum = chooseEnum (minBound, maxBound) + +-- | Generates an integral number from a bounded domain. The number is +-- chosen from the entire range of the type, but small numbers are +-- generated more often than big numbers. Inspired by demands from +-- Phil Wadler. +arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a +-- INLINEABLE so that this combinator gets specialised at each type, +-- which means that the constant 'bits' in the let-block below will +-- only be computed once. +{-# INLINEABLE arbitrarySizedBoundedIntegral #-} +arbitrarySizedBoundedIntegral = + withBounds $ \mn mx -> + let ilog2 1 = 0 + ilog2 n | n > 0 = 1 + ilog2 (n `div` 2) + + -- How many bits are needed to represent this type? + -- (This number is an upper bound, not exact.) + bits = ilog2 (toInteger mx - toInteger mn + 1) in + sized $ \k -> + let + -- Reach maximum size by k=80, or quicker for small integer types + power = ((bits `max` 40) * k) `div` 80 + + -- Bounds should be 2^power, but: + -- * clamp the result to minBound/maxBound + -- * clamp power to 'bits', in case k is a huge number + lo = toInteger mn `max` (-1 `shiftL` (power `min` bits)) + hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in + fmap fromInteger (chooseInteger (lo, hi)) + +-- ** Generators for various kinds of character + +-- | Generates any Unicode character (but not a surrogate) +arbitraryUnicodeChar :: Gen Char +arbitraryUnicodeChar = + arbitraryBoundedEnum `suchThat` isValidUnicode + where + isValidUnicode c = case generalCategory c of + Surrogate -> False + NotAssigned -> False + _ -> True + +-- | Generates a random ASCII character (0-127). +arbitraryASCIIChar :: Gen Char +arbitraryASCIIChar = chooseEnum ('\0', '\127') + +-- | Generates a printable Unicode character. +arbitraryPrintableChar :: Gen Char +arbitraryPrintableChar = arbitrary `suchThat` isPrint + +-- ** Helper functions for implementing shrink + +-- | Returns no shrinking alternatives. +shrinkNothing :: a -> [a] +shrinkNothing _ = [] + +-- | Map a shrink function to another domain. This is handy if your data type +-- has special invariants, but is /almost/ isomorphic to some other type. +-- +-- @ +-- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] +-- shrinkOrderedList = shrinkMap sort id +-- +-- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] +-- shrinkSet = shrinkMap fromList toList +-- @ +shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] +shrinkMap f g = shrinkMapBy f g shrink + +-- | Non-overloaded version of `shrinkMap`. +shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] +shrinkMapBy f g shr = map f . shr . g + +-- | Shrink an integral number. +shrinkIntegral :: Integral a => a -> [a] +shrinkIntegral x = + nub $ + [ -x + | x < 0, -x > x + ] ++ + [ x' + | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) + ] + where + -- a << b is "morally" abs a < abs b, but taking care of overflow. + a << b = case (a >= 0, b >= 0) of + (True, True) -> a < b + (False, False) -> a > b + (True, False) -> a + b < 0 + (False, True) -> a + b > 0 + +-- | Shrink a fraction, preferring numbers with smaller +-- numerators or denominators. See also 'shrinkDecimal'. +shrinkRealFrac :: RealFrac a => a -> [a] +shrinkRealFrac x + | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN + | not (2*x+1>x) = 0 : takeWhile ( abs y < abs x) $ + -- Try shrinking to an integer first + map fromInteger (shrink (truncate x) ++ [truncate x]) ++ + -- Shrink the numerator + [fromRational (num' % denom) | num' <- shrink num] ++ + -- Shrink the denominator, and keep the fraction as close + -- to the original as possible, rounding towards zero + [fromRational (truncate (num * denom' % denom) % denom') + | denom' <- shrink denom, denom' /= 0 ] + where + num = numerator (toRational x) + denom = denominator (toRational x) + +-- | Shrink a real number, preferring numbers with shorter +-- decimal representations. See also 'shrinkRealFrac'. +shrinkDecimal :: RealFrac a => a -> [a] +shrinkDecimal x + | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN + | not (2*abs x+1>abs x) = 0 : takeWhile ( instance CoArbitrary MyType +-- +-- You should only use 'genericCoarbitrary' for data types where +-- equality is structural, i.e. if you can't have two different +-- representations of the same value. An example where it's not +-- safe is sets implemented using binary search trees: the same +-- set can be represented as several different trees. +-- Here you would have to explicitly define +-- @coarbitrary s = coarbitrary (toList s)@. +#else +-- | Used for random generation of functions. +#endif +class CoArbitrary a where + -- | Used to generate a function of type @a -> b@. + -- The first argument is a value, the second a generator. + -- You should use 'variant' to perturb the random generator; + -- the goal is that different values for the first argument will + -- lead to different calls to 'variant'. An example will help: + -- + -- @ + -- instance CoArbitrary a => CoArbitrary [a] where + -- coarbitrary [] = 'variant' 0 + -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) + -- @ + coarbitrary :: a -> Gen b -> Gen b +#ifndef NO_GENERICS + default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b + coarbitrary = genericCoarbitrary + +-- | Generic CoArbitrary implementation. +genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b +genericCoarbitrary = gCoarbitrary . from + +class GCoArbitrary f where + gCoarbitrary :: f a -> Gen b -> Gen b + +instance GCoArbitrary U1 where + gCoarbitrary U1 = id + +instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where + -- Like the instance for tuples. + gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r + +instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where + -- Like the instance for Either. + gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x + gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x + +instance GCoArbitrary f => GCoArbitrary (M1 i c f) where + gCoarbitrary (M1 x) = gCoarbitrary x + +instance CoArbitrary a => GCoArbitrary (K1 i a) where + gCoarbitrary (K1 x) = coarbitrary x +#endif + +{-# DEPRECATED (><) "Use ordinary function composition instead" #-} +-- | Combine two generator perturbing functions, for example the +-- results of calls to 'variant' or 'coarbitrary'. +(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) +(><) = (.) + +instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where + coarbitrary f gen = + do xs <- arbitrary + coarbitrary (map f xs) gen + +instance CoArbitrary () where + coarbitrary _ = id + +instance CoArbitrary Bool where + coarbitrary False = variant 0 + coarbitrary True = variant 1 + +instance CoArbitrary Ordering where + coarbitrary GT = variant 0 + coarbitrary EQ = variant 1 + coarbitrary LT = variant 2 + +instance CoArbitrary a => CoArbitrary (Maybe a) where + coarbitrary Nothing = variant 0 + coarbitrary (Just x) = variant 1 . coarbitrary x + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where + coarbitrary (Left x) = variant 0 . coarbitrary x + coarbitrary (Right y) = variant 1 . coarbitrary y + +instance CoArbitrary a => CoArbitrary [a] where + coarbitrary [] = variant 0 + coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) + +instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where + coarbitrary r = coarbitrary (numerator r,denominator r) + +#ifndef NO_FIXED +instance HasResolution a => CoArbitrary (Fixed a) where + coarbitrary = coarbitraryReal +#endif + +#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) +instance CoArbitrary a => CoArbitrary (Complex a) where +#else +instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where +#endif + coarbitrary (x :+ y) = coarbitrary x . coarbitrary y + +instance (CoArbitrary a, CoArbitrary b) + => CoArbitrary (a,b) + where + coarbitrary (x,y) = coarbitrary x + . coarbitrary y + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) + => CoArbitrary (a,b,c) + where + coarbitrary (x,y,z) = coarbitrary x + . coarbitrary y + . coarbitrary z + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) + => CoArbitrary (a,b,c,d) + where + coarbitrary (x,y,z,v) = coarbitrary x + . coarbitrary y + . coarbitrary z + . coarbitrary v + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) + => CoArbitrary (a,b,c,d,e) + where + coarbitrary (x,y,z,v,w) = coarbitrary x + . coarbitrary y + . coarbitrary z + . coarbitrary v + . coarbitrary w + +-- typical instance for primitive (numerical) types + +instance CoArbitrary Integer where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int64 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word64 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Char where + coarbitrary = coarbitrary . ord + +instance CoArbitrary Float where + coarbitrary = coarbitraryReal + +instance CoArbitrary Double where + coarbitrary = coarbitraryReal + +-- Coarbitrary instances for container types +instance CoArbitrary a => CoArbitrary (Set.Set a) where + coarbitrary = coarbitrary. Set.toList +instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where + coarbitrary = coarbitrary . Map.toList +instance CoArbitrary IntSet.IntSet where + coarbitrary = coarbitrary . IntSet.toList +instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where + coarbitrary = coarbitrary . IntMap.toList +instance CoArbitrary a => CoArbitrary (Sequence.Seq a) where + coarbitrary = coarbitrary . toList + +-- CoArbitrary instance for Ziplist +instance CoArbitrary a => CoArbitrary (ZipList a) where + coarbitrary = coarbitrary . getZipList + +#ifndef NO_TRANSFORMERS +-- CoArbitrary instance for transformers' Functors +instance CoArbitrary a => CoArbitrary (Identity a) where + coarbitrary = coarbitrary . runIdentity + +instance CoArbitrary a => CoArbitrary (Constant a b) where + coarbitrary = coarbitrary . getConstant +#endif + +-- CoArbitrary instance for Const +instance CoArbitrary a => CoArbitrary (Const a b) where + coarbitrary = coarbitrary . getConst + +-- CoArbitrary instances for Monoid +instance CoArbitrary a => CoArbitrary (Monoid.Dual a) where + coarbitrary = coarbitrary . Monoid.getDual + +instance (Arbitrary a, CoArbitrary a) => CoArbitrary (Monoid.Endo a) where + coarbitrary = coarbitrary . Monoid.appEndo + +instance CoArbitrary Monoid.All where + coarbitrary = coarbitrary . Monoid.getAll + +instance CoArbitrary Monoid.Any where + coarbitrary = coarbitrary . Monoid.getAny + +instance CoArbitrary a => CoArbitrary (Monoid.Sum a) where + coarbitrary = coarbitrary . Monoid.getSum + +instance CoArbitrary a => CoArbitrary (Monoid.Product a) where + coarbitrary = coarbitrary . Monoid.getProduct + +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(3,0,0) +instance CoArbitrary a => CoArbitrary (Monoid.First a) where + coarbitrary = coarbitrary . Monoid.getFirst + +instance CoArbitrary a => CoArbitrary (Monoid.Last a) where + coarbitrary = coarbitrary . Monoid.getLast +#endif + +#if MIN_VERSION_base(4,8,0) +instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where + coarbitrary = coarbitrary . Monoid.getAlt +#endif +#endif + +instance CoArbitrary Version where + coarbitrary (Version a b) = coarbitrary (a, b) + +-- ** Helpers for implementing coarbitrary + +-- | A 'coarbitrary' implementation for integral numbers. +coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b +coarbitraryIntegral = variant + +-- | A 'coarbitrary' implementation for real numbers. +coarbitraryReal :: Real a => a -> Gen b -> Gen b +coarbitraryReal x = coarbitrary (toRational x) + +-- | 'coarbitrary' helper for lazy people :-). +coarbitraryShow :: Show a => a -> Gen b -> Gen b +coarbitraryShow x = coarbitrary (show x) + +-- | A 'coarbitrary' implementation for enums. +coarbitraryEnum :: Enum a => a -> Gen b -> Gen b +coarbitraryEnum = variant . fromEnum + +-------------------------------------------------------------------------- +-- ** arbitrary generators + +-- these are here and not in Gen because of the Arbitrary class constraint + +-- | Generates a list of a given length. +vector :: Arbitrary a => Int -> Gen [a] +vector k = vectorOf k arbitrary + +-- | Generates an ordered list. +orderedList :: (Ord a, Arbitrary a) => Gen [a] +orderedList = sort `fmap` arbitrary + +-- | Generates an infinite list. +infiniteList :: Arbitrary a => Gen [a] +infiniteList = infiniteListOf arbitrary + +-------------------------------------------------------------------------- +-- the end. 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,117 @@ +-- | Throwing and catching exceptions. Internal QuickCheck module. + +-- Hide away the nasty implementation-specific ways of catching +-- exceptions behind a nice API. The main trouble is catching ctrl-C. + +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Exception where + +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) +#define OLD_EXCEPTIONS +#endif + +#if defined(NO_EXCEPTIONS) +#else +import qualified Control.Exception as E +#endif + +#if defined(NO_EXCEPTIONS) +type AnException = () +#elif defined(OLD_EXCEPTIONS) +type AnException = E.Exception +#else +type AnException = E.SomeException +#endif + +#ifdef NO_EXCEPTIONS +tryEvaluate :: a -> IO (Either AnException a) +tryEvaluate x = return (Right x) + +tryEvaluateIO :: IO a -> IO (Either AnException a) +tryEvaluateIO m = fmap Right m + +evaluate :: a -> IO a +evaluate x = x `seq` return x + +isInterrupt :: AnException -> Bool +isInterrupt _ = False + +discard :: a +discard = error "'discard' not supported, since your Haskell system can't catch exceptions" + +isDiscard :: AnException -> Bool +isDiscard _ = False + +finally :: IO a -> IO b -> IO a +finally mx my = do + x <- mx + my + return x + +#else +-------------------------------------------------------------------------- +-- try evaluate + +tryEvaluate :: a -> IO (Either AnException a) +tryEvaluate x = tryEvaluateIO (return x) + +tryEvaluateIO :: IO a -> IO (Either AnException a) +tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) + where + notAsync :: AnException -> Maybe AnException +#if MIN_VERSION_base(4,7,0) + notAsync e = case E.fromException e of + Just (E.SomeAsyncException _) -> Nothing + Nothing -> Just e +#elif !defined(OLD_EXCEPTIONS) + notAsync e = case E.fromException e :: Maybe E.AsyncException of + Just _ -> Nothing + Nothing -> Just e +#else + notAsync e = Just e +#endif + +--tryEvaluateIO m = Right `fmap` m + +evaluate :: a -> IO a +evaluate = E.evaluate + +-- | Test if an exception was a @^C@. +-- QuickCheck won't try to shrink an interrupted test case. +isInterrupt :: AnException -> Bool + +#if defined(OLD_EXCEPTIONS) +isInterrupt _ = False +#else +isInterrupt e = E.fromException e == Just E.UserInterrupt +#endif + +-- | A special error value. If a property evaluates 'discard', it +-- causes QuickCheck to discard the current test case. +-- This can be useful if you want to discard the current test case, +-- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a +-- generator. +discard :: a + +isDiscard :: AnException -> Bool +(discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) + where + msg = "DISCARD. " ++ + "You should not see this exception, it is internal to QuickCheck." +#if defined(OLD_EXCEPTIONS) + isDiscard (E.ErrorCall msg') = msg' == msg + isDiscard _ = False +#else + isDiscard e = + case E.fromException e of + Just (E.ErrorCall msg') -> msg' == msg + _ -> False +#endif + +finally :: IO a -> IO b -> IO a +finally = E.finally +#endif + +-------------------------------------------------------------------------- +-- the end. 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,106 @@ +{-# OPTIONS_HADDOCK hide #-} +module Test.QuickCheck.Features where + +import Test.QuickCheck.Property hiding (Result, reason) +import qualified Test.QuickCheck.Property as P +import Test.QuickCheck.Test +import Test.QuickCheck.Gen +import Test.QuickCheck.State +import Test.QuickCheck.Text +import qualified Data.Set as Set +import Data.Set(Set) +import Data.List +import Data.IORef +import Data.Maybe + +features :: [String] -> Set String -> Set String +features labels classes = + Set.fromList labels `Set.union` classes + +prop_noNewFeatures :: Testable prop => Set String -> prop -> Property +prop_noNewFeatures feats prop = + mapResult f prop + where + f res = + case ok res of + Just True + | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) -> + res{ok = Just False, P.reason = "New feature found"} + _ -> res + +-- | Given a property, which must use 'label', 'collect', 'classify' or 'cover' +-- to associate labels with test cases, find an example test case for each possible label. +-- The example test cases are minimised using shrinking. +-- +-- For example, suppose we test @'Data.List.delete' x xs@ and record the number +-- of times that @x@ occurs in @xs@: +-- +-- > prop_delete :: Int -> [Int] -> Property +-- > prop_delete x xs = +-- > classify (count x xs == 0) "count x xs == 0" $ +-- > classify (count x xs == 1) "count x xs == 1" $ +-- > classify (count x xs >= 2) "count x xs >= 2" $ +-- > counterexample (show (delete x xs)) $ +-- > count x (delete x xs) == max 0 (count x xs-1) +-- > where count x xs = length (filter (== x) xs) +-- +-- 'labelledExamples' generates three example test cases, one for each label: +-- +-- >>> labelledExamples prop_delete +-- *** Found example of count x xs == 0 +-- 0 +-- [] +-- [] +-- +-- *** Found example of count x xs == 1 +-- 0 +-- [0] +-- [] +-- +-- *** Found example of count x xs >= 2 +-- 5 +-- [5,5] +-- [5] +-- +-- +++ OK, passed 100 tests: +-- 78% count x xs == 0 +-- 21% count x xs == 1 +-- 1% count x xs >= 2 + + +labelledExamples :: Testable prop => prop -> IO () +labelledExamples prop = labelledExamplesWith stdArgs prop + +-- | A variant of 'labelledExamples' that takes test arguments. +labelledExamplesWith :: Testable prop => Args -> prop -> IO () +labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return () + +-- | A variant of 'labelledExamples' that returns a result. +labelledExamplesResult :: Testable prop => prop -> IO Result +labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop + +-- | A variant of 'labelledExamples' that takes test arguments and returns a result. +labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result +labelledExamplesWithResult args prop = + withState args $ \state -> do + let + loop :: Set String -> State -> IO Result + loop feats state = withNullTerminal $ \nullterm -> do + res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) + let feats' = features (failingLabels res) (failingClasses res) + case res of + Failure{reason = "New feature found"} -> do + putLine (terminal state) $ + "*** Found example of " ++ + concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) + mapM_ (putLine (terminal state)) (failingTestCase res) + putStrLn "" + loop (Set.union feats feats') + state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} + _ -> do + out <- terminalOutput nullterm + putStr out + return res + at0 f s 0 0 = s + at0 f s n d = f n d + loop Set.empty state 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,588 @@ +{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +#endif + +#ifndef NO_GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts #-} +#endif + +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif + +-- | Generation of random shrinkable, showable functions. +-- See the paper \"Shrinking and showing functions\" by Koen Claessen. +-- +-- __Note__: most of the contents of this module are re-exported by +-- "Test.QuickCheck". You probably do not need to import it directly. +-- +-- Example of use: +-- +-- >>> :{ +-- >>> let prop :: Fun String Integer -> Bool +-- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" +-- >>> :} +-- >>> quickCheck prop +-- *** Failed! Falsified (after 3 tests and 134 shrinks): +-- {"elephant"->1, "monkey"->1, _->0} +-- +-- To generate random values of type @'Fun' a b@, +-- you must have an instance @'Function' a@. +-- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, +-- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. +-- See the @'Function' [a]@ instance for an example of the latter. +module Test.QuickCheck.Function + ( Fun(..) + , applyFun + , apply + , applyFun2 + , applyFun3 + , (:->) + , Function(..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum + , functionVoid + , functionMapWith + , functionEitherWith + , functionPairWith +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Poly + +import Control.Applicative +import Data.Char +import Data.Word +import Data.List( intersperse ) +import Data.Ratio +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Sequence +import Data.Int +import Data.Complex +import Data.Foldable(toList) +import Data.Functor.Identity +import qualified Data.Monoid as Monoid + +#ifndef NO_FIXED +import Data.Fixed +#endif + +#ifndef NO_GENERICS +import GHC.Generics hiding (C) +#endif + +-------------------------------------------------------------------------- +-- concrete functions + +-- | The type of possibly partial concrete functions +data a :-> c where + Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c) + (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) + Unit :: c -> (() :-> c) + Nil :: a :-> c + Table :: Eq a => [(a,c)] -> (a :-> c) + Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c) + +instance Functor ((:->) a) where + fmap f (Pair p) = Pair (fmap (fmap f) p) + fmap f (p:+:q) = fmap f p :+: fmap f q + fmap f (Unit c) = Unit (f c) + fmap f Nil = Nil + fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ] + fmap f (Map g h p) = Map g h (fmap f p) + +instance (Show a, Show b) => Show (a:->b) where + show p = showFunction p Nothing + +-- only use this on finite functions +showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String +showFunction p md = + "{" ++ concat (intersperse ", " ( [ show x ++ "->" ++ show c + | (x,c) <- table p + ] + ++ [ "_->" ++ show d + | Just d <- [md] + ] )) ++ "}" + +-- turning a concrete function into an abstract function (with a default result) +abstract :: (a :-> c) -> c -> (a -> c) +abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy +abstract (Unit c) _ _ = c +abstract Nil d _ = d +abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d]) +abstract (Map g _ p) d x = abstract p d (g x) + +-- generating a table from a concrete function +table :: (a :-> c) -> [(a,c)] +table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ] +table (p :+: q) = [ (Left x, c) | (x,c) <- table p ] + ++ [ (Right y,c) | (y,c) <- table q ] +table (Unit c) = [ ((), c) ] +table Nil = [] +table (Table xys) = xys +table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] + +-------------------------------------------------------------------------- +-- Function + +-- | The class @Function a@ is used for random generation of showable +-- functions of type @a -> b@. +-- +-- There is a default implementation for 'function', which you can use +-- if your type has structural equality. Otherwise, you can normally +-- use 'functionMap' or 'functionShow'. +class Function a where + function :: (a->b) -> (a:->b) +#ifndef NO_GENERICS + default function :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) + function = genericFunction +#endif + +-- basic instances + +-- | Provides a 'Function' instance for types with 'Bounded' and 'Enum'. +-- Use only for small types (i.e. not integers): creates +-- the list @['minBound'..'maxBound']@! +functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b) +functionBoundedEnum f = Table [(x,f x) | x <- [minBound..maxBound]] + +-- | Provides a 'Function' instance for types with 'RealFrac'. +functionRealFrac :: RealFrac a => (a->b) -> (a:->b) +functionRealFrac = functionMap toRational fromRational + +-- | Provides a 'Function' instance for types with 'Integral'. +functionIntegral :: Integral a => (a->b) -> (a:->b) +functionIntegral = functionMap fromIntegral fromInteger + +-- | Provides a 'Function' instance for types with 'Show' and 'Read'. +functionShow :: (Show a, Read a) => (a->c) -> (a:->c) +functionShow f = functionMap show read f + +-- | Provides a 'Function' instance for types isomorphic to 'Data.Void.Void'. +-- +-- An actual @'Function' 'Data.Void.Void'@ instance is defined in +-- @quickcheck-instances@. +functionVoid :: (forall b. void -> b) -> void :-> c +functionVoid _ = Nil + +-- | The basic building block for 'Function' instances. +-- Provides a 'Function' instance by mapping to and from a type that +-- already has a 'Function' instance. +functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) +functionMap = functionMapWith function + +-- | @since 2.13.3 +functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) +functionMapWith function g h f = Map g h (function (\b -> f (h b))) + +instance Function () where + function f = Unit (f ()) + +instance Function a => Function (Const a b) where + function = functionMap getConst Const + +instance Function a => Function (Identity a) where + function = functionMap runIdentity Identity + +instance (Function a, Function b) => Function (a,b) where + function = functionPairWith function function + +-- | @since 2.13.3 +functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) +functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) + +instance (Function a, Function b) => Function (Either a b) where + function = functionEitherWith function function + +-- | @since 2.13.3 +functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) +functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (f . Right) + +-- tuple convenience instances + +instance (Function a, Function b, Function c) => Function (a,b,c) where + function = functionMap (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c)) + +instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where + function = functionMap (\(a,b,c,d) -> (a,(b,c,d))) (\(a,(b,c,d)) -> (a,b,c,d)) + +instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where + function = functionMap (\(a,b,c,d,e) -> (a,(b,c,d,e))) (\(a,(b,c,d,e)) -> (a,b,c,d,e)) + +instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where + function = functionMap (\(a,b,c,d,e,f) -> (a,(b,c,d,e,f))) (\(a,(b,c,d,e,f)) -> (a,b,c,d,e,f)) + +instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where + function = functionMap (\(a,b,c,d,e,f,g) -> (a,(b,c,d,e,f,g))) (\(a,(b,c,d,e,f,g)) -> (a,b,c,d,e,f,g)) + +-- other instances + +instance Function a => Function [a] where + function = functionMap g h + where + g [] = Left () + g (x:xs) = Right (x,xs) + + h (Left _) = [] + h (Right (x,xs)) = x:xs + +instance Function a => Function (Maybe a) where + function = functionMap g h + where + g Nothing = Left () + g (Just x) = Right x + + h (Left _) = Nothing + h (Right x) = Just x + +instance Function Bool where + function = functionMap g h + where + g False = Left () + g True = Right () + + h (Left _) = False + h (Right _) = True + +instance Function Integer where + function = functionMap gInteger hInteger + where + gInteger n | n < 0 = Left (gNatural (abs n - 1)) + | otherwise = Right (gNatural n) + + hInteger (Left ws) = -(hNatural ws + 1) + hInteger (Right ws) = hNatural ws + + gNatural 0 = [] + gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256) + + hNatural [] = 0 + hNatural (w:ws) = fromIntegral w + 256 * hNatural ws + +instance Function Int where + function = functionIntegral + +instance Function Word where + function = functionIntegral + +instance Function Char where + function = functionMap ord chr + +instance Function Float where + function = functionRealFrac + +instance Function Double where + function = functionRealFrac + +-- instances for assorted types in the base package + +instance Function Ordering where + function = functionMap g h + where + g LT = Left False + g EQ = Left True + g GT = Right () + + h (Left False) = LT + h (Left True) = EQ + h (Right _) = GT + +instance (Integral a, Function a) => Function (Ratio a) where + function = functionMap g h + where + g r = (numerator r, denominator r) + h (n, d) = n % d + +#ifndef NO_FIXED +instance HasResolution a => Function (Fixed a) where + function = functionRealFrac +#endif + +instance (RealFloat a, Function a) => Function (Complex a) where + function = functionMap g h + where + g (x :+ y) = (x, y) + h (x, y) = x :+ y + +instance (Ord a, Function a) => Function (Set.Set a) where + function = functionMap Set.toList Set.fromList + +instance (Ord a, Function a, Function b) => Function (Map.Map a b) where + function = functionMap Map.toList Map.fromList + +instance Function IntSet.IntSet where + function = functionMap IntSet.toList IntSet.fromList + +instance Function a => Function (IntMap.IntMap a) where + function = functionMap IntMap.toList IntMap.fromList + +instance Function a => Function (Sequence.Seq a) where + function = functionMap toList Sequence.fromList + +instance Function Int8 where + function = functionBoundedEnum + +instance Function Int16 where + function = functionIntegral + +instance Function Int32 where + function = functionIntegral + +instance Function Int64 where + function = functionIntegral + +instance Function Word8 where + function = functionBoundedEnum + +instance Function Word16 where + function = functionIntegral + +instance Function Word32 where + function = functionIntegral + +instance Function Word64 where + function = functionIntegral + +-- instances for Data.Monoid newtypes + +instance Function a => Function (Monoid.Dual a) where + function = functionMap Monoid.getDual Monoid.Dual + +instance Function Monoid.All where + function = functionMap Monoid.getAll Monoid.All + +instance Function Monoid.Any where + function = functionMap Monoid.getAny Monoid.Any + +instance Function a => Function (Monoid.Sum a) where + function = functionMap Monoid.getSum Monoid.Sum + +instance Function a => Function (Monoid.Product a) where + function = functionMap Monoid.getProduct Monoid.Product + +instance Function a => Function (Monoid.First a) where + function = functionMap Monoid.getFirst Monoid.First + +instance Function a => Function (Monoid.Last a) where + function = functionMap Monoid.getLast Monoid.Last + +#if MIN_VERSION_base(4,8,0) +instance Function (f a) => Function (Monoid.Alt f a) where + function = functionMap Monoid.getAlt Monoid.Alt +#endif + +-- poly instances + +instance Function A where + function = functionMap unA A + +instance Function B where + function = functionMap unB B + +instance Function C where + function = functionMap unC C + +instance Function OrdA where + function = functionMap unOrdA OrdA + +instance Function OrdB where + function = functionMap unOrdB OrdB + +instance Function OrdC where + function = functionMap unOrdC OrdC + +-- instance Arbitrary + +instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where + arbitrary = function `fmap` arbitrary + shrink = shrinkFun shrink + +-------------------------------------------------------------------------- +-- generic function instances + +#ifndef NO_GENERICS +-- | Generic 'Function' implementation. +genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) +genericFunction = functionMapWith gFunction from to + +class GFunction f where + gFunction :: (f a -> b) -> (f a :-> b) + +instance GFunction U1 where + gFunction = functionMap (\U1 -> ()) (\() -> U1) + +instance (GFunction f, GFunction g) => GFunction (f :*: g) where + gFunction = functionMapWith (functionPairWith gFunction gFunction) g h + where + g (x :*: y) = (x, y) + h (x, y) = x :*: y + +instance (GFunction f, GFunction g) => GFunction (f :+: g) where + gFunction = functionMapWith (functionEitherWith gFunction gFunction) g h + where + g (L1 x) = Left x + g (R1 x) = Right x + h (Left x) = L1 x + h (Right x) = R1 x + +instance GFunction f => GFunction (M1 i c f) where + gFunction = functionMapWith gFunction (\(M1 x) -> x) M1 + +instance Function a => GFunction (K1 i a) where + gFunction = functionMap (\(K1 x) -> x) K1 +#endif + +-------------------------------------------------------------------------- +-- shrinking + +shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] +shrinkFun shr (Pair p) = + [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] + where + pair Nil = Nil + pair p = Pair p + +shrinkFun shr (p :+: q) = + [ p .+. Nil | not (isNil q) ] ++ + [ Nil .+. q | not (isNil p) ] ++ + [ p .+. q' | q' <- shrinkFun shr q ] ++ + [ p' .+. q | p' <- shrinkFun shr p ] + where + isNil :: (a :-> b) -> Bool + isNil Nil = True + isNil _ = False + + Nil .+. Nil = Nil + p .+. q = p :+: q + +shrinkFun shr (Unit c) = + [ Nil ] ++ + [ Unit c' | c' <- shr c ] + +shrinkFun shr (Table xys) = + [ table xys' | xys' <- shrinkList shrXy xys ] + where + shrXy (x,y) = [(x,y') | y' <- shr y] + + table [] = Nil + table xys = Table xys + +shrinkFun shr Nil = + [] + +shrinkFun shr (Map g h p) = + [ mapp g h p' | p' <- shrinkFun shr p ] + where + mapp g h Nil = Nil + mapp g h p = Map g h p + +-------------------------------------------------------------------------- +-- the Fun modifier + +-- | Generation of random shrinkable, showable functions. +-- +-- To generate random values of type @'Fun' a b@, +-- you must have an instance @'Function' a@. +-- +-- See also 'applyFun', and 'Fn' with GHC >= 7.8. +data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) +data Shrunk = Shrunk | NotShrunk deriving Eq + +instance Functor (Fun a) where + fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g) + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +-- | A modifier for testing functions. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop (Fn f) = f "banana" == f "monkey" +-- > || f "banana" == f "elephant" +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn :: (a -> b) -> Fun a b +#endif +pattern Fn f <- (applyFun -> f) + +-- | A modifier for testing binary functions. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c +#endif +pattern Fn2 f <- (applyFun2 -> f) + +-- | A modifier for testing ternary functions. +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d +#endif +pattern Fn3 f <- (applyFun3 -> f) +#endif + +mkFun :: (a :-> b) -> b -> Fun a b +mkFun p d = Fun (p, d, NotShrunk) (abstract p d) + +-- | Alias to 'applyFun'. +apply :: Fun a b -> (a -> b) +apply = applyFun + +-- | Extracts the value of a function. +-- +-- 'Fn' is the pattern equivalent of this function. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop f = applyFun f "banana" == applyFun f "monkey" +-- > || applyFun f "banana" == applyFun f "elephant" +applyFun :: Fun a b -> (a -> b) +applyFun (Fun _ f) = f + +-- | Extracts the value of a binary function. +-- +-- 'Fn2' is the pattern equivalent of this function. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] +-- +applyFun2 :: Fun (a, b) c -> (a -> b -> c) +applyFun2 (Fun _ f) a b = f (a, b) + +-- | Extracts the value of a ternary function. 'Fn3' is the +-- pattern equivalent of this function. +applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) +applyFun3 (Fun _ f) a b c = f (a, b, c) + +instance (Show a, Show b) => Show (Fun a b) where + show (Fun (_, _, NotShrunk) _) = "" + 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,352 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +-- | Test case generation. +-- +-- __Note__: the contents of this module (except for the definition of +-- 'Gen') are re-exported by "Test.QuickCheck". You probably do not +-- need to import it directly. +module Test.QuickCheck.Gen where + +-------------------------------------------------------------------------- +-- imports + +import System.Random + ( Random + , random + , randomR + , split + ) + +import Control.Monad + ( ap + , replicateM + , filterM + ) + +import Control.Monad.Fix + ( MonadFix(..) ) + +import Control.Applicative + ( Applicative(..) ) + +import Test.QuickCheck.Random +import Data.List +import Data.Ord +import Data.Maybe +#ifndef NO_SPLITMIX +import System.Random.SplitMix(bitmaskWithRejection64', SMGen, nextInteger) +#endif +import Data.Word +import Data.Int +import Data.Bits +import Control.Applicative + +-------------------------------------------------------------------------- +-- ** Generator type + +-- | A generator for values of type @a@. +-- +-- The third-party packages +-- +-- and +-- +-- provide monad transformer versions of @Gen@. +newtype Gen a = MkGen{ + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. + -- If you just want to get a random value out, consider using 'generate'. + } + +instance Functor Gen where + fmap f (MkGen h) = + MkGen (\r n -> f (h r n)) + +instance Applicative Gen where + pure x = + MkGen (\_ _ -> x) + (<*>) = ap + +#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE + -- We don't need to split the seed for these. + _ *> m = m + m <* _ = m +#endif + +instance Monad Gen where + return = pure + + MkGen m >>= k = + MkGen (\r n -> + case split r of + (r1, r2) -> + let MkGen m' = k (m r1 n) + in m' r2 n + ) + + (>>) = (*>) + +instance MonadFix Gen where + mfix f = + MkGen $ \r n -> + let a = unGen (f a) r n + in a + +-------------------------------------------------------------------------- +-- ** Primitive generator combinators + +-- | Modifies a generator using an integer seed. +variant :: Integral n => n -> Gen a -> Gen a +variant k (MkGen g) = MkGen (\r n -> g (integerVariant (toInteger k) $! r) n) + +-- | Used to construct generators that depend on the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = sized $ \n -> +-- > do k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'getSize'. +sized :: (Int -> Gen a) -> Gen a +sized f = MkGen (\r n -> let MkGen m = f n in m r n) + +-- | Returns the size parameter. Used to construct generators that depend on +-- the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = do +-- > n <- getSize +-- > k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'sized'. +getSize :: Gen Int +getSize = sized pure + +-- | Overrides the size parameter. Returns a generator which uses +-- the given size instead of the runtime-size parameter. +resize :: Int -> Gen a -> Gen a +resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" +resize n (MkGen g) = MkGen (\r _ -> g r n) + +-- | Adjust the size parameter, by transforming it with the given +-- function. +scale :: (Int -> Int) -> Gen a -> Gen a +scale f g = sized (\n -> resize (f n) g) + +-- | Generates a random element in the given inclusive range. +-- For integral and enumerated types, the specialised variants of +-- 'choose' below run much quicker. +choose :: Random a => (a,a) -> Gen a +choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) + +-- | Generates a random element over the natural range of `a`. +chooseAny :: Random a => Gen a +chooseAny = MkGen (\r _ -> let (x,_) = random r in x) + +-- | A fast implementation of 'choose' for enumerated types. +chooseEnum :: Enum a => (a, a) -> Gen a +chooseEnum (lo, hi) = + fmap toEnum (chooseInt (fromEnum lo, fromEnum hi)) + +-- | A fast implementation of 'choose' for 'Int'. +chooseInt :: (Int, Int) -> Gen Int +chooseInt = chooseBoundedIntegral + +-- Note about INLINEABLE: we specialise chooseBoundedIntegral +-- for each concrete type, so that all the bounds checks get +-- simplified away. +{-# INLINEABLE chooseBoundedIntegral #-} +-- | A fast implementation of 'choose' for bounded integral types. +chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a +chooseBoundedIntegral (lo, hi) +#ifndef NO_SPLITMIX + | toInteger mn >= toInteger (minBound :: Int64) && + toInteger mx <= toInteger (maxBound :: Int64) = + fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi)) + | toInteger mn >= toInteger (minBound :: Word64) && + toInteger mx <= toInteger (maxBound :: Word64) = + fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi)) +#endif + | otherwise = + fmap fromInteger (chooseInteger (toInteger lo, toInteger hi)) +#ifndef NO_SPLITMIX + where + mn = minBound `asTypeOf` lo + mx = maxBound `asTypeOf` hi +#endif + +-- | A fast implementation of 'choose' for 'Integer'. +chooseInteger :: (Integer, Integer) -> Gen Integer +#ifdef NO_SPLITMIX +chooseInteger = choose +#else +chooseInteger (lo, hi) + | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) && + hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) = + fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi)) + | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) && + hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) = + fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi)) + | otherwise = MkGen $ \(QCGen g) _ -> fst (nextInteger lo hi g) + +chooseWord64 :: (Word64, Word64) -> Gen Word64 +chooseWord64 (lo, hi) + | lo <= hi = chooseWord64' (lo, hi) + | otherwise = chooseWord64' (hi, lo) + where + chooseWord64' :: (Word64, Word64) -> Gen Word64 + chooseWord64' (lo, hi) = + fmap (+ lo) (chooseUpTo (hi - lo)) + +chooseInt64 :: (Int64, Int64) -> Gen Int64 +chooseInt64 (lo, hi) + | lo <= hi = chooseInt64' (lo, hi) + | otherwise = chooseInt64' (hi, lo) + where + chooseInt64' :: (Int64, Int64) -> Gen Int64 + chooseInt64' (lo, hi) = do + w <- chooseUpTo (fromIntegral hi - fromIntegral lo) + return (fromIntegral (w + fromIntegral lo)) + +chooseUpTo :: Word64 -> Gen Word64 +chooseUpTo n = + MkGen $ \(QCGen g) _ -> + fst (bitmaskWithRejection64' n g) +#endif + +-- | Run a generator. The size passed to the generator is always 30; +-- if you want another size then you should explicitly use 'resize'. +generate :: Gen a -> IO a +generate (MkGen g) = + do r <- newQCGen + return (g r 30) + +-- | Generates some example values. +sample' :: Gen a -> IO [a] +sample' g = + generate (sequence [ resize n g | n <- [0,2..20] ]) + +-- | Generates some example values and prints them to 'stdout'. +sample :: Show a => Gen a -> IO () +sample g = + do cases <- sample' g + mapM_ print cases + +-------------------------------------------------------------------------- +-- ** Common generator combinators + +-- | Generates a value that satisfies a predicate. +suchThat :: Gen a -> (a -> Bool) -> Gen a +gen `suchThat` p = + do mx <- gen `suchThatMaybe` p + case mx of + Just x -> return x + Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) + +-- | Generates a value for which the given function returns a 'Just', and then +-- applies the function. +suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b +gen `suchThatMap` f = + fmap fromJust $ fmap f gen `suchThat` isJust + +-- | Tries to generate a value that satisfies a predicate. +-- If it fails to do so after enough attempts, returns @Nothing@. +suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) +gen `suchThatMaybe` p = sized (\n -> try n (2*n)) + where + try m n + | m > n = return Nothing + | otherwise = do + x <- resize m gen + if p x then return (Just x) else try (m+1) n + +-- | Randomly uses one of the given generators. The input list +-- must be non-empty. +oneof :: [Gen a] -> Gen a +oneof [] = error "QuickCheck.oneof used with empty list" +oneof gs = chooseInt (0,length gs - 1) >>= (gs !!) + +-- | Chooses one of the given generators, with a weighted random distribution. +-- The input list must be non-empty. +frequency :: [(Int, Gen a)] -> Gen a +frequency [] = error "QuickCheck.frequency used with empty list" +frequency xs + | any (< 0) (map fst xs) = + error "QuickCheck.frequency: negative weight" + | all (== 0) (map fst xs) = + error "QuickCheck.frequency: all weights were zero" +frequency xs0 = chooseInt (1, tot) >>= (`pick` xs0) + where + tot = sum (map fst xs0) + + pick n ((k,x):xs) + | n <= k = x + | otherwise = pick (n-k) xs + pick _ _ = error "QuickCheck.pick used with empty list" + +-- | Generates one of the given values. The input list must be non-empty. +elements :: [a] -> Gen a +elements [] = error "QuickCheck.elements used with empty list" +elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) + +-- | Generates a random subsequence of the given list. +sublistOf :: [a] -> Gen [a] +sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs + +-- | Generates a random permutation of the given list. +shuffle :: [a] -> Gen [a] +shuffle xs = do + ns <- vectorOf (length xs) (chooseInt (minBound :: Int, maxBound)) + return (map snd (sortBy (comparing fst) (zip ns xs))) + +-- | Takes a list of elements of increasing size, and chooses +-- among an initial segment of the list. The size of this initial +-- segment increases with the size parameter. +-- The input list must be non-empty. +growingElements :: [a] -> Gen a +growingElements [] = error "QuickCheck.growingElements used with empty list" +growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) + where + k = length xs + mx = 100 + log' = round . log . toDouble + size n = (log' n + 1) * k `div` log' mx + toDouble = fromIntegral :: Int -> Double + +{- WAS: +growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) + where + k = length xs +-} + +-- | Generates a list of random length. The maximum length depends on the +-- size parameter. +listOf :: Gen a -> Gen [a] +listOf gen = sized $ \n -> + do k <- chooseInt (0,n) + vectorOf k gen + +-- | Generates a non-empty list of random length. The maximum length +-- depends on the size parameter. +listOf1 :: Gen a -> Gen [a] +listOf1 gen = sized $ \n -> + do k <- chooseInt (1,1 `max` n) + vectorOf k gen + +-- | Generates a list of the given length. +vectorOf :: Int -> Gen a -> Gen [a] +vectorOf = replicateM + +-- | Generates an infinite list. +infiniteListOf :: Gen a -> Gen [a] +infiniteListOf gen = sequence (repeat gen) + +-------------------------------------------------------------------------- +-- the end. 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,54 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +-- | Unsafe combinators for the 'Gen' monad. +-- +-- 'Gen' is only morally a monad: two generators that are supposed +-- to be equal will give the same probability distribution, but they +-- might be different as functions from random number seeds to values. +-- QuickCheck maintains the illusion that a 'Gen' is a probability +-- distribution and does not allow you to distinguish two generators +-- that have the same distribution. +-- +-- The functions in this module allow you to break this illusion by +-- reusing the same random number seed twice. This is unsafe because +-- by applying the same seed to two morally equal generators, you can +-- see whether they are really equal or not. +module Test.QuickCheck.Gen.Unsafe where + +import Test.QuickCheck.Gen +import Control.Monad + +-- | Promotes a monadic generator to a generator of monadic values. +promote :: Monad m => m (Gen a) -> Gen (m a) +promote m = do + eval <- delay + return (liftM eval m) + +-- | Randomly generates a function of type @'Gen' a -> a@, which +-- you can then use to evaluate generators. Mostly useful in +-- implementing 'promote'. +delay :: Gen (Gen a -> a) +delay = MkGen (\r n g -> unGen g r n) + +#ifndef NO_ST_MONAD +-- | A variant of 'delay' that returns a polymorphic evaluation function. +-- Can be used in a pinch to generate polymorphic (rank-2) values: +-- +-- > genSelector :: Gen (a -> a -> a) +-- > genSelector = elements [\x y -> x, \x y -> y] +-- > +-- > data Selector = Selector (forall a. a -> a -> a) +-- > genPolySelector :: Gen Selector +-- > genPolySelector = do +-- > Capture eval <- capture +-- > return (Selector (eval genSelector)) +capture :: Gen Capture +capture = MkGen (\r n -> Capture (\g -> unGen g r n)) + +newtype Capture = Capture (forall a. Gen a -> a) +#endif 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,531 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +#ifndef NO_MULTI_PARAM_TYPE_CLASSES +{-# LANGUAGE MultiParamTypeClasses #-} +#endif +#ifndef NO_NEWTYPE_DERIVING +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif +-- | Modifiers for test data. +-- +-- These types do things such as restricting the kind of test data that can be generated. +-- They can be pattern-matched on in properties as a stylistic +-- alternative to using explicit quantification. +-- +-- __Note__: the contents of this module are re-exported by +-- "Test.QuickCheck". You do not need to import it directly. +-- +-- Examples: +-- +-- @ +-- -- Functions cannot be shown (but see "Test.QuickCheck.Function") +-- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = +-- takeWhile p xs ++ dropWhile p xs == xs +-- @ +-- +-- @ +-- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = +-- take n xs ++ drop n xs == xs +-- @ +-- +-- @ +-- -- cycle does not work for empty lists +-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = +-- take n (cycle xs) == take n (xs ++ cycle xs) +-- @ +-- +-- @ +-- -- Instead of 'forAll' 'orderedList' +-- prop_Sort ('Ordered' (xs :: ['OrdA'])) = +-- sort xs == xs +-- @ +module Test.QuickCheck.Modifiers + ( + -- ** Type-level modifiers for changing generator behavior + Blind(..) + , Fixed(..) + , OrderedList(..) + , NonEmptyList(..) + , InfiniteList(..) + , SortedList(..) + , Positive(..) + , Negative(..) + , NonZero(..) + , NonNegative(..) + , NonPositive(..) + , Large(..) + , Small(..) + , Smart(..) + , Shrink2(..) +#ifndef NO_MULTI_PARAM_TYPE_CLASSES + , Shrinking(..) + , ShrinkState(..) +#endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Exception + +import Data.List + ( sort + ) +import Data.Ix (Ix) + +#ifndef NO_TYPEABLE +import Data.Typeable (Typeable) +#endif + +-------------------------------------------------------------------------- +-- | @Blind x@: as x, but x does not have to be in the 'Show' class. +newtype Blind a = Blind {getBlind :: a} + deriving ( Eq, Ord +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Blind where + fmap f (Blind x) = Blind (f x) + +instance Show (Blind a) where + show _ = "(*)" + +instance Arbitrary a => Arbitrary (Blind a) where + arbitrary = Blind `fmap` arbitrary + + shrink (Blind x) = [ Blind x' | x' <- shrink x ] + +-------------------------------------------------------------------------- +-- | @Fixed x@: as x, but will not be shrunk. +newtype Fixed a = Fixed {getFixed :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Fixed where + fmap f (Fixed x) = Fixed (f x) + +instance Arbitrary a => Arbitrary (Fixed a) where + arbitrary = Fixed `fmap` arbitrary + + -- no shrink function + +-------------------------------------------------------------------------- +-- | @Ordered xs@: guarantees that xs is ordered. +newtype OrderedList a = Ordered {getOrdered :: [a]} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor OrderedList where + fmap f (Ordered x) = Ordered (map f x) + +instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where + arbitrary = Ordered `fmap` orderedList + + shrink (Ordered xs) = + [ Ordered xs' + | xs' <- shrink xs + , sort xs' == xs' + ] + +-------------------------------------------------------------------------- +-- | @NonEmpty xs@: guarantees that xs is non-empty. +newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NonEmptyList where + fmap f (NonEmpty x) = NonEmpty (map f x) + +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) + + shrink (NonEmpty xs) = + [ NonEmpty xs' + | xs' <- shrink xs + , not (null xs') + ] + +---------------------------------------------------------------------- +-- | @InfiniteList xs _@: guarantees that xs is an infinite list. +-- When a counterexample is found, only prints the prefix of xs +-- that was used by the program. +-- +-- Here is a contrived example property: +-- +-- > prop_take_10 :: InfiniteList Char -> Bool +-- > prop_take_10 (InfiniteList xs _) = +-- > or [ x == 'a' | x <- take 10 xs ] +-- +-- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but +-- the remaining (infinite) part can contain anything: +-- +-- >>> quickCheck prop_take_10 +-- *** Failed! Falsified (after 1 test and 14 shrinks): +-- "bbbbbbbbbb" ++ ... +data InfiniteList a = + InfiniteList { + getInfiniteList :: [a], + infiniteListInternalData :: InfiniteListInternalData a } + +-- Uses a similar trick to Test.QuickCheck.Function: +-- the Arbitrary instance generates an infinite list, which is +-- reduced to a finite prefix by shrinking. We use discard to +-- check that nothing coming after the finite prefix is used +-- (see infiniteListFromData). +data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] + +infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a +infiniteListFromData info@(Infinite xs) = InfiniteList xs info +infiniteListFromData info@(FinitePrefix xs) = + InfiniteList (xs ++ discard) info + +instance Show a => Show (InfiniteList a) where + showsPrec _ (InfiniteList _ (Infinite _)) = + ("" ++) + showsPrec n (InfiniteList _ (FinitePrefix xs)) = + (if n > 10 then ('(':) else id) . + showsPrec 0 xs . + (" ++ ..." ++) . + (if n > 10 then (')':) else id) + +instance Arbitrary a => Arbitrary (InfiniteList a) where + arbitrary = fmap infiniteListFromData arbitrary + shrink (InfiniteList _ info) = + map infiniteListFromData (shrink info) + +instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where + arbitrary = fmap Infinite infiniteList + shrink (Infinite xs) = + [FinitePrefix (take n xs) | n <- map (2^) [0..]] + shrink (FinitePrefix xs) = + map FinitePrefix (shrink xs) + +-------------------------------------------------------------------------- +-- | @Sorted xs@: guarantees that xs is sorted. +newtype SortedList a = Sorted {getSorted :: [a]} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor SortedList where + fmap f (Sorted x) = Sorted (map f x) + +instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where + arbitrary = fmap (Sorted . sort) arbitrary + + shrink (Sorted xs) = + [ Sorted xs' + | xs' <- map sort (shrink xs) + ] + +-------------------------------------------------------------------------- +-- | @Positive x@: guarantees that @x \> 0@. +newtype Positive a = Positive {getPositive :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Positive where + fmap f (Positive x) = Positive (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where + arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) + shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] + +-------------------------------------------------------------------------- +-- | @Negative x@: guarantees that @x \< 0@. +newtype Negative a = Negative {getNegative :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Negative where + fmap f (Negative x) = Negative (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where + arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) + shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] + +-------------------------------------------------------------------------- +-- | @NonZero x@: guarantees that @x \/= 0@. +newtype NonZero a = NonZero {getNonZero :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NonZero where + fmap f (NonZero x) = NonZero (f x) + +instance (Num a, Eq a, Arbitrary a) => Arbitrary (NonZero a) where + arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) + + shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] + +-------------------------------------------------------------------------- +-- | @NonNegative x@: guarantees that @x \>= 0@. +newtype NonNegative a = NonNegative {getNonNegative :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NonNegative where + fmap f (NonNegative x) = NonNegative (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where + arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0)) + shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] + +-------------------------------------------------------------------------- +-- | @NonPositive x@: guarantees that @x \<= 0@. +newtype NonPositive a = NonPositive {getNonPositive :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NonPositive where + fmap f (NonPositive x) = NonPositive (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where + arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0)) + shrink (NonPositive x) = [ NonPositive x' | x' <- shrink x , x' <= 0 ] + +-------------------------------------------------------------------------- +-- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small +-- range. @Large Int@ gives you values drawn from the entire range instead. +newtype Large a = Large {getLarge :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Large where + fmap f (Large x) = Large (f x) + +instance (Integral a, Bounded a) => Arbitrary (Large a) where + arbitrary = fmap Large arbitrarySizedBoundedIntegral + shrink (Large x) = fmap Large (shrinkIntegral x) + +-------------------------------------------------------------------------- +-- | @Small x@: generates values of @x@ drawn from a small range. +-- The opposite of 'Large'. +newtype Small a = Small {getSmall :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Small where + fmap f (Small x) = Small (f x) + +instance Integral a => Arbitrary (Small a) where + arbitrary = fmap Small arbitrarySizedIntegral + shrink (Small x) = map Small (shrinkIntegral x) + +-------------------------------------------------------------------------- +-- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x +newtype Shrink2 a = Shrink2 {getShrink2 :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor Shrink2 where + fmap f (Shrink2 x) = Shrink2 (f x) + +instance Arbitrary a => Arbitrary (Shrink2 a) where + arbitrary = + Shrink2 `fmap` arbitrary + + shrink (Shrink2 x) = + [ Shrink2 y | y <- shrink_x ] ++ + [ Shrink2 z + | y <- shrink_x + , z <- shrink y + ] + where + shrink_x = shrink x + +-------------------------------------------------------------------------- +-- | @Smart _ x@: tries a different order when shrinking. +data Smart a = + Smart Int a + +instance Functor Smart where + fmap f (Smart n x) = Smart n (f x) + +instance Show a => Show (Smart a) where + showsPrec n (Smart _ x) = showsPrec n x + +instance Arbitrary a => Arbitrary (Smart a) where + arbitrary = + do x <- arbitrary + return (Smart 0 x) + + shrink (Smart i x) = take i' ys `ilv` drop i' ys + where + ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] + i' = 0 `max` (i-2) + + [] `ilv` bs = bs + as `ilv` [] = as + (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) + +{- + shrink (Smart i x) = part0 ++ part2 ++ part1 + where + ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] + i' = 0 `max` (i-2) + k = i `div` 10 + + part0 = take k ys + part1 = take (i'-k) (drop k ys) + part2 = drop i' ys +-} + + -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 + -- take a (take b xs) == take (a `min` b) xs + -- take a xs ++ drop a xs == xs + + -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys + -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) + -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) + -- == take k ys ++ drop k ys + -- == ys + +#ifndef NO_MULTI_PARAM_TYPE_CLASSES +-------------------------------------------------------------------------- +-- | @Shrinking _ x@: allows for maintaining a state during shrinking. +data Shrinking s a = + Shrinking s a + +class ShrinkState s a where + shrinkInit :: a -> s + shrinkState :: a -> s -> [(a,s)] + +instance Functor (Shrinking s) where + fmap f (Shrinking s x) = Shrinking s (f x) + +instance Show a => Show (Shrinking s a) where + showsPrec n (Shrinking _ x) = showsPrec n x + +instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where + arbitrary = + do x <- arbitrary + return (Shrinking (shrinkInit x) x) + + shrink (Shrinking s x) = + [ Shrinking s' x' + | (x',s') <- shrinkState x s + ] + +#endif /* NO_MULTI_PARAM_TYPE_CLASSES */ + +-------------------------------------------------------------------------- +-- | @ASCIIString@: generates an ASCII string. +newtype ASCIIString = ASCIIString {getASCIIString :: String} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Arbitrary ASCIIString where + arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar + shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @UnicodeString@: generates a unicode String. +-- The string will not contain surrogate pairs. +newtype UnicodeString = UnicodeString {getUnicodeString :: String} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Arbitrary UnicodeString where + arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar + shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @PrintableString@: generates a printable unicode String. +-- The string will not contain surrogate pairs. +newtype PrintableString = PrintableString {getPrintableString :: String} + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Arbitrary PrintableString where + arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar + shrink (PrintableString xs) = PrintableString `fmap` shrink xs + +-- the end. 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,279 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif +#endif +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +{-| +Module : Test.QuickCheck.Monadic + +Allows testing of monadic values. Will generally follow this form: + +@ +prop_monadic a b = 'monadicIO' $ do + a\' \<- 'run' (f a) + b\' \<- 'run' (f b) + -- ... + 'assert' someBoolean +@ + +Example using the @FACTOR(1)@ command-line utility: + +@ +import System.Process +import Test.QuickCheck +import Test.QuickCheck.Monadic + +-- $ factor 16 +-- 16: 2 2 2 2 +factor :: Integer -> IO [Integer] +factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where + + parse :: String -> [Integer] + parse = map read . tail . words + +prop_factor :: Positive Integer -> Property +prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do + factors \<- 'run' (factor n) + + 'assert' (product factors == n) +@ + +>>> quickCheck prop_factor ++++ OK, passed 100 tests. + +See the paper \"\". +-} +module Test.QuickCheck.Monadic ( + -- * Property monad + PropertyM(..) + + -- * Monadic specification combinators + , run + , assert + , pre + , wp + , pick + , forAllM + , monitor + , stop + + -- * Run functions + , monadic + , monadic' + , monadicIO +#ifndef NO_ST_MONAD + , monadicST + , runSTGen +#endif + ) where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe +import Test.QuickCheck.Property + +import Control.Monad(liftM, liftM2) + +import Control.Monad.ST +import Control.Applicative + +#ifndef NO_TRANSFORMERS +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +#endif + +#ifndef NO_MONADFAIL +import qualified Control.Monad.Fail as Fail +#endif + +-------------------------------------------------------------------------- +-- type PropertyM + +-- | The property monad is really a monad transformer that can contain +-- monadic computations in the monad @m@ it is parameterized by: +-- +-- * @m@ - the @m@-computations that may be performed within @PropertyM@ +-- +-- Elements of @PropertyM m a@ may mix property operations and @m@-computations. +newtype PropertyM m a = + MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } + +bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b +MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) + +fail_ :: Monad m => String -> PropertyM m a +fail_ s = stop (failed { reason = s }) + +instance Functor (PropertyM m) where + fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) + +instance Applicative (PropertyM m) where + pure x = MkPropertyM (\k -> k x) + mf <*> mx = + mf `bind` \f -> mx `bind` \x -> pure (f x) + +instance Monad m => Monad (PropertyM m) where + return = pure + (>>=) = bind +#if !MIN_VERSION_base(4,13,0) + fail = fail_ +#endif + +#ifndef NO_MONADFAIL +instance Monad m => Fail.MonadFail (PropertyM m) where + fail = fail_ +#endif + +#ifndef NO_TRANSFORMERS +instance MonadTrans PropertyM where + lift = run + +instance MonadIO m => MonadIO (PropertyM m) where + liftIO = run . liftIO +#endif + +stop :: (Testable prop, Monad m) => prop -> PropertyM m a +stop p = MkPropertyM (\_k -> return (return (property p))) + +-- should think about strictness/exceptions here +-- assert :: Testable prop => prop -> PropertyM m () +-- | Allows embedding non-monadic properties into monadic ones. +assert :: Monad m => Bool -> PropertyM m () +assert True = return () +assert False = fail "Assertion failed" + +-- should think about strictness/exceptions here +-- | Tests preconditions. Unlike 'assert' this does not cause the +-- property to fail, rather it discards them just like using the +-- implication combinator 'Test.QuickCheck.Property.==>'. +-- +-- This allows representing the +-- +-- > {p} x ← e{q} +-- +-- as +-- +-- @ +-- pre p +-- x \<- run e +-- assert q +-- @ +-- +pre :: Monad m => Bool -> PropertyM m () +pre True = return () +pre False = stop rejected + +-- should be called lift? +-- | The lifting operation of the property monad. Allows embedding +-- monadic\/'IO'-actions in properties: +-- +-- @ +-- log :: Int -> IO () +-- +-- prop_foo n = monadicIO $ do +-- run (log n) +-- -- ... +-- @ +run :: Monad m => m a -> PropertyM m a +run m = MkPropertyM (liftM (m >>=) . promote) + +-- | Quantification in a monadic property, fits better with +-- /do-notation/ than 'forAllM'. +-- __Note__: values generated by 'pick' do not shrink. +pick :: (Monad m, Show a) => Gen a -> PropertyM m a +pick gen = MkPropertyM $ \k -> + do a <- gen + mp <- k a + return (do p <- mp + return (forAll (return a) (const p))) + +-- | The +-- +-- > wp(x ← e, p) +-- +-- can be expressed as in code as @wp e (\\x -> p)@. +wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b +wp m k = run m >>= k + +-- | Quantification in monadic properties to 'pick', with a notation similar to +-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. + +forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b +forAllM gen k = pick gen >>= k + +-- | Allows making observations about the test data: +-- +-- @ +-- monitor ('collect' e) +-- @ +-- +-- collects the distribution of value of @e@. +-- +-- @ +-- monitor ('counterexample' "Failure!") +-- @ +-- +-- Adds @"Failure!"@ to the counterexamples. +monitor :: Monad m => (Property -> Property) -> PropertyM m () +monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) + +-- run functions + +monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property +monadic runner m = property (fmap runner (monadic' m)) + +monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) +monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) + +-- | Runs the property monad for 'IO'-computations. +-- +-- @ +-- prop_cat msg = monadicIO $ do +-- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) +-- +-- pre ('System.Exit.ExitSuccess' == exitCode) +-- +-- assert (stdout == msg) +-- @ +-- +-- >>> quickCheck prop_cat +-- +++ OK, passed 100 tests. +-- +monadicIO :: Testable a => PropertyM IO a -> Property +monadicIO = monadic ioProperty + +#ifndef NO_ST_MONAD +-- | Runs the property monad for 'ST'-computations. +-- +-- @ +-- -- Your mutable sorting algorithm here +-- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) +-- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' +-- +-- prop_sortST xs = monadicST $ do +-- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) +-- assert ('Data.Vector.toList' sorted == sort xs) +-- @ +-- +-- >>> quickCheck prop_sortST +-- +++ OK, passed 100 tests. +-- +monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property +monadicST m = property (runSTGen (monadic' m)) + +runSTGen :: (forall s. Gen (ST s a)) -> Gen a +runSTGen f = do + Capture eval <- capture + return (runST (eval f)) +#endif + +-------------------------------------------------------------------------- +-- the end. 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,981 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Combinators for constructing properties. +{-# LANGUAGE CPP #-} +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +module Test.QuickCheck.Property where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Text( isOneLine, putLine ) +import Test.QuickCheck.Exception +import Test.QuickCheck.State( State(terminal), Confidence(..) ) + +#ifndef NO_TIMEOUT +import System.Timeout(timeout) +#endif +import Data.Maybe +import Control.Applicative +import Control.Monad +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif +#ifndef NO_TYPEABLE +import Data.Typeable (Typeable) +#endif +import Data.Maybe + +-------------------------------------------------------------------------- +-- fixities + +infixr 0 ==> +infixr 1 .&. +infixr 1 .&&. +infixr 1 .||. + +-- The story for exception handling: +-- +-- To avoid insanity, we have rules about which terms can throw +-- exceptions when we evaluate them: +-- * A rose tree must evaluate to WHNF without throwing an exception +-- * The 'ok' component of a Result must evaluate to Just True or +-- Just False or Nothing rather than raise an exception +-- * IORose _ must never throw an exception when executed +-- +-- Both rose trees and Results may loop when we evaluate them, though, +-- so we have to be careful not to force them unnecessarily. +-- +-- We also have to be careful when we use fmap or >>= in the Rose +-- monad that the function we supply is total, or else use +-- protectResults afterwards to install exception handlers. The +-- mapResult function on Properties installs an exception handler for +-- us, though. +-- +-- Of course, the user is free to write "error "ha ha" :: Result" if +-- they feel like it. We have to make sure that any user-supplied Rose +-- Results or Results get wrapped in exception handlers, which we do by: +-- * Making the 'property' function install an exception handler +-- round its argument. This function always gets called in the +-- right places, because all our Property-accepting functions are +-- actually polymorphic over the Testable class so they have to +-- call 'property'. +-- * Installing an exception handler round a Result before we put it +-- in a rose tree (the only place Results can end up). + +-------------------------------------------------------------------------- +-- * Property and Testable types + +-- | The type of properties. +newtype Property = MkProperty { unProperty :: Gen Prop } +#ifndef NO_TYPEABLE + deriving (Typeable) +#endif + +-- | The class of properties, i.e., types which QuickCheck knows how to test. +-- Typically a property will be a function returning 'Bool' or 'Property'. +-- +-- If a property does no quantification, i.e. has no +-- parameters and doesn't use 'forAll', it will only be tested once. +-- This may not be what you want if your property is an @IO Bool@. +-- You can change this behaviour using the 'again' combinator. +class Testable prop where + -- | Convert the thing to a property. + property :: prop -> Property + + -- | Optional; used internally in order to improve shrinking. + -- Tests a property but also quantifies over an extra value + -- (with a custom shrink and show function). + -- The 'Testable' instance for functions defines + -- @propertyForAllShrinkShow@ in a way that improves shrinking. + propertyForAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property + propertyForAllShrinkShow gen shr shw f = + forAllShrinkBlind gen shr $ + \x -> foldr counterexample (property (f x)) (shw x) + +-- | If a property returns 'Discard', the current test case is discarded, +-- the same as if a precondition was false. +-- +-- An example is the definition of '==>': +-- +-- > (==>) :: Testable prop => Bool -> prop -> Property +-- > False ==> _ = property Discard +-- > True ==> p = property p +data Discard = Discard + +instance Testable Discard where + property _ = property rejected + +-- This instance is here to make it easier to turn IO () into a Property. +instance Testable () where + property = property . liftUnit + where + -- N.B. the unit gets forced only inside 'property', + -- so that we turn exceptions into test failures + liftUnit () = succeeded + +instance Testable prop => Testable (Maybe prop) where + property = property . liftMaybe + where + -- See comment for liftUnit above + liftMaybe Nothing = property Discard + liftMaybe (Just prop) = property prop + +instance Testable Bool where + property = property . liftBool + +instance Testable Result where + property = MkProperty . return . MkProp . protectResults . return + +instance Testable Prop where + property p = MkProperty . return . protectProp $ p + +instance Testable prop => Testable (Gen prop) where + property mp = MkProperty $ do p <- mp; unProperty (again p) + +instance Testable Property where + property (MkProperty mp) = MkProperty (fmap protectProp mp) + +-- | Do I/O inside a property. +{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} +morallyDubiousIOProperty :: Testable prop => IO prop -> Property +morallyDubiousIOProperty = ioProperty + +-- | Do I/O inside a property. +-- +-- Warning: any random values generated inside of the argument to @ioProperty@ +-- will not currently be shrunk. For best results, generate all random values +-- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. +-- +-- Note: if your property does no quantification, it will only be tested once. +-- To test it repeatedly, use 'again'. +ioProperty :: Testable prop => IO prop -> Property +ioProperty prop = idempotentIOProperty (fmap noShrinking prop) + +-- | Do I/O inside a property. +-- +-- Warning: during shrinking, the I/O may not always be re-executed. +-- Instead, the I/O may be executed once and then its result retained. +-- If this is not acceptable, use 'ioProperty' instead. +idempotentIOProperty :: Testable prop => IO prop -> Property +idempotentIOProperty = + MkProperty . fmap (MkProp . ioRose . fmap unProp) . + promote . fmap (unProperty . property) + +instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where + property f = + propertyForAllShrinkShow arbitrary shrink (return . show) f + propertyForAllShrinkShow gen shr shw f = + -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop + -- Idea: Generate and shrink (b, a) as a pair + propertyForAllShrinkShow + (liftM2 (,) gen arbitrary) + (liftShrink2 shr shrink) + (\(x, y) -> shw x ++ [show y]) + (uncurry f) + +-- ** Exception handling +protect :: (AnException -> a) -> IO a -> IO a +protect f x = either f id `fmap` tryEvaluateIO x + +-------------------------------------------------------------------------- +-- ** Type Prop + +newtype Prop = MkProp{ unProp :: Rose Result } + +-- ** type Rose + +data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) +-- Only use IORose if you know that the argument is not going to throw an exception! +-- Otherwise, try ioRose. +ioRose :: IO (Rose Result) -> Rose Result +ioRose = IORose . protectRose + +joinRose :: Rose (Rose a) -> Rose a +joinRose (IORose rs) = IORose (fmap joinRose rs) +joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) +joinRose (MkRose (MkRose x ts) tts) = + -- first shrinks outer quantification; makes most sense + MkRose x (map joinRose tts ++ ts) + -- first shrinks inner quantification: terrible + --MkRose x (ts ++ map joinRose tts) + +instance Functor Rose where + -- f must be total + fmap f (IORose rs) = IORose (fmap (fmap f) rs) + fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] + +instance Applicative Rose where + pure = return + -- f must be total + (<*>) = liftM2 ($) + +instance Monad Rose where + return x = MkRose x [] + -- k must be total + m >>= k = joinRose (fmap k m) + +-- | Execute the "IORose" bits of a rose tree, returning a tree +-- constructed by MkRose. +reduceRose :: Rose Result -> IO (Rose Result) +reduceRose r@(MkRose _ _) = return r +reduceRose (IORose m) = m >>= reduceRose + +-- | Apply a function to the outermost MkRose constructor of a rose tree. +-- The function must be total! +onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a +onRose f (MkRose x rs) = f x rs +onRose f (IORose m) = IORose (fmap (onRose f) m) + +-- | Wrap a rose tree in an exception handler. +protectRose :: IO (Rose Result) -> IO (Rose Result) +protectRose = protect (return . exception "Exception") + +-- | Wrap the top level of a 'Prop' in an exception handler. +protectProp :: Prop -> Prop +protectProp (MkProp r) = MkProp (IORose . protectRose . return $ r) + +-- | Wrap all the Results in a rose tree in exception handlers. +protectResults :: Rose Result -> Rose Result +protectResults = onRose $ \x rs -> + IORose $ do + y <- protectResult (return x) + return (MkRose y (map protectResults rs)) + +-- ** Result type + +-- | Different kinds of callbacks +data Callback + = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test + | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case +data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator + | NotCounterexample -- ^ Not affected by the 'verbose' combinator + +-- | The result of a single test. +data Result + = MkResult + { ok :: Maybe Bool + -- ^ result of the test case; Nothing = discard + , expect :: Bool + -- ^ indicates what the expected result of the property is + , reason :: String + -- ^ a message indicating what went wrong + , theException :: Maybe AnException + -- ^ the exception thrown, if any + , abort :: Bool + -- ^ if True, the test should not be repeated + , maybeNumTests :: Maybe Int + -- ^ stop after this many tests + , maybeCheckCoverage :: Maybe Confidence + -- ^ required coverage confidence + , labels :: [String] + -- ^ test case labels + , classes :: [String] + -- ^ test case classes + , tables :: [(String, String)] + -- ^ test case tables + , requiredCoverage :: [(Maybe String, String, Double)] + -- ^ required coverage + , callbacks :: [Callback] + -- ^ the callbacks for this test case + , testCase :: [String] + -- ^ the generated test case + } + +exception :: String -> AnException -> Result +exception msg err + | isDiscard err = rejected + | otherwise = failed{ reason = formatException msg err, + theException = Just err } + +formatException :: String -> AnException -> String +formatException msg err = msg ++ ":" ++ format (show err) + where format xs | isOneLine xs = " '" ++ xs ++ "'" + | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] + +protectResult :: IO Result -> IO Result +protectResult = protect (exception "Exception") + +succeeded, failed, rejected :: Result +(succeeded, failed, rejected) = + (result{ ok = Just True }, + result{ ok = Just False }, + result{ ok = Nothing }) + where + result = + MkResult + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = True + , maybeNumTests = Nothing + , maybeCheckCoverage = Nothing + , labels = [] + , classes = [] + , tables = [] + , requiredCoverage = [] + , callbacks = [] + , testCase = [] + } + +-------------------------------------------------------------------------- +-- ** Lifting and mapping functions + +liftBool :: Bool -> Result +liftBool True = succeeded +liftBool False = failed { reason = "Falsified" } + +mapResult :: Testable prop => (Result -> Result) -> prop -> Property +mapResult f = mapRoseResult (protectResults . fmap f) + +mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property +mapTotalResult f = mapRoseResult (fmap f) + +-- f here mustn't throw an exception (rose tree invariant). +mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property +mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) + +mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property +mapProp f = MkProperty . fmap f . unProperty . property + +-------------------------------------------------------------------------- +-- ** Property combinators + +-- | Adjust the test case size for a property, by transforming it with the given +-- function. +mapSize :: Testable prop => (Int -> Int) -> prop -> Property +mapSize f = property . scale f . unProperty . property + +-- | Shrinks the argument to a property if it fails. Shrinking is done +-- automatically for most types. This function is only needed when you want to +-- override the default behavior. +shrinking :: Testable prop => + (a -> [a]) -- ^ 'shrink'-like function. + -> a -- ^ The original argument + -> (a -> prop) -> Property +shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0))) + where + props x = + MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] + +-- | Disables shrinking for a property altogether. +-- Only quantification /inside/ the call to 'noShrinking' is affected. +noShrinking :: Testable prop => prop -> Property +noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) + +-- | Adds a callback +callback :: Testable prop => Callback -> prop -> Property +callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) + +-- | Adds the given string to the counterexample if the property fails. +counterexample :: Testable prop => String -> prop -> Property +counterexample s = + mapTotalResult (\res -> res{ testCase = s:testCase res }) . + callback (PostFinalFailure Counterexample $ \st _res -> do + s <- showCounterexample s + putLine (terminal st) s) + +showCounterexample :: String -> IO String +showCounterexample s = do + let force [] = return () + force (x:xs) = x `seq` force xs + res <- tryEvaluateIO (force s) + return $ + case res of + Left err -> + formatException "Exception thrown while showing test case" err + Right () -> + s + +-- | Adds the given string to the counterexample if the property fails. +{-# DEPRECATED printTestCase "Use counterexample instead" #-} +printTestCase :: Testable prop => String -> prop -> Property +printTestCase = counterexample + +-- | Performs an 'IO' action after the last failure of a property. +whenFail :: Testable prop => IO () -> prop -> Property +whenFail m = + callback $ PostFinalFailure NotCounterexample $ \_st _res -> + m + +-- | Performs an 'IO' action every time a property fails. Thus, +-- if shrinking is done, this can be used to keep track of the +-- failures along the way. +whenFail' :: Testable prop => IO () -> prop -> Property +whenFail' m = + callback $ PostTest NotCounterexample $ \_st res -> + if ok res == Just False + then m + else return () + +-- | Prints out the generated test case every time the property is tested. +-- Only variables quantified over /inside/ the 'verbose' are printed. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verbose :: Testable prop => prop -> Property +verbose = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) + where newCallback cbs = + PostTest Counterexample $ \st res -> do + putLine (terminal st) (status res ++ ":") + sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] + putLine (terminal st) "" + status MkResult{ok = Just True} = "Passed" + status MkResult{ok = Just False} = "Failed" + status MkResult{ok = Nothing} = "Skipped (precondition false)" + +-- | Prints out the generated test case every time the property fails, including during shrinking. +-- Only variables quantified over /inside/ the 'verboseShrinking' are printed. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verboseShrinking :: Testable prop => prop -> Property +verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res }) + where newCallback cbs = + PostTest Counterexample $ \st res -> + when (ok res == Just False) $ do + putLine (terminal st) "Failed:" + sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ] + putLine (terminal st) "" + +-- | Indicates that a property is supposed to fail. +-- QuickCheck will report an error if it does not fail. +expectFailure :: Testable prop => prop -> Property +expectFailure = mapTotalResult (\res -> res{ expect = False }) + +-- | Modifies a property so that it only will be tested once. +-- Opposite of 'again'. +once :: Testable prop => prop -> Property +once = mapTotalResult (\res -> res{ abort = True }) + +-- | Modifies a property so that it will be tested repeatedly. +-- Opposite of 'once'. +again :: Testable prop => prop -> Property +again = mapTotalResult (\res -> res{ abort = False }) + +-- | Configures how many times a property will be tested. +-- +-- For example, +-- +-- > quickCheck (withMaxSuccess 1000 p) +-- +-- will test @p@ up to 1000 times. +withMaxSuccess :: Testable prop => Int -> prop -> Property +withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) + +-- | Check that all coverage requirements defined by 'cover' and 'coverTable' +-- are met, using a statistically sound test, and fail if they are not met. +-- +-- Ordinarily, a failed coverage check does not cause the property to fail. +-- This is because the coverage requirement is not tested in a statistically +-- sound way. If you use 'cover' to express that a certain value must appear 20% +-- of the time, QuickCheck will warn you if the value only appears in 19 out of +-- 100 test cases - but since the coverage varies randomly, you may have just +-- been unlucky, and there may not be any real problem with your test +-- generation. +-- +-- When you use 'checkCoverage', QuickCheck uses a statistical test to account +-- for the role of luck in coverage failures. It will run as many tests as +-- needed until it is sure about whether the coverage requirements are met. If a +-- coverage requirement is not met, the property fails. +-- +-- Example: +-- +-- > quickCheck (checkCoverage prop_foo) +checkCoverage :: Testable prop => prop -> Property +checkCoverage = checkCoverageWith stdConfidence + +-- | Check coverage requirements using a custom confidence level. +-- See 'stdConfidence'. +-- +-- An example of making the statistical test less stringent in order to improve +-- performance: +-- +-- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo) +checkCoverageWith :: Testable prop => Confidence -> prop -> Property +checkCoverageWith confidence = + certainty confidence `seq` + tolerance confidence `seq` + mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence }) + +-- | The standard parameters used by 'checkCoverage': @certainty = 10^9@, +-- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters. +stdConfidence :: Confidence +stdConfidence = + Confidence { + certainty = 10^9, + tolerance = 0.9 } + +-- | Attaches a label to a test case. This is used for reporting +-- test case distribution. +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > label ("length of input is " ++ show (length xs)) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% length of input is 7 +-- 6% length of input is 3 +-- 5% length of input is 4 +-- 4% length of input is 6 +-- ... +-- +-- Each use of 'label' in your property results in a separate +-- table of test case distribution in the output. If this is +-- not what you want, use 'tabulate'. +label :: Testable prop => String -> prop -> Property +label s = +#ifndef NO_DEEPSEQ + s `deepseq` +#endif + mapTotalResult $ + \res -> res { labels = s:labels res } + +-- | Attaches a label to a test case. This is used for reporting +-- test case distribution. +-- +-- > collect x = label (show x) +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > collect (length xs) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% 7 +-- 6% 3 +-- 5% 4 +-- 4% 6 +-- ... +-- +-- Each use of 'collect' in your property results in a separate +-- table of test case distribution in the output. If this is +-- not what you want, use 'tabulate'. +collect :: (Show a, Testable prop) => a -> prop -> Property +collect x = label (show x) + +-- | Reports how many test cases satisfy a given condition. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > classify (length xs > 1) "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests (22% non-trivial). +classify :: Testable prop => + Bool -- ^ @True@ if the test case should be labelled. + -> String -- ^ Label. + -> prop -> Property +classify False _ = property +classify True s = +#ifndef NO_DEEPSEQ + s `deepseq` +#endif + mapTotalResult $ + \res -> res { classes = s:classes res } + +-- | Checks that at least the given proportion of /successful/ test +-- cases belong to the given class. Discarded tests (i.e. ones +-- with a false precondition) do not affect coverage. +-- +-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but +-- the property does /not/ fail. To make the property fail, use 'checkCoverage'. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > cover 50 (length xs > 1) "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial). +-- +-- Only 26% non-trivial, but expected 50% +cover :: Testable prop => + Double -- ^ The required percentage (0-100) of test cases. + -> Bool -- ^ @True@ if the test case belongs to the class. + -> String -- ^ Label for the test case class. + -> prop -> Property +cover p x s = mapTotalResult f . classify x s + where + f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res } + +-- | Collects information about test case distribution into a table. +-- The arguments to 'tabulate' are the table's name and a list of values +-- associated with the current test case. After testing, QuickCheck prints the +-- frequency of all collected values. The frequencies are expressed as a +-- percentage of the total number of values collected. +-- +-- You should prefer 'tabulate' to 'label' when each test case is associated +-- with a varying number of values. Here is a (not terribly useful) example, +-- where the test data is a list of integers and we record all values that +-- occur in the list: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > tabulate "List elements" (map show xs) $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests; 1684 discarded. +-- +-- List elements (109 in total): +-- 3.7% 0 +-- 3.7% 17 +-- 3.7% 2 +-- 3.7% 6 +-- 2.8% -6 +-- 2.8% -7 +-- +-- Here is a more useful example. We are testing a chatroom, where the user can +-- log in, log out, or send a message: +-- +-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) +-- > instance Arbitrary Command where ... +-- +-- There are some restrictions on command sequences; for example, the user must +-- log in before doing anything else. The function @valid :: [Command] -> Bool@ +-- checks that a command sequence is allowed. Our property then has the form: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > valid cmds ==> +-- > ... +-- +-- The use of '==>' may skew test case distribution. We use 'collect' to see the +-- length of the command sequences, and 'tabulate' to get the frequencies of the +-- individual commands: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > 'collect' (length cmds) $ +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... +-- +-- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom +-- +++ OK, passed 100 tests; 2775 discarded: +-- 60% 0 +-- 20% 1 +-- 15% 2 +-- 3% 3 +-- 1% 4 +-- 1% 5 +-- +-- Commands (68 in total): +-- 62% LogIn +-- 22% SendMessage +-- 16% LogOut +tabulate :: Testable prop => String -> [String] -> prop -> Property +tabulate key values = +#ifndef NO_DEEPSEQ + key `deepseq` values `deepseq` +#endif + mapTotalResult $ + \res -> res { tables = [(key, value) | value <- values] ++ tables res } + +-- | Checks that the values in a given 'table' appear a certain proportion of +-- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts +-- that of the values in @table@, @x1@ should appear at least @p1@ percent of +-- the time, @x2@ at least @p2@ percent of the time, and so on. +-- +-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but +-- the property does /not/ fail. To make the property fail, use 'checkCoverage'. +-- +-- Continuing the example from the 'tabular' combinator... +-- +-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... +-- +-- ...we can add a coverage requirement as follows, which checks that @LogIn@, +-- @LogOut@ and @SendMessage@ each occur at least 25% of the time: +-- +-- > prop_chatroom :: [Command] -> Property +-- > prop_chatroom cmds = +-- > wellFormed cmds LoggedOut ==> +-- > coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $ +-- > 'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $ +-- > ... property goes here ... +-- +-- >>> quickCheck prop_chatroom +-- +++ OK, passed 100 tests; 2909 discarded: +-- 56% 0 +-- 17% 1 +-- 10% 2 +-- 6% 3 +-- 5% 4 +-- 3% 5 +-- 3% 7 +-- +-- Commands (111 in total): +-- 51.4% LogIn +-- 30.6% SendMessage +-- 18.0% LogOut +-- +-- Table 'Commands' had only 18.0% LogOut, but expected 25.0% +coverTable :: Testable prop => + String -> [(String, Double)] -> prop -> Property +coverTable table xs = +#ifndef NO_DEEPSEQ + table `deepseq` xs `deepseq` +#endif + mapTotalResult $ + \res -> res { requiredCoverage = ys ++ requiredCoverage res } + where + ys = [(Just table, x, p/100) | (x, p) <- xs] + +-- | Implication for properties: The resulting property holds if +-- the first argument is 'False' (in which case the test case is discarded), +-- or if the given property holds. Note that using implication carelessly can +-- severely skew test case distribution: consider using 'cover' to make sure +-- that your test data is still good quality. +(==>) :: Testable prop => Bool -> prop -> Property +False ==> _ = property Discard +True ==> p = property p + +-- | Considers a property failed if it does not complete within +-- the given number of microseconds. +-- +-- Note: if the property times out, variables quantified inside the +-- `within` will not be printed. Therefore, you should use `within` +-- only in the body of your property. +-- +-- Good: @prop_foo a b c = within 1000000 ...@ +-- +-- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@ +-- +-- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@ +within :: Testable prop => Int -> prop -> Property +within n = mapRoseResult f + where + f rose = ioRose $ do + let m `orError` x = fmap (fromMaybe x) m + MkRose res roses <- timeout n (reduceRose rose) `orError` + return timeoutResult + res' <- timeout n (protectResult (return res)) `orError` + timeoutResult + return (MkRose res' (map f roses)) + + timeoutResult = failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." } +#ifdef NO_TIMEOUT + timeout _ = fmap Just +#endif + +-- | Explicit universal quantification: uses an explicitly given +-- test case generator. +forAll :: (Show a, Testable prop) + => Gen a -> (a -> prop) -> Property +forAll gen pf = forAllShrink gen (\_ -> []) pf + +-- | Like 'forAll', but with an explicitly given show function. +forAllShow :: Testable prop + => Gen a -> (a -> String) -> (a -> prop) -> Property +forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf + +-- | Like 'forAll', but without printing the generated value. +forAllBlind :: Testable prop + => Gen a -> (a -> prop) -> Property +forAllBlind gen pf = forAllShrinkBlind gen (\_ -> []) pf + +-- | Like 'forAll', but tries to shrink the argument for failing test cases. +forAllShrink :: (Show a, Testable prop) + => Gen a -> (a -> [a]) -> (a -> prop) -> Property +forAllShrink gen shrinker = forAllShrinkShow gen shrinker show + +-- | Like 'forAllShrink', but with an explicitly given show function. +forAllShrinkShow + :: Testable prop + => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property +forAllShrinkShow gen shrinker shower pf = + forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x)) + +-- | Like 'forAllShrink', but without printing the generated value. +forAllShrinkBlind + :: Testable prop + => Gen a -> (a -> [a]) -> (a -> prop) -> Property +forAllShrinkBlind gen shrinker pf = + again $ + MkProperty $ + gen >>= \x -> + unProperty $ + shrinking shrinker x pf + +-- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of +-- 'p1' and 'p2' to test. If you test the property 100 times it +-- makes 100 random choices. +(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .&. p2 = + again $ + MkProperty $ + arbitrary >>= \b -> + unProperty $ + counterexample (if b then "LHS" else "RHS") $ + if b then property p1 else property p2 + +-- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. +(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .&&. p2 = conjoin [property p1, property p2] + +-- | Take the conjunction of several properties. +conjoin :: Testable prop => [prop] -> Property +conjoin ps = + again $ + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps + return (MkProp (conj id roses)) + where + conj k [] = + MkRose (k succeeded) [] + + conj k (p : ps) = IORose $ do + rose@(MkRose result _) <- reduceRose p + case ok result of + _ | not (expect result) -> + return (return failed { reason = "expectFailure may not occur inside a conjunction" }) + Just True -> return (conj (addLabels result . addCallbacksAndCoverage result . k) ps) + Just False -> return rose + Nothing -> do + rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage result . k) ps) + return $ + -- Nasty work to make sure we use the right callbacks + case ok result2 of + Just True -> MkRose (result2 { ok = Nothing }) [] + Just False -> rose2 + Nothing -> rose2 + + addCallbacksAndCoverage result r = + r { callbacks = callbacks result ++ callbacks r, + requiredCoverage = requiredCoverage result ++ requiredCoverage r } + addLabels result r = + r { labels = labels result ++ labels r, + classes = classes result ++ classes r, + tables = tables result ++ tables r } + +-- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. +(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .||. p2 = disjoin [property p1, property p2] + +-- | Take the disjunction of several properties. +disjoin :: Testable prop => [prop] -> Property +disjoin ps = + again $ + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps + return (MkProp (foldr disj (MkRose failed []) roses)) + where + disj :: Rose Result -> Rose Result -> Rose Result + disj p q = + do result1 <- p + case ok result1 of + _ | not (expect result1) -> return expectFailureError + Just False -> do + result2 <- q + return $ + case ok result2 of + _ | not (expect result2) -> expectFailureError + Just True -> addCoverage result1 result2 + Just False -> + MkResult { + ok = Just False, + expect = True, + reason = sep (reason result1) (reason result2), + theException = theException result1 `mplus` theException result2, + -- The following few fields are not important because the + -- test case has failed anyway + abort = False, + maybeNumTests = Nothing, + maybeCheckCoverage = Nothing, + labels = [], + classes = [], + tables = [], + requiredCoverage = [], + callbacks = + callbacks result1 ++ + [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ + callbacks result2, + testCase = + testCase result1 ++ + testCase result2 } + Nothing -> result2 + -- The "obvious" semantics of .||. has: + -- discard .||. true = true + -- discard .||. discard = discard + -- but this implementation gives discard .||. true = discard. + -- This is reasonable because evaluating result2 in the case + -- that result1 discards is just busy-work - it won't ever + -- cause the property to fail. On the other hand, discarding + -- instead of returning true causes us to execute one more + -- test case - but assuming that preconditions are cheap to + -- evaluate, this is no more work than evaluating result2 + -- would be, while (unlike evaluating result2) it might catch + -- a bug. + _ -> return result1 + + expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } + sep [] s = s + sep s [] = s + sep s s' = s ++ ", " ++ s' + + addCoverage result r = + r { requiredCoverage = requiredCoverage result ++ requiredCoverage r } + +-- | Like '==', but prints a counterexample when it fails. +infix 4 === +(===) :: (Eq a, Show a) => a -> a -> Property +x === y = + counterexample (show x ++ interpret res ++ show y) res + where + res = x == y + interpret True = " == " + interpret False = " /= " + +-- | Like '/=', but prints a counterexample when it fails. +infix 4 =/= +(=/=) :: (Eq a, Show a) => a -> a -> Property +x =/= y = + counterexample (show x ++ interpret res ++ show y) res + where + res = x /= y + interpret True = " /= " + interpret False = " == " + +#ifndef NO_DEEPSEQ +-- | Checks that a value is total, i.e., doesn't crash when evaluated. +total :: NFData a => a -> Property +total x = property (rnf x) +#endif + +-------------------------------------------------------------------------- +-- the end. 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,116 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | A wrapper around the system random number generator. Internal QuickCheck module. +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +module Test.QuickCheck.Random where + +import System.Random +#ifndef NO_SPLITMIX +import System.Random.SplitMix +#endif +import Data.Bits + +-- | The "standard" QuickCheck random number generator. +-- A wrapper around either 'SMGen' on GHC, or 'StdGen' +-- on other Haskell systems. +#ifdef NO_SPLITMIX +newtype QCGen = QCGen StdGen +#else +newtype QCGen = QCGen SMGen +#endif + +instance Show QCGen where + showsPrec n (QCGen g) s = showsPrec n g s +instance Read QCGen where + readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] + +instance RandomGen QCGen where +#ifdef NO_SPLITMIX + split (QCGen g) = + case split g of + (g1, g2) -> (QCGen g1, QCGen g2) + genRange (QCGen g) = genRange g + next = wrapQCGen next +#else + split (QCGen g) = + case splitSMGen g of + (g1, g2) -> (QCGen g1, QCGen g2) + genRange _ = (minBound, maxBound) + next = wrapQCGen nextInt + +#ifndef OLD_RANDOM + genWord8 = wrapQCGen genWord8 + genWord16 = wrapQCGen genWord16 + genWord32 = wrapQCGen genWord32 + genWord64 = wrapQCGen genWord64 + genWord32R r = wrapQCGen (genWord32R r) + genWord64R r = wrapQCGen (genWord64R r) + genShortByteString n = wrapQCGen (genShortByteString n) +#endif +#endif + +{-# INLINE wrapQCGen #-} +#ifdef NO_SPLITMIX +wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen)) +#else +wrapQCGen :: (SMGen -> (a, SMGen)) -> (QCGen -> (a, QCGen)) +#endif +wrapQCGen f (QCGen g) = + case f g of + (x, g') -> (x, QCGen g') + +newQCGen :: IO QCGen +#ifdef NO_SPLITMIX +newQCGen = fmap QCGen newStdGen +#else +newQCGen = fmap QCGen newSMGen +#endif + +mkQCGen :: Int -> QCGen +#ifdef NO_SPLITMIX +mkQCGen n = QCGen (mkStdGen n) +#else +mkQCGen n = QCGen (mkSMGen (fromIntegral n)) +#endif + +-- Parameterised in order to make this code testable. +class Splittable a where + left, right :: a -> a + +instance Splittable QCGen where + left = fst . split + right = snd . split + +-- The logic behind 'variant'. Given a random number seed, and an integer, uses +-- splitting to transform the seed according to the integer. We use a +-- prefix-free code so that calls to integerVariant n g for different values of +-- n are guaranteed to return independent seeds. +{-# INLINE integerVariant #-} +integerVariant :: Splittable a => Integer -> a -> a +integerVariant n g + -- Use one bit to encode the sign, then use Elias gamma coding + -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest. + -- Actually, the first bit encodes whether n >= 1 or not; + -- this has the advantage that both 0 and 1 get short codes. + | n >= 1 = gamma n $! left g + | otherwise = gamma (1-n) $! right g + where + gamma n = + encode k . zeroes k + where + k = ilog2 n + + encode (-1) g = g + encode k g + | testBit n k = + encode (k-1) $! right g + | otherwise = + encode (k-1) $! left g + + zeroes 0 g = g + zeroes k g = zeroes (k-1) $! left g + + ilog2 1 = 0 + ilog2 n = 1 + ilog2 (n `div` 2) 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,91 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | QuickCheck's internal state. Internal QuickCheck module. +module Test.QuickCheck.State where + +import Test.QuickCheck.Text +import Test.QuickCheck.Random +import Data.Map(Map) + +-------------------------------------------------------------------------- +-- State + +-- | State represents QuickCheck's internal state while testing a property. +-- The state is made visible to callback functions. +data State + = MkState + -- static + { terminal :: Terminal + -- ^ the current terminal + , maxSuccessTests :: Int + -- ^ maximum number of successful tests needed + , maxDiscardedRatio :: Int + -- ^ maximum number of discarded tests per successful test + , coverageConfidence :: Maybe Confidence + -- ^ required coverage confidence + , computeSize :: Int -> Int -> Int + -- ^ how to compute the size of test cases from + -- #tests and #discarded tests + , numTotMaxShrinks :: !Int + -- ^ How many shrinks to try before giving up + + -- dynamic + , numSuccessTests :: !Int + -- ^ the current number of tests that have succeeded + , numDiscardedTests :: !Int + -- ^ the current number of discarded tests + , numRecentlyDiscardedTests :: !Int + -- ^ the number of discarded tests since the last successful test + , labels :: !(Map [String] Int) + -- ^ counts for each combination of labels (label/collect) + , classes :: !(Map String Int) + -- ^ counts for each class of test case (classify/cover) + , tables :: !(Map String (Map String Int)) + -- ^ tables collected using tabulate + , requiredCoverage :: !(Map (Maybe String, String) Double) + -- ^ coverage requirements + , expected :: !Bool + -- ^ indicates the expected result of the property + , randomSeed :: !QCGen + -- ^ the current random seed + + -- shrinking + , numSuccessShrinks :: !Int + -- ^ number of successful shrinking steps so far + , numTryShrinks :: !Int + -- ^ number of failed shrinking steps since the last successful shrink + , numTotTryShrinks :: !Int + -- ^ total number of failed shrinking steps + } + +-- | The statistical parameters used by 'checkCoverage'. +data Confidence = + Confidence { + certainty :: Integer, + -- ^ How certain 'checkCoverage' must be before the property fails. + -- If the coverage requirement is met, and the certainty parameter is @n@, + -- then you should get a false positive at most one in @n@ runs of QuickCheck. + -- The default value is @10^9@. + -- + -- Lower values will speed up 'checkCoverage' at the cost of false + -- positives. + -- + -- If you are using 'checkCoverage' as part of a test suite, you should + -- be careful not to set @certainty@ too low. If you want, say, a 1% chance + -- of a false positive during a project's lifetime, then @certainty@ should + -- be set to at least @100 * m * n@, where @m@ is the number of uses of + -- 'cover' in the test suite, and @n@ is the number of times you expect the + -- test suite to be run during the project's lifetime. The default value + -- is chosen to be big enough for most projects. + tolerance :: Double + -- ^ For statistical reasons, 'checkCoverage' will not reject coverage + -- levels that are only slightly below the required levels. + -- If the required level is @p@ then an actual level of @tolerance * p@ + -- will be accepted. The default value is @0.9@. + -- + -- Lower values will speed up 'checkCoverage' at the cost of not detecting + -- minor coverage violations. + } + deriving Show + +-------------------------------------------------------------------------- +-- the end. 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,699 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | The main test loop. +{-# LANGUAGE CPP #-} +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +module Test.QuickCheck.Test where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) +import qualified Test.QuickCheck.Property as P +import Test.QuickCheck.Text +import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) +import qualified Test.QuickCheck.State as S +import Test.QuickCheck.Exception +import Test.QuickCheck.Random +import System.Random(split) +#if defined(MIN_VERSION_containers) +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Map +#else +import qualified Data.Map as Map +#endif +#else +import qualified Data.Map as Map +#endif +import qualified Data.Set as Set +import Data.Set(Set) +import Data.Map(Map) + +import Data.Char + ( isSpace + ) + +import Data.List + ( sort + , sortBy + , group + , intersperse + ) + +import Data.Maybe(fromMaybe, isNothing, catMaybes) +import Data.Ord(comparing) +import Text.Printf(printf) +import Control.Monad +import Data.Bits + +#ifndef NO_TYPEABLE +import Data.Typeable (Typeable) +#endif + +-------------------------------------------------------------------------- +-- quickCheck + +-- * Running tests + +-- | Args specifies arguments to the QuickCheck driver +data Args + = Args + { replay :: Maybe (QCGen,Int) + -- ^ Should we replay a previous test? + -- Note: saving a seed from one version of QuickCheck and + -- replaying it in another is not supported. + -- If you want to store a test case permanently you should save + -- the test case itself. + , maxSuccess :: Int + -- ^ Maximum number of successful tests before succeeding. Testing stops + -- at the first failure. If all tests are passing and you want to run more tests, + -- increase this number. + , maxDiscardRatio :: Int + -- ^ Maximum number of discarded tests per successful test before giving up + , maxSize :: Int + -- ^ Size to use for the biggest test cases + , chatty :: Bool + -- ^ Whether to print anything + , maxShrinks :: Int + -- ^ Maximum number of shrinks to before giving up. Setting this to zero + -- turns shrinking off. + } + deriving ( Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +-- | Result represents the test result +data Result + -- | A successful test run + = Success + { numTests :: Int + -- ^ Number of tests performed + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + -- ^ The number of test cases having each combination of labels (see 'label') + , classes :: !(Map String Int) + -- ^ The number of test cases having each class (see 'classify') + , tables :: !(Map String (Map String Int)) + -- ^ Data collected by 'tabulate' + , output :: String + -- ^ Printed output + } + -- | Given up + | GaveUp + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + , classes :: !(Map String Int) + , tables :: !(Map String (Map String Int)) + , output :: String + } + -- | A failed test run + | Failure + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , numShrinks :: Int + -- ^ Number of successful shrinking steps performed + , numShrinkTries :: Int + -- ^ Number of unsuccessful shrinking steps performed + , numShrinkFinal :: Int + -- ^ Number of unsuccessful shrinking steps performed since last successful shrink + , usedSeed :: QCGen + -- ^ What seed was used + , usedSize :: Int + -- ^ What was the test size + , reason :: String + -- ^ Why did the property fail + , theException :: Maybe AnException + -- ^ The exception the property threw, if any + , output :: String + , failingTestCase :: [String] + -- ^ The test case which provoked the failure + , failingLabels :: [String] + -- ^ The test case's labels (see 'label') + , failingClasses :: Set String + -- ^ The test case's classes (see 'classify') + } + -- | A property that should have failed did not + | NoExpectedFailure + { numTests :: Int + , numDiscarded :: Int + -- ^ Number of tests skipped + , labels :: !(Map [String] Int) + , classes :: !(Map String Int) + , tables :: !(Map String (Map String Int)) + , output :: String + } + deriving ( Show ) + +-- | Check if the test run result was a success +isSuccess :: Result -> Bool +isSuccess Success{} = True +isSuccess _ = False + +-- | The default test arguments +stdArgs :: Args +stdArgs = Args + { replay = Nothing + , maxSuccess = 100 + , maxDiscardRatio = 10 + , maxSize = 100 + , chatty = True + , maxShrinks = maxBound + } + +-- | Tests a property and prints the results to 'stdout'. +-- +-- By default up to 100 tests are performed, which may not be enough +-- to find all bugs. To run more tests, use 'withMaxSuccess'. +-- +-- If you want to get the counterexample as a Haskell value, +-- rather than just printing it, try the +-- +-- package. + +quickCheck :: Testable prop => prop -> IO () +quickCheck p = quickCheckWith stdArgs p + +-- | Tests a property, using test arguments, and prints the results to 'stdout'. +quickCheckWith :: Testable prop => Args -> prop -> IO () +quickCheckWith args p = quickCheckWithResult args p >> return () + +-- | Tests a property, produces a test result, and prints the results to 'stdout'. +quickCheckResult :: Testable prop => prop -> IO Result +quickCheckResult p = quickCheckWithResult stdArgs p + +-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. +quickCheckWithResult :: Testable prop => Args -> prop -> IO Result +quickCheckWithResult a p = + withState a (\s -> test s (property p)) + +withState :: Args -> (State -> IO a) -> IO a +withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do + rnd <- case replay a of + Nothing -> newQCGen + Just (rnd,_) -> return rnd + test MkState{ terminal = tm + , maxSuccessTests = maxSuccess a + , coverageConfidence = Nothing + , maxDiscardedRatio = maxDiscardRatio a + , computeSize = case replay a of + Nothing -> computeSize' + Just (_,s) -> computeSize' `at0` s + , numTotMaxShrinks = maxShrinks a + , numSuccessTests = 0 + , numDiscardedTests = 0 + , numRecentlyDiscardedTests = 0 + , S.labels = Map.empty + , S.classes = Map.empty + , S.tables = Map.empty + , S.requiredCoverage = Map.empty + , expected = True + , randomSeed = rnd + , numSuccessShrinks = 0 + , numTryShrinks = 0 + , numTotTryShrinks = 0 + } + where computeSize' n d + -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: + -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. + | n `roundTo` maxSize a + maxSize a <= maxSuccess a || + n >= maxSuccess a || + maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a + | otherwise = + ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a + n `roundTo` m = (n `div` m) * m + at0 f s 0 0 = s + at0 f s n d = f n d + +-- | Tests a property and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verboseCheck :: Testable prop => prop -> IO () +verboseCheck p = quickCheck (verbose p) + +-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verboseCheckWith :: Testable prop => Args -> prop -> IO () +verboseCheckWith args p = quickCheckWith args (verbose p) + +-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verboseCheckResult :: Testable prop => prop -> IO Result +verboseCheckResult p = quickCheckResult (verbose p) + +-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. +-- +-- Note: for technical reasons, the test case is printed out /after/ +-- the property is tested. To debug a property that goes into an +-- infinite loop, use 'within' to add a timeout instead. +verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result +verboseCheckWithResult a p = quickCheckWithResult a (verbose p) + +-------------------------------------------------------------------------- +-- main test loop + +test :: State -> Property -> IO Result +test st f + | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = + doneTesting st f + | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = + giveUp st f + | otherwise = + runATest st f + +doneTesting :: State -> Property -> IO Result +doneTesting st _f + | expected st == False = do + putPart (terminal st) + ( bold ("*** Failed!") + ++ " Passed " + ++ showTestCount st + ++ " (expected failure)" + ) + finished NoExpectedFailure + | otherwise = do + putPart (terminal st) + ( "+++ OK, passed " + ++ showTestCount st + ) + finished Success + where + finished k = do + success st + theOutput <- terminalOutput (terminal st) + return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) + +giveUp :: State -> Property -> IO Result +giveUp st _f = + do -- CALLBACK gave_up? + putPart (terminal st) + ( bold ("*** Gave up!") + ++ " Passed only " + ++ showTestCount st + ++ " tests" + ) + success st + theOutput <- terminalOutput (terminal st) + return GaveUp{ numTests = numSuccessTests st + , numDiscarded = numDiscardedTests st + , labels = S.labels st + , classes = S.classes st + , tables = S.tables st + , output = theOutput + } + +showTestCount :: State -> String +showTestCount st = + number (numSuccessTests st) "test" + ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" + | numDiscardedTests st > 0 + ] + +runATest :: State -> Property -> IO Result +runATest st f = + do -- CALLBACK before_test + putTemp (terminal st) + ( "(" + ++ showTestCount st + ++ ")" + ) + let powerOfTwo n = n .&. (n - 1) == 0 + let f_or_cov = + case coverageConfidence st of + Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> + addCoverageCheck confidence st f + _ -> f + let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) + MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) + res <- callbackPostTest st res + + let continue break st' | abort res = break st' + | otherwise = test st' + + let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st + , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) + , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) + , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) + , S.tables = + foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) + (S.tables st) (P.tables res) + , S.requiredCoverage = + foldr (\(key, value, p) -> Map.insertWith max (key, value) p) + (S.requiredCoverage st) (P.requiredCoverage res) + , expected = expect res } + + case res of + MkResult{ok = Just True} -> -- successful test + do continue doneTesting + st'{ numSuccessTests = numSuccessTests st' + 1 + , numRecentlyDiscardedTests = 0 + , randomSeed = rnd2 + } f + + MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test + do continue giveUp + -- Don't add coverage info from this test + st{ numDiscardedTests = numDiscardedTests st' + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 + , randomSeed = rnd2 + } f + + MkResult{ok = Just False} -> -- failed test + do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts + theOutput <- terminalOutput (terminal st') + if not (expect res) then + return Success{ labels = S.labels st', + classes = S.classes st', + tables = S.tables st', + numTests = numSuccessTests st'+1, + numDiscarded = numDiscardedTests st', + output = theOutput } + else do + testCase <- mapM showCounterexample (P.testCase res) + return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) + , usedSize = size + , numTests = numSuccessTests st'+1 + , numDiscarded = numDiscardedTests st' + , numShrinks = numShrinks + , numShrinkTries = totFailed + , numShrinkFinal = lastFailed + , output = theOutput + , reason = P.reason res + , theException = P.theException res + , failingTestCase = testCase + , failingLabels = P.labels res + , failingClasses = Set.fromList (P.classes res) + } + where + (rnd1,rnd2) = split (randomSeed st) + +failureSummary :: State -> P.Result -> String +failureSummary st res = fst (failureSummaryAndReason st res) + +failureReason :: State -> P.Result -> [String] +failureReason st res = snd (failureSummaryAndReason st res) + +failureSummaryAndReason :: State -> P.Result -> (String, [String]) +failureSummaryAndReason st res = (summary, full) + where + summary = + header ++ + short 26 (oneLine theReason ++ " ") ++ + count True ++ "..." + + full = + (header ++ + (if isOneLine theReason then theReason ++ " " else "") ++ + count False ++ ":"): + if isOneLine theReason then [] else lines theReason + + theReason = P.reason res + + header = + if expect res then + bold "*** Failed! " + else "+++ OK, failed as expected. " + + count full = + "(after " ++ number (numSuccessTests st+1) "test" ++ + concat [ + " and " ++ + show (numSuccessShrinks st) ++ + concat [ "." ++ show (numTryShrinks st) | showNumTryShrinks ] ++ + " shrink" ++ + (if numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s") + | numSuccessShrinks st > 0 || showNumTryShrinks ] ++ + ")" + where + showNumTryShrinks = full && numTryShrinks st > 0 + +success :: State -> IO () +success st = do + mapM_ (putLine $ terminal st) (paragraphs [short, long]) + where + (short, long) = + case labelsAndTables st of + ([msg], long) -> + ([" (" ++ dropWhile isSpace msg ++ ")."], long) + ([], long) -> + (["."], long) + (short, long) -> + (":":short, long) + +labelsAndTables :: State -> ([String], [String]) +labelsAndTables st = (theLabels, theTables) + where + theLabels :: [String] + theLabels = + paragraphs $ + [ showTable (numSuccessTests st) Nothing m + | m <- S.classes st:Map.elems numberedLabels ] + + numberedLabels :: Map Int (Map String Int) + numberedLabels = + Map.fromListWith (Map.unionWith (+)) $ + [ (i, Map.singleton l n) + | (labels, n) <- Map.toList (S.labels st), + (i, l) <- zip [0..] labels ] + + theTables :: [String] + theTables = + paragraphs $ + [ showTable (sum (Map.elems m)) (Just table) m + | (table, m) <- Map.toList (S.tables st) ] ++ + [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ") + ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot + | (mtable, label, tot, n, p) <- allCoverage st, + insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] + +showTable :: Int -> Maybe String -> Map String Int -> [String] +showTable k mtable m = + [table ++ " " ++ total ++ ":" | Just table <- [mtable]] ++ + (map format . + -- Descending order of occurrences + reverse . sortBy (comparing snd) . + -- If #occurences the same, sort in increasing order of key + -- (note: works because sortBy is stable) + reverse . sortBy (comparing fst) $ Map.toList m) + where + format (key, v) = + rpercent v k ++ " " ++ key + + total = printf "(%d in total)" k + +-------------------------------------------------------------------------- +-- main shrinking loop + +foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +foundFailure st res ts = + do localMin st{ numTryShrinks = 0 } res ts + +localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +-- Don't try to shrink for too long +localMin st res ts + | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = + localMinFound st res +localMin st res ts = do + r <- tryEvaluateIO $ + putTemp (terminal st) (failureSummary st res) + case r of + Left err -> + localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } + Right () -> do + r <- tryEvaluate ts + case r of + Left err -> + localMinFound st + (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } + Right ts' -> localMin' st res ts' + +localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +localMin' st res [] = localMinFound st res +localMin' st res (t:ts) = + do -- CALLBACK before_test + MkRose res' ts' <- protectRose (reduceRose t) + res' <- callbackPostTest st res' + if ok res' == Just False + then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, + numTryShrinks = 0 } res' ts' + else localMin st{ numTryShrinks = numTryShrinks st + 1, + numTotTryShrinks = numTotTryShrinks st + 1 } res ts + +localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) +localMinFound st res = + do sequence_ [ putLine (terminal st) msg | msg <- failureReason st res ] + callbackPostFinalFailure st res + -- NB no need to check if callbacks threw an exception because + -- we are about to return to the user anyway + return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res) + +-------------------------------------------------------------------------- +-- callbacks + +callbackPostTest :: State -> P.Result -> IO P.Result +callbackPostTest st res = protect (exception "Exception running callback") $ do + sequence_ [ f st res | PostTest _ f <- callbacks res ] + return res + +callbackPostFinalFailure :: State -> P.Result -> IO () +callbackPostFinalFailure st res = do + x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ] + case x of + Left err -> do + putLine (terminal st) "*** Exception running callback: " + tryEvaluateIO $ putLine (terminal st) (show err) + return () + Right () -> return () + +---------------------------------------------------------------------- +-- computing coverage + +sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool +sufficientlyCovered confidence n k p = + -- Accept the coverage if, with high confidence, the actual probability is + -- at least 0.9 times the required one. + wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p + where + err = certainty confidence + tol = tolerance confidence + +insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool +insufficientlyCovered Nothing n k p = + fromIntegral k < p * fromIntegral n +insufficientlyCovered (Just err) n k p = + wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p + +-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval +-- Note: +-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf +-- suggests we should use a instead of a/2 for a one-sided test. Look +-- into this. +wilson :: Integer -> Integer -> Double -> Double +wilson k n z = + (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf) + where + nf = fromIntegral n + p = fromIntegral k / fromIntegral n + +wilsonLow :: Integer -> Integer -> Double -> Double +wilsonLow k n a = wilson k n (invnormcdf (a/2)) + +wilsonHigh :: Integer -> Integer -> Double -> Double +wilsonHigh k n a = wilson k n (invnormcdf (1-a/2)) + +-- Algorithm taken from +-- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/ +-- Accurate to about one part in 10^9. +-- +-- The 'erf' package uses the same algorithm, but with an extra step +-- to get a fully accurate result, which we skip because it requires +-- the 'erfc' function. +invnormcdf :: Double -> Double +invnormcdf p + | p < 0 = 0/0 + | p > 1 = 0/0 + | p == 0 = -1/0 + | p == 1 = 1/0 + | p < p_low = + let + q = sqrt(-2*log(p)) + in + (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / + ((((d1*q+d2)*q+d3)*q+d4)*q+1) + | p <= p_high = + let + q = p - 0.5 + r = q*q + in + (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q / + (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1) + | otherwise = + let + q = sqrt(-2*log(1-p)) + in + -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / + ((((d1*q+d2)*q+d3)*q+d4)*q+1) + where + a1 = -3.969683028665376e+01 + a2 = 2.209460984245205e+02 + a3 = -2.759285104469687e+02 + a4 = 1.383577518672690e+02 + a5 = -3.066479806614716e+01 + a6 = 2.506628277459239e+00 + + b1 = -5.447609879822406e+01 + b2 = 1.615858368580409e+02 + b3 = -1.556989798598866e+02 + b4 = 6.680131188771972e+01 + b5 = -1.328068155288572e+01 + + c1 = -7.784894002430293e-03 + c2 = -3.223964580411365e-01 + c3 = -2.400758277161838e+00 + c4 = -2.549732539343734e+00 + c5 = 4.374664141464968e+00 + c6 = 2.938163982698783e+00 + + d1 = 7.784695709041462e-03 + d2 = 3.224671290700398e-01 + d3 = 2.445134137142996e+00 + d4 = 3.754408661907416e+00 + + p_low = 0.02425 + p_high = 1 - p_low + +addCoverageCheck :: Confidence -> State -> Property -> Property +addCoverageCheck confidence st prop + | and [ sufficientlyCovered confidence tot n p + | (_, _, tot, n, p) <- allCoverage st ] = + -- Note: run prop once more so that we get labels for this test case run + once prop + | or [ insufficientlyCovered (Just (certainty confidence)) tot n p + | (_, _, tot, n, p) <- allCoverage st ] = + let (theLabels, theTables) = labelsAndTables st in + foldr counterexample (property failed{P.reason = "Insufficient coverage"}) + (paragraphs [theLabels, theTables]) + | otherwise = prop + +allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] +allCoverage st = + [ (key, value, tot, n, p) + | ((key, value), p) <- Map.toList (S.requiredCoverage st), + let tot = + case key of + Just key -> Map.findWithDefault 0 key totals + Nothing -> numSuccessTests st, + let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ] + where + combinedCounts :: Map (Maybe String) (Map String Int) + combinedCounts = + Map.insert Nothing (S.classes st) + (Map.mapKeys Just (S.tables st)) + + totals :: Map String Int + totals = fmap (sum . Map.elems) (S.tables st) + +-------------------------------------------------------------------------- +-- the end. 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,232 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Terminal control and text helper functions. Internal QuickCheck module. +module Test.QuickCheck.Text + ( Str(..) + , ranges + + , number + , short + , showErr + , oneLine + , isOneLine + , bold + , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage + , drawTable, Cell(..) + , paragraphs + + , newTerminal + , withStdioTerminal + , withHandleTerminal + , withNullTerminal + , terminalOutput + , handle + , Terminal + , putTemp + , putPart + , putLine + ) + where + +-------------------------------------------------------------------------- +-- imports + +import System.IO + ( hFlush + , hPutStr + , stdout + , stderr + , Handle + , BufferMode (..) + , hGetBuffering + , hSetBuffering + , hIsTerminalDevice + ) + +import Data.IORef +import Data.List +import Text.Printf +import Test.QuickCheck.Exception + +-------------------------------------------------------------------------- +-- literal string + +newtype Str = MkStr String + +instance Show Str where + show (MkStr s) = s + +ranges :: (Show a, Integral a) => a -> a -> Str +ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1)) + where + n' = k * (n `div` k) + +-------------------------------------------------------------------------- +-- formatting + +number :: Int -> String -> String +number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" + +short :: Int -> String -> String +short n s + | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s + | otherwise = s + where + k = length s + i = if n >= 5 then 3 else 0 + +showErr :: Show a => a -> String +showErr = unwords . words . show + +oneLine :: String -> String +oneLine = unwords . words + +isOneLine :: String -> Bool +isOneLine xs = '\n' `notElem` xs + +ljust n xs = xs ++ replicate (n - length xs) ' ' +rjust n xs = replicate (n - length xs) ' ' ++ xs +centre n xs = + ljust n $ + replicate ((n - length xs) `div` 2) ' ' ++ xs + +lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String +lpercent n k = + lpercentage (fromIntegral n / fromIntegral k) k + +rpercent n k = + rpercentage (fromIntegral n / fromIntegral k) k + +lpercentage, rpercentage :: Integral a => Double -> a -> String +lpercentage p n = + printf "%.*f" places (100*p) ++ "%" + where + -- Show no decimal places if k <= 100, + -- one decimal place if k <= 1000, + -- two decimal places if k <= 10000, and so on. + places :: Integer + places = + ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 + +rpercentage p n = padding ++ lpercentage p n + where + padding = if p < 0.1 then " " else "" + +data Cell = LJust String | RJust String | Centred String deriving Show + +text :: Cell -> String +text (LJust xs) = xs +text (RJust xs) = xs +text (Centred xs) = xs + +-- Flatten a table into a list of rows +flattenRows :: [[Cell]] -> [String] +flattenRows rows = map row rows + where + cols = transpose rows + widths = map (maximum . map (length . text)) cols + + row cells = concat (intersperse " " (zipWith cell widths cells)) + cell n (LJust xs) = ljust n xs + cell n (RJust xs) = rjust n xs + cell n (Centred xs) = centre n xs + +-- Draw a table given a header and contents +drawTable :: [String] -> [[Cell]] -> [String] +drawTable headers table = + [line] ++ + [border '|' ' ' header | header <- headers] ++ + [line | not (null headers) && not (null rows)] ++ + [border '|' ' ' row | row <- rows] ++ + [line] + where + rows = flattenRows table + + headerwidth = maximum (0:map length headers) + bodywidth = maximum (0:map length rows) + width = max headerwidth bodywidth + + line = border '+' '-' $ replicate width '-' + border x y xs = [x, y] ++ centre width xs ++ [y, x] + +paragraphs :: [[String]] -> [String] +paragraphs = concat . intersperse [""] . filter (not . null) + +bold :: String -> String +-- not portable: +--bold s = "\ESC[1m" ++ s ++ "\ESC[0m" +bold s = s -- for now + +-------------------------------------------------------------------------- +-- putting strings + +data Terminal + = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) + +newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal +newTerminal out err = + do res <- newIORef (showString "") + tmp <- newIORef 0 + return (MkTerminal res tmp out err) + +withBuffering :: IO a -> IO a +withBuffering action = do + mode <- hGetBuffering stderr + -- By default stderr is unbuffered. This is very slow, hence we explicitly + -- enable line buffering. + hSetBuffering stderr LineBuffering + action `finally` hSetBuffering stderr mode + +withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a +withHandleTerminal outh merrh action = do + let + err = + case merrh of + Nothing -> const (return ()) + Just errh -> handle errh + newTerminal (handle outh) err >>= action + +withStdioTerminal :: (Terminal -> IO a) -> IO a +withStdioTerminal action = do + isatty <- hIsTerminalDevice stderr + if isatty then + withBuffering (withHandleTerminal stdout (Just stderr) action) + else + withBuffering (withHandleTerminal stdout Nothing action) + +withNullTerminal :: (Terminal -> IO a) -> IO a +withNullTerminal action = + newTerminal (const (return ())) (const (return ())) >>= action + +terminalOutput :: Terminal -> IO String +terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) + +handle :: Handle -> String -> IO () +handle h s = do + hPutStr h s + hFlush h + +putPart, putTemp, putLine :: Terminal -> String -> IO () +putPart tm@(MkTerminal res _ out _) s = + do putTemp tm "" + force s + out s + modifyIORef res (. showString s) + where + force :: [a] -> IO () + force = evaluate . seqList + + seqList :: [a] -> () + seqList [] = () + seqList (x:xs) = x `seq` seqList xs + +putLine tm s = putPart tm (s ++ "\n") + +putTemp tm@(MkTerminal _ tmp _ err) s = + do n <- readIORef tmp + err $ + replicate n ' ' ++ replicate n '\b' ++ + s ++ [ '\b' | _ <- s ] + writeIORef tmp (length s) + +-------------------------------------------------------------------------- +-- the end. diff --git a/test-hugs b/test-hugs new file mode 100644 --- /dev/null +++ b/test-hugs @@ -0,0 +1,26 @@ +#!/bin/sh + +set -e + +CABAL=${CABAL:-cabal} +HC=${HC:-ghc} + +# Install cpphs if it is not in path +command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs + +# Regenerate quickcheck-hugs +sh make-hugs +find quickcheck-hugs + +die() { + echo "TEST FAILED" + exit 1 +} + +dotest() { + echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output + grep "$3" hugs.output || die +} + +# Simple tests +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." 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 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] .&&.