QuickCheck-2.6/0000755000000000000000000000000012116126475011566 5ustar0000000000000000QuickCheck-2.6/QuickCheck.cabal0000644000000000000000000000635012116126475014570 0ustar0000000000000000Name: QuickCheck Version: 2.6 Cabal-Version: >= 1.6 Build-type: Simple License: BSD3 License-file: LICENSE Extra-source-files: README Copyright: 2000-2012 Koen Claessen, 2006-2008 Björn Bringert, 2009-2012 Nick Smallbone Author: Koen Claessen Maintainer: QuickCheck developers Bug-reports: mailto:quickcheck@projects.haskell.org Tested-with: GHC >=6.8, Hugs Homepage: http://code.haskell.org/QuickCheck Category: Testing Synopsis: Automatic testing of Haskell programs Description: QuickCheck is a library for random testing of program properties. . The programmer provides a specification of the program, in the form of properties which functions should satisfy, and QuickCheck then tests that the properties hold in a large number of randomly generated cases. . Specifications are expressed in Haskell, using combinators defined in the QuickCheck library. QuickCheck provides combinators to define properties, observe the distribution of test data, and define test data generators. source-repository head type: git location: https://github.com/nick8325/quickcheck source-repository this type: git location: https://github.com/nick8325/quickcheck tag: 2.5.1.1 flag base3 Description: Choose the new smaller, split-up base package. flag base4 Description: Choose the even newer base package with extensible exceptions. flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. library -- Choose which library versions to use. if flag(base4) Build-depends: base >= 4 && < 5, random else if flag(base3) Build-depends: base >= 3 && < 4, random else Build-depends: base < 3 -- On old versions of GHC use the ghc package to catch ctrl-C. if impl(ghc >= 6.7) && impl(ghc < 6.13) Build-depends: ghc -- We want to use extensible-exceptions even if linking against base-3. if impl(ghc >= 6.9) && impl (ghc < 7.0) Build-depends: extensible-exceptions -- Modules that are always built. Exposed-Modules: Test.QuickCheck, Test.QuickCheck.Arbitrary, Test.QuickCheck.Gen, Test.QuickCheck.Monadic, Test.QuickCheck.Modifiers, Test.QuickCheck.Property, Test.QuickCheck.Test, Test.QuickCheck.Text, Test.QuickCheck.Poly, Test.QuickCheck.State Extensions: CPP -- Choose which optional features to build based on which compiler -- we're using. It would be nice to use flags for this but Cabal's -- dependency resolution isn't good enough. if impl(ghc) Exposed-Modules: Test.QuickCheck.Function if flag(templateHaskell) && impl(ghc >= 6.12) Build-depends: template-haskell >= 2.4 Exposed-Modules: Test.QuickCheck.All -- GHC < 7.0 doesn't cope with multiple LANGUAGE pragmas in the same -- file, I think... if impl(ghc < 7) Extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, TypeOperators else -- 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 if !impl(hugs) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES Other-Modules: Test.QuickCheck.Exception QuickCheck-2.6/Setup.lhs0000644000000000000000000000015712116126475013401 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain QuickCheck-2.6/LICENSE0000644000000000000000000000304712116126475012577 0ustar0000000000000000Copyright (c) 2000-2012, Koen Claessen Copyright (c) 2006-2008, Björn Bringert Copyright (c) 2009-2012, Nick Smallbone All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the names of the copyright owners nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. QuickCheck-2.6/README0000644000000000000000000000120412116126475012443 0ustar0000000000000000This is QuickCheck 2, a library for random testing of program properties. === Installation === Installation is done with Cabal: $ cabal install or, if you're missing the cabal command, $ runghc Setup.lhs configure $ runghc Setup.lhs build $ runghc Setup.lhs install If you get errors about Template Haskell, try $ cabal install -f-templateHaskell but please report this as a bug, letting us know about your GHC installation. === Bugs === Please report bugs to the QuickCheck mailing list at quickcheck@projects.haskell.org. === Documentation === $ runghc Setup.lhs haddock generates API documentation in dist/doc/html/index.html QuickCheck-2.6/Test/0000755000000000000000000000000012116126475012505 5ustar0000000000000000QuickCheck-2.6/Test/QuickCheck.hs0000644000000000000000000000467612116126475015070 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.QuickCheck ( -- * Running tests quickCheck , Args(..), Result(..) , stdArgs , quickCheckWith , quickCheckWithResult , quickCheckResult -- ** Running tests verbosely , verboseCheck , verboseCheckWith , verboseCheckWithResult , verboseCheckResult , verbose -- * Random generation , Gen -- ** Generator combinators , sized , resize , choose , promote , suchThat , suchThatMaybe , oneof , frequency , elements , growingElements , listOf , listOf1 , vectorOf -- ** Generators which use Arbitrary , vector , orderedList -- ** Generator debugging , sample , sample' -- * Arbitrary and CoArbitrary classes , Arbitrary(..) , CoArbitrary(..) -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral , arbitrarySizedFractional , arbitrarySizedBoundedIntegral , arbitraryBoundedIntegral , arbitraryBoundedRandom , arbitraryBoundedEnum , coarbitraryEnum -- ** Helper functions for implementing shrink , shrinkNothing , shrinkIntegral , shrinkRealFrac -- ** Helper functions for implementing coarbitrary , variant , (><) , coarbitraryIntegral , coarbitraryReal , coarbitraryShow -- ** Type-level modifiers for changing generator behavior , Blind(..) , Fixed(..) , OrderedList(..) , NonEmptyList(..) , Positive(..) , NonZero(..) , NonNegative(..) , Smart(..) , Shrink2(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) #endif , ShrinkState(..) -- * Properties , Property, Prop, Testable(..) -- ** Property combinators , mapSize , shrinking , (==>) , discard , forAll , forAllShrink -- *** Experimental combinators for conjunction and disjunction , (.&.) , (.&&.) , conjoin , (.||.) , disjoin -- *** Handling failure , whenFail , printTestCase , whenFail' , expectFailure , within -- *** Test distribution , label , collect , classify , cover , once -- * Text formatting , Str(..) , ranges ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Text import Test.QuickCheck.Exception -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/0000755000000000000000000000000012116126475014517 5ustar0000000000000000QuickCheck-2.6/Test/QuickCheck/Modifiers.hs0000644000000000000000000001646012116126475017003 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_MULTI_PARAM_TYPE_CLASSES {-# LANGUAGE MultiParamTypeClasses #-} #endif #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif -- | Modifiers for test data. -- -- These types do things such as restricting the kind of test data that can be generated. -- They can be pattern-matched on in properties as a stylistic -- alternative to using explicit quantification. -- -- Examples: -- -- @ -- -- Functions cannot be shown (but see "Test.QuickCheck.Function") -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ -- -- Instead of 'forAll' 'orderedList' -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = -- sort xs == xs -- @ module Test.QuickCheck.Modifiers ( -- ** Type-level modifiers for changing generator behavior Blind(..) , Fixed(..) , OrderedList(..) , NonEmptyList(..) , Positive(..) , NonZero(..) , NonNegative(..) , Smart(..) , Shrink2(..) , Shrinking(..) , ShrinkState(..) ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Data.List ( sort ) -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class. newtype Blind a = Blind a deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) 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 a deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) instance Arbitrary a => Arbitrary (Fixed a) where arbitrary = Fixed `fmap` arbitrary -- no shrink function -------------------------------------------------------------------------- -- | @Ordered xs@: guarantees that xs is ordered. newtype OrderedList a = Ordered {getOrdered :: [a]} deriving ( Eq, Ord, Show, Read ) instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where arbitrary = Ordered `fmap` orderedList shrink (Ordered xs) = [ Ordered xs' | xs' <- shrink xs , sort xs' == xs' ] -------------------------------------------------------------------------- -- | @NonEmpty xs@: guarantees that xs is non-empty. newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} deriving ( Eq, Ord, Show, Read ) instance Arbitrary a => Arbitrary (NonEmptyList a) where arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) shrink (NonEmpty xs) = [ NonEmpty xs' | xs' <- shrink xs , not (null xs') ] -------------------------------------------------------------------------- -- | @Positive x@: guarantees that @x \> 0@. newtype Positive a = Positive {getPositive :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where arbitrary = ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0 where gt0 (Positive x) = x > 0 shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] -------------------------------------------------------------------------- -- | @NonZero x@: guarantees that @x \/= 0@. newtype NonZero a = NonZero {getNonZero :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) instance (Num a, Ord 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 , Num, Integral, Real, Enum #endif ) instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where arbitrary = (frequency -- why is this distrbution like this? [ (5, (NonNegative . abs) `fmap` arbitrary) , (1, return (NonNegative 0)) ] ) `suchThat` ge0 where ge0 (NonNegative x) = x >= 0 shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] -------------------------------------------------------------------------- -- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x newtype Shrink2 a = Shrink2 a deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif ) 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 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 Show a => Show (Shrinking s a) where showsPrec n (Shrinking _ x) = showsPrec n x instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where arbitrary = do x <- arbitrary return (Shrinking (shrinkInit x) x) shrink (Shrinking s x) = [ Shrinking s' x' | (x',s') <- shrinkState x s ] #endif /* NO_MULTI_PARAM_TYPE_CLASSES */ -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Gen.hs0000644000000000000000000001172512116126475015572 0ustar0000000000000000-- | Test case generation. module Test.QuickCheck.Gen where -------------------------------------------------------------------------- -- imports import System.Random ( Random , StdGen , randomR , split , newStdGen ) import Control.Monad ( liftM , ap ) import Control.Applicative ( Applicative(..) ) -------------------------------------------------------------------------- -- ** Generator type newtype Gen a = MkGen{ unGen :: StdGen -> Int -> a } instance Functor Gen where fmap f (MkGen h) = MkGen (\r n -> f (h r n)) instance Applicative Gen where pure = return (<*>) = ap instance Monad Gen where return x = MkGen (\_ _ -> x) MkGen m >>= k = MkGen (\r n -> let (r1,r2) = split r MkGen m' = k (m r1 n) in m' r2 n ) -------------------------------------------------------------------------- -- ** Primitive generator combinators -- | Modifies a generator using an integer seed. variant :: Integral n => n -> Gen a -> Gen a variant k0 (MkGen m) = MkGen (\r n -> m (var k0 r) n) where var k = (if k == k' then id else var k') . (if even k then fst else snd) . split where k' = k `div` 2 -- | Used to construct generators that depend on the size parameter. sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. resize :: Int -> Gen a -> Gen a resize n (MkGen m) = MkGen (\r _ -> m r n) -- | Generates a random element in the given inclusive range. choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) -- | Promotes a monadic generator to a generator of monadic values. promote :: Monad m => m (Gen a) -> Gen (m a) promote m = MkGen (\r n -> liftM (\(MkGen m') -> m' r n) m) -- | Generates some example values. sample' :: Gen a -> IO [a] sample' (MkGen m) = do rnd0 <- newStdGen let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = split rnd return [(m r n) | (r,n) <- rnds rnd0 `zip` [0,2..20] ] -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO () sample g = do cases <- sample' g sequence_ (map print cases) -------------------------------------------------------------------------- -- ** Common generator combinators -- | Generates a value that satisfies a predicate. suchThat :: Gen a -> (a -> Bool) -> Gen a gen `suchThat` p = do mx <- gen `suchThatMaybe` p case mx of Just x -> return x Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) -- | Tries to generate a value that satisfies a predicate. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) gen `suchThatMaybe` p = sized (try 0 . max 1) where try _ 0 = return Nothing try k n = do x <- resize (2*k+n) gen if p x then return (Just x) else try (k+1) (n-1) -- | Randomly uses one of the given generators. The input list -- must be non-empty. oneof :: [Gen a] -> Gen a oneof [] = error "QuickCheck.oneof used with empty list" oneof gs = choose (0,length gs - 1) >>= (gs !!) -- | Chooses one of the given generators, with a weighted random distribution. -- The input list must be non-empty. frequency :: [(Int, Gen a)] -> Gen a frequency [] = error "QuickCheck.frequency used with empty list" frequency xs0 = choose (1, tot) >>= (`pick` xs0) where tot = sum (map fst xs0) pick n ((k,x):xs) | n <= k = x | otherwise = pick (n-k) xs pick _ _ = error "QuickCheck.pick used with empty list" -- | Generates one of the given values. The input list must be non-empty. elements :: [a] -> Gen a elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` choose (0, length xs - 1) -- | 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 . fromIntegral size n = (log' n + 1) * k `div` log' mx {- WAS: growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) where k = length xs -} -- | Generates a list of random length. The maximum length depends on the -- size parameter. listOf :: Gen a -> Gen [a] listOf gen = sized $ \n -> do k <- choose (0,n) vectorOf k gen -- | Generates a non-empty list of random length. The maximum length -- depends on the size parameter. listOf1 :: Gen a -> Gen [a] listOf1 gen = sized $ \n -> do k <- choose (1,1 `max` n) vectorOf k gen -- | Generates a list of the given length. vectorOf :: Int -> Gen a -> Gen [a] vectorOf k gen = sequence [ gen | _ <- [1..k] ] -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Function.hs0000644000000000000000000002042012116126475016636 0ustar0000000000000000{-# LANGUAGE TypeOperators, GADTs #-} -- | Generation of random shrinkable, showable functions. -- Not really documented at the moment! -- -- Example of use: -- -- >>> :{ -- >>> let prop :: Fun String Integer -> Bool -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" -- >>> :} -- >>> quickCheck prop -- *** Failed! Falsifiable (after 3 tests and 134 shrinks): -- {"elephant"->1, "monkey"->1, _->0} -- -- To generate random values of type @'Fun' a b@, -- you must have an instance @'Function' a@. -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function ( Fun(..) , apply , (:->) , Function(..) , functionMap , functionShow ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly import Data.Char import Data.Word import Data.List( intersperse ) import Data.Maybe( fromJust ) -------------------------------------------------------------------------- -- concrete functions -- the type of possibly partial concrete functions data a :-> c where Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c) (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) Unit :: c -> (() :-> c) Nil :: a :-> c Table :: Eq a => [(a,c)] -> (a :-> c) Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c) instance Functor ((:->) a) where fmap f (Pair p) = Pair (fmap (fmap f) p) fmap f (p:+:q) = fmap f p :+: fmap f q fmap f (Unit c) = Unit (f c) fmap f Nil = Nil fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ] fmap f (Map g h p) = Map g h (fmap f p) instance (Show a, Show b) => Show (a:->b) where show p = showFunction p Nothing -- only use this on finite functions showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String showFunction p md = "{" ++ concat (intersperse ", " ( [ show x ++ "->" ++ show c | (x,c) <- table p ] ++ [ "_->" ++ show d | Just d <- [md] ] )) ++ "}" -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy abstract (Unit c) _ _ = c abstract Nil d _ = d abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d]) abstract (Map g _ p) d x = abstract p d (g x) -- generating a table from a concrete function table :: (a :-> c) -> [(a,c)] table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ] table (p :+: q) = [ (Left x, c) | (x,c) <- table p ] ++ [ (Right y,c) | (y,c) <- table q ] table (Unit c) = [ ((), c) ] table Nil = [] table (Table xys) = xys table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] -------------------------------------------------------------------------- -- Function class Function a where function :: (a->b) -> (a:->b) -- basic instances instance Function () where function f = Unit (f ()) instance Function Word8 where function f = Table [(x,f x) | x <- [0..255]] instance (Function a, Function b) => Function (a,b) where function f = Pair (function `fmap` function (curry f)) instance (Function a, Function b) => Function (Either a b) where function f = function (f . Left) :+: function (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 functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMap g h f = Map g h (function (\b -> f (h b))) functionShow :: (Show a, Read a) => (a->c) -> (a:->c) functionShow f = functionMap show read f 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 = functionMap fromIntegral fromInteger instance Function Char where function = functionMap ord' chr' where ord' c = fromIntegral (ord c) :: Word8 chr' n = chr (fromIntegral n) -- 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 -------------------------------------------------------------------------- -- shrinking shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] shrinkFun shr (Pair p) = [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] where pair Nil = Nil pair p = Pair p shrinkFun shr (p :+: q) = [ p .+. Nil | not (isNil q) ] ++ [ Nil .+. q | not (isNil p) ] ++ [ p .+. q' | q' <- shrinkFun shr q ] ++ [ p' .+. q | p' <- shrinkFun shr p ] where isNil :: (a :-> b) -> Bool isNil Nil = True isNil _ = False Nil .+. Nil = Nil p .+. q = p :+: q shrinkFun shr (Unit c) = [ Nil ] ++ [ Unit c' | c' <- shr c ] shrinkFun shr (Table xys) = [ table xys' | xys' <- shrinkList shrXy xys ] where shrXy (x,y) = [(x,y') | y' <- shr y] table [] = Nil table xys = Table xys shrinkFun shr Nil = [] shrinkFun shr (Map g h p) = [ mapp g h p' | p' <- shrinkFun shr p ] where mapp g h Nil = Nil mapp g h p = Map g h p -------------------------------------------------------------------------- -- the Fun modifier data Fun a b = Fun (a :-> b, b) (a -> b) mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p,d) (abstract p d) apply :: Fun a b -> (a -> b) apply (Fun _ f) = f instance (Show a, Show b) => Show (Fun a b) where show (Fun (p,d) _) = 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) _) = [ mkFun p' d | p' <- shrink p ] ++ [ mkFun p d' | d' <- shrink d ] -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Monadic.hs0000644000000000000000000000535212116126475016432 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif -- | Allows testing of monadic values. -- See the paper \"Testing Monadic Code with QuickCheck\": -- . module Test.QuickCheck.Monadic where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Property import Control.Monad ( liftM ) import Control.Monad.ST -- instance of monad transformer? -------------------------------------------------------------------------- -- type PropertyM newtype PropertyM m a = MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } instance Functor (PropertyM m) where fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) instance Monad m => Monad (PropertyM m) where return x = MkPropertyM (\k -> k x) MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) fail s = stop (failed { reason = s }) 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 () assert :: Monad m => Bool -> PropertyM m () assert True = return () assert False = fail "Assertion failed" -- should think about strictness/exceptions here pre :: Monad m => Bool -> PropertyM m () pre True = return () pre False = stop rejected -- should be called lift? run :: Monad m => m a -> PropertyM m a run m = MkPropertyM (liftM (m >>=) . promote) 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))) wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b wp m k = run m >>= k forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k monitor :: Monad m => (Property -> Property) -> PropertyM m () monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) -- run functions monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property monadic runner m = property (fmap runner (monadic' m)) monadic' :: Monad m => PropertyM m a -> Gen (m Property) monadic' (MkPropertyM m) = m (const (return (return (property True)))) monadicIO :: PropertyM IO a -> Property monadicIO = monadic morallyDubiousIOProperty #ifndef NO_ST_MONAD monadicST :: (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m)) runSTGen :: (forall s. Gen (ST s a)) -> Gen a runSTGen g = MkGen $ \r n -> runST (unGen g r n) #endif -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Test.hs0000644000000000000000000003676112116126475016007 0ustar0000000000000000module Test.QuickCheck.Test where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, interrupted ) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text import Test.QuickCheck.State import Test.QuickCheck.Exception import System.Random ( split , newStdGen , StdGen ) import Data.Char ( isSpace ) import Data.List ( sort , group , groupBy , intersperse ) -------------------------------------------------------------------------- -- quickCheck -- * Running tests -- | Args specifies arguments to the QuickCheck driver data Args = Args { replay :: Maybe (StdGen,Int) -- ^ should we replay a previous test? , maxSuccess :: Int -- ^ maximum number of successful tests before succeeding , maxDiscardRatio :: Int -- ^ maximum number of discarded tests per successful test before giving up , maxSize :: Int -- ^ size to use for the biggest test cases , chatty :: Bool -- ^ whether to print anything } deriving ( Show, Read ) -- | Result represents the test result data Result = Success -- a successful test run { numTests :: Int -- ^ number of successful tests performed , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests , output :: String -- ^ printed output } | GaveUp -- given up { numTests :: Int -- ^ number of successful tests performed , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests , output :: String -- ^ printed output } | Failure -- failed test run { numTests :: Int -- ^ number of tests performed , numShrinks :: Int -- ^ number of successful shrinking steps performed , usedSeed :: StdGen -- ^ what seed was used , usedSize :: Int -- ^ what was the test size , reason :: String -- ^ what was the reason , interrupted :: Bool -- ^ did the user press ctrl-C? , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests , output :: String -- ^ printed output } | NoExpectedFailure -- the expected failure did not happen { numTests :: Int -- ^ number of tests performed , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests , output :: String -- ^ printed output } deriving ( Show, Read ) -- | isSuccess checks if the test run result was a success isSuccess :: Result -> Bool isSuccess Success{} = True isSuccess _ = False -- | stdArgs are the default test arguments used stdArgs :: Args stdArgs = Args { replay = Nothing , maxSuccess = 100 , maxDiscardRatio = 10 , maxSize = 100 , chatty = True -- noShrinking flag? } -- | Tests a property and prints the results to 'stdout'. quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p -- | Tests a property, using test arguments, and prints the results to 'stdout'. quickCheckWith :: Testable prop => Args -> prop -> IO () quickCheckWith args p = quickCheckWithResult args p >> return () -- | Tests a property, produces a test result, and prints the results to 'stdout'. quickCheckResult :: Testable prop => prop -> IO Result quickCheckResult p = quickCheckWithResult stdArgs p -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. quickCheckWithResult :: Testable prop => Args -> prop -> IO Result quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of Nothing -> newStdGen Just (rnd,_) -> return rnd test MkState{ terminal = tm , maxSuccessTests = if exhaustive p then 1 else maxSuccess a , maxDiscardedTests = if exhaustive p then maxDiscardRatio a else maxDiscardRatio a * maxSuccess a , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s , numSuccessTests = 0 , numDiscardedTests = 0 , numRecentlyDiscardedTests = 0 , collected = [] , expectedFailure = False , randomSeed = rnd , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 } (unGen (property p)) where computeSize' n d -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. | n `roundTo` maxSize a + maxSize a <= maxSuccess a || n >= maxSuccess a || maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a | otherwise = ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a n `roundTo` m = (n `div` m) * m at0 f s 0 0 = s at0 f s n d = f n d -- | Tests a property and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that means the same as 'quickCheck' '.' 'verbose'. verboseCheck :: Testable prop => prop -> IO () verboseCheck p = quickCheck (verbose p) -- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. verboseCheckWith :: Testable prop => Args -> prop -> IO () verboseCheckWith args p = quickCheckWith args (verbose p) -- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. verboseCheckResult :: Testable prop => prop -> IO Result verboseCheckResult p = quickCheckResult (verbose p) -- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result verboseCheckWithResult a p = quickCheckWithResult a (verbose p) -------------------------------------------------------------------------- -- main test loop test :: State -> (StdGen -> Int -> Prop) -> IO Result test st f | numSuccessTests st >= maxSuccessTests st = doneTesting st f | numDiscardedTests st >= maxDiscardedTests st = giveUp st f | otherwise = runATest st f doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result doneTesting st _f = do -- CALLBACK done_testing? if expectedFailure st then putPart (terminal st) ( "+++ OK, passed " ++ show (numSuccessTests st) ++ " tests" ) else putPart (terminal st) ( bold ("*** Failed!") ++ " Passed " ++ show (numSuccessTests st) ++ " tests (expected failure)" ) success st theOutput <- terminalOutput (terminal st) if expectedFailure st then return Success{ labels = summary st, numTests = numSuccessTests st, output = theOutput } else return NoExpectedFailure{ labels = summary st, numTests = numSuccessTests st, output = theOutput } giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result giveUp st _f = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") ++ " Passed only " ++ show (numSuccessTests st) ++ " tests" ) success st theOutput <- terminalOutput (terminal st) return GaveUp{ numTests = numSuccessTests st , labels = summary st , output = theOutput } runATest :: State -> (StdGen -> Int -> Prop) -> IO Result runATest st f = do -- CALLBACK before_test putTemp (terminal st) ( "(" ++ number (numSuccessTests st) "test" ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" | numDiscardedTests st > 0 ] ++ ")" ) let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size))) callbackPostTest st res let continue break st' | abort res = break st' | otherwise = test st' case res of MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test do continue doneTesting st{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 , randomSeed = rnd2 , collected = stamp : collected st , expectedFailure = expect } f MkResult{ok = Nothing, expect = expect} -> -- discarded test do continue giveUp st{ numDiscardedTests = numDiscardedTests st + 1 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 , randomSeed = rnd2 , expectedFailure = expect } f MkResult{ok = Just False} -> -- failed test do if expect res then putPart (terminal st) (bold "*** Failed! ") else putPart (terminal st) "+++ OK, failed as expected. " numShrinks <- foundFailure st res ts theOutput <- terminalOutput (terminal st) if not (expect res) then return Success{ labels = summary st, numTests = numSuccessTests st+1, output = theOutput } else return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) , usedSize = size , numTests = numSuccessTests st+1 , numShrinks = numShrinks , output = theOutput , reason = P.reason res , interrupted = P.interrupted res , labels = summary st } where (rnd1,rnd2) = split (randomSeed st) summary :: State -> [(String,Int)] summary st = reverse . sort . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st)) . group . sort $ [ concat (intersperse ", " s') | s <- collected st , let s' = [ t | (t,_) <- s ] , not (null s') ] success :: State -> IO () success st = case allLabels ++ covers of [] -> do putLine (terminal st) "." [pt] -> do putLine (terminal st) ( " (" ++ dropWhile isSpace pt ++ ")." ) cases -> do putLine (terminal st) ":" sequence_ [ putLine (terminal st) pt | pt <- cases ] where allLabels = reverse . sort . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss)) . group . sort $ [ concat (intersperse ", " s') | s <- collected st , let s' = [ t | (t,0) <- s ] , not (null s') ] covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%") | lps <- groupBy first . sort $ [ lp | lps <- collected st , lp <- maxi lps , snd lp > 0 ] , let occurP = (100 * length lps) `div` maxSuccessTests st reqP = maximum (map snd lps) , occurP < reqP ] (x,_) `first` (y,_) = x == y maxi = map (\lps -> (fst (head lps), maximum (map snd lps))) . groupBy first . sort showP p = (if p < 10 then " " else "") ++ show p ++ "% " -------------------------------------------------------------------------- -- main shrinking loop foundFailure :: State -> P.Result -> [Rose P.Result] -> IO Int foundFailure st res ts = do localMin st{ numTryShrinks = 0 } res ts localMin :: State -> P.Result -> [Rose P.Result] -> IO Int localMin st res _ | P.interrupted res = localMinFound st res localMin st res ts = do putTemp (terminal st) ( short 26 (oneLine (P.reason res)) ++ " (after " ++ number (numSuccessTests st+1) "test" ++ concat [ " and " ++ show (numSuccessShrinks st) ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ] ++ " shrink" ++ (if numSuccessShrinks st == 1 && numTryShrinks st == 0 then "" else "s") | numSuccessShrinks st > 0 || numTryShrinks st > 0 ] ++ ")..." ) 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 localMin' st res [] = localMinFound st res localMin' st res (t:ts) = do -- CALLBACK before_test MkRose res' ts' <- protectRose (reduceRose t) callbackPostTest st res' if ok res' == Just False then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts' else localMin st{ numTryShrinks = numTryShrinks st + 1, numTotTryShrinks = numTotTryShrinks st + 1 } res ts localMinFound :: State -> P.Result -> IO Int localMinFound st res = do let report = concat [ "(after " ++ number (numSuccessTests st+1) "test", concat [ " and " ++ number (numSuccessShrinks st) "shrink" | numSuccessShrinks st > 0 ], "): " ] if isOneLine (P.reason res) then putLine (terminal st) (P.reason res ++ " " ++ report) else do putLine (terminal st) report sequence_ [ putLine (terminal st) msg | msg <- lines (P.reason res) ] callbackPostFinalFailure st res return (numSuccessShrinks st) -------------------------------------------------------------------------- -- callbacks callbackPostTest :: State -> P.Result -> IO () callbackPostTest st res = sequence_ [ safely st (f st res) | PostTest _ f <- callbacks res ] callbackPostFinalFailure :: State -> P.Result -> IO () callbackPostFinalFailure st res = sequence_ [ safely st (f st res) | PostFinalFailure _ f <- callbacks res ] safely :: State -> IO () -> IO () safely st x = do r <- tryEvaluateIO x case r of Left e -> putLine (terminal st) ("*** Exception in callback: " ++ show e) Right x -> return x -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Exception.hs0000644000000000000000000000511612116126475017014 0ustar0000000000000000-- Hide away the nasty implementation-specific ways of catching -- exceptions behind a nice API. The main trouble is catching ctrl-C. {-# LANGUAGE CPP #-} module Test.QuickCheck.Exception where #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 609) #define OLD_EXCEPTIONS #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 607 #define GHC_INTERRUPT #if __GLASGOW_HASKELL__ < 613 #define GHCI_INTERRUPTED_EXCEPTION #endif #if __GLASGOW_HASKELL__ >= 700 #define NO_BASE_3 #endif #endif #if defined(OLD_EXCEPTIONS) || defined(NO_BASE_3) import qualified Control.Exception as E #else import qualified Control.Exception.Extensible as E #endif #if defined(GHC_INTERRUPT) #if defined(GHCI_INTERRUPTED_EXCEPTION) import Panic(GhcException(Interrupted)) #endif import Data.Typeable #if defined(OLD_EXCEPTIONS) import Data.Dynamic #endif #endif #if defined(OLD_EXCEPTIONS) type AnException = E.Exception #else type AnException = E.SomeException #endif -------------------------------------------------------------------------- -- try evaluate tryEvaluate :: a -> IO (Either AnException a) tryEvaluate x = tryEvaluateIO (return x) tryEvaluateIO :: IO a -> IO (Either AnException a) tryEvaluateIO m = E.try (m >>= E.evaluate) --tryEvaluateIO m = Right `fmap` m -- Test if an exception was a ^C. -- QuickCheck won't try to shrink an interrupted test case. isInterrupt :: AnException -> Bool #if defined(GHC_INTERRUPT) #if defined(OLD_EXCEPTIONS) isInterrupt (E.DynException e) = fromDynamic e == Just Interrupted isInterrupt _ = False #elif defined(GHCI_INTERRUPTED_EXCEPTION) isInterrupt (E.SomeException e) = cast e == Just Interrupted || cast e == Just E.UserInterrupt #else isInterrupt (E.SomeException e) = cast e == Just E.UserInterrupt #endif #else /* !defined(GHC_INTERRUPT) */ isInterrupt _ = False #endif -- | A special exception that makes QuickCheck discard the test case. -- Normally you should use '==>', but if for some reason this isn't -- possible (e.g. you are deep inside a generator), use 'discard' -- instead. discard :: a isDiscard :: AnException -> Bool (discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) where msg = "DISCARD. " ++ "You should not see this exception, it is internal to QuickCheck." #if defined(OLD_EXCEPTIONS) isDiscard (E.ErrorCall msg') = msg' == msg isDiscard _ = False #else isDiscard (E.SomeException e) = case cast e of Just (E.ErrorCall msg') -> msg' == msg _ -> False #endif finally :: IO a -> IO b -> IO a finally = E.finally -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Poly.hs0000644000000000000000000000614012116126475015777 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif -- | Types to help with testing polymorphic properties. -- -- Types 'A', 'B' and 'C' are @newtype@ wrappers around 'Integer' that -- implement 'Eq', 'Show', 'Arbitrary' and 'CoArbitrary'. Types -- 'OrdA', 'OrdB' and 'OrdC' also implement 'Ord' and 'Num'. -- -- See also "Test.QuickCheck.All" for an experimental way of testing -- polymorphic properties. module Test.QuickCheck.Poly ( A(..), B(..), C(..) , OrdA(..), OrdB(..), OrdC(..) ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Arbitrary -------------------------------------------------------------------------- -- polymorphic A, B, C (in Eq) -- A newtype A = A{ unA :: Integer } deriving ( Eq ) instance Show A where showsPrec n (A x) = showsPrec n x instance Arbitrary A where arbitrary = (A . (+1) . abs) `fmap` arbitrary shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ] instance CoArbitrary A where coarbitrary = coarbitrary . unA -- B newtype B = B{ unB :: Integer } deriving ( Eq ) instance Show B where showsPrec n (B x) = showsPrec n x instance Arbitrary B where arbitrary = (B . (+1) . abs) `fmap` arbitrary shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ] instance CoArbitrary B where coarbitrary = coarbitrary . unB -- C newtype C = C{ unC :: Integer } deriving ( Eq ) instance Show C where showsPrec n (C x) = showsPrec n x instance Arbitrary C where arbitrary = (C . (+1) . abs) `fmap` arbitrary shrink (C x) = [ C x' | x' <- shrink x, x' > 0 ] instance CoArbitrary C where coarbitrary = coarbitrary . unC -------------------------------------------------------------------------- -- polymorphic OrdA, OrdB, OrdC (in Eq, Ord) -- OrdA newtype OrdA = OrdA{ unOrdA :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdA where showsPrec n (OrdA x) = showsPrec n x instance Arbitrary OrdA where arbitrary = (OrdA . (+1) . abs) `fmap` arbitrary shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdA where coarbitrary = coarbitrary . unOrdA -- OrdB newtype OrdB = OrdB{ unOrdB :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdB where showsPrec n (OrdB x) = showsPrec n x instance Arbitrary OrdB where arbitrary = (OrdB . (+1) . abs) `fmap` arbitrary shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdB where coarbitrary = coarbitrary . unOrdB -- OrdC newtype OrdC = OrdC{ unOrdC :: Integer } deriving ( Eq, Ord #ifndef NO_NEWTYPE_DERIVING , Num #endif ) instance Show OrdC where showsPrec n (OrdC x) = showsPrec n x instance Arbitrary OrdC where arbitrary = (OrdC . (+1) . abs) `fmap` arbitrary shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ] instance CoArbitrary OrdC where coarbitrary = coarbitrary . unOrdC -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Arbitrary.hs0000644000000000000000000004027712116126475017024 0ustar0000000000000000module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes Arbitrary(..) , CoArbitrary(..) -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral -- :: Num a => Gen a , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedFractional -- :: Fractional a => Gen a , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a -- ** Helper functions for implementing shrink , shrinkNothing -- :: a -> [a] , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] , shrinkIntegral -- :: Integral a => a -> [a] , shrinkRealFrac -- :: RealFrac a => a -> [a] -- ** Helper functions for implementing coarbitrary , (><) , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b -- ** Generators which use arbitrary , vector -- :: Arbitrary a => Int -> Gen [a] , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen {- import Data.Generics ( (:*:)(..) , (:+:)(..) , Unit(..) ) -} import Data.Char ( chr , ord , isLower , isUpper , toLower , isDigit , isSpace ) import Data.Fixed ( Fixed , HasResolution ) import Data.Ratio ( Ratio , (%) , numerator , denominator ) import Data.Complex ( Complex((:+)) ) import System.Random ( Random ) import Data.List ( sort , nub ) import Control.Monad ( liftM , liftM2 , liftM3 , liftM4 , liftM5 ) import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. class Arbitrary a where -- | A generator for values of the given type. arbitrary :: Gen a arbitrary = error "no default generator" -- | Produces a (possibly) empty list of all the possible -- immediate shrinks of the given value. shrink :: a -> [a] shrink _ = [] -- instances instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where arbitrary = promote (`coarbitrary` arbitrary) instance Arbitrary () where arbitrary = return () instance Arbitrary Bool where arbitrary = choose (False,True) shrink True = [False] shrink False = [] instance Arbitrary Ordering where arbitrary = arbitraryBoundedEnum shrink GT = [EQ, LT] shrink LT = [EQ] shrink EQ = [] instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)] shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ] shrink _ = [] instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary] shrink (Left x) = [ Left x' | x' <- shrink x ] shrink (Right y) = [ Right y' | y' <- shrink y ] instance Arbitrary a => Arbitrary [a] where arbitrary = sized $ \n -> do k <- choose (0,n) sequence [ arbitrary | _ <- [1..k] ] shrink xs = shrinkList shrink xs 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 a) => Arbitrary (Ratio a) where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where arbitrary = liftM2 (:+) arbitrary arbitrary shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ [ x :+ y' | y' <- shrink y ] instance HasResolution a => Arbitrary (Fixed a) where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where arbitrary = liftM2 (,) arbitrary arbitrary shrink (x,y) = [ (x',y) | x' <- shrink x ] ++ [ (x,y') | y' <- shrink y ] instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a,b,c) where arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary shrink (x,y,z) = [ (x',y,z) | x' <- shrink x ] ++ [ (x,y',z) | y' <- shrink y ] ++ [ (x,y,z') | z' <- shrink 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' <- shrink w ] ++ [ (w,x',y,z) | x' <- shrink x ] ++ [ (w,x,y',z) | y' <- shrink y ] ++ [ (w,x,y,z') | z' <- shrink 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' <- shrink v ] ++ [ (v,w',x,y,z) | w' <- shrink w ] ++ [ (v,w,x',y,z) | x' <- shrink x ] ++ [ (v,w,x,y',z) | y' <- shrink y ] ++ [ (v,w,x,y,z') | z' <- shrink z ] -- typical instance for primitive (numerical) types instance Arbitrary Integer where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral instance Arbitrary Int where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Char where arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)] shrink c = filter (<. c) $ nub $ ['a','b','c'] ++ [ toLower c | isUpper c ] ++ ['A','B','C'] ++ ['1','2','3'] ++ [' ','\n'] where a <. b = stamp a < stamp b stamp a = ( (not (isLower a) , not (isUpper a) , not (isDigit a)) , (not (a==' ') , not (isSpace a) , a) ) instance Arbitrary Float where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance Arbitrary Double where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac -- ** Helper functions for implementing arbitrary -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Num a => Gen a arbitrarySizedIntegral = sized $ \n -> let n' = toInteger n in fmap fromInteger (choose (-n', n')) -- | Generates a fractional number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedFractional :: Fractional a => Gen a arbitrarySizedFractional = sized $ \n -> let n' = toInteger n in do a <- choose ((-n') * precision, n' * precision) b <- choose (1, precision) return (fromRational (a % b)) where precision = 9999999999999 :: Integer -- | 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 = do let mn = minBound mx = maxBound `asTypeOf` mn n <- choose (toInteger mn, toInteger mx) return (fromInteger n `asTypeOf` mn) -- | 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 = do let mn = minBound mx = maxBound `asTypeOf` mn n <- choose (fromEnum mn, fromEnum mx) return (toEnum n `asTypeOf` mn) -- | Generates an integral number from a bounded domain. The number is -- chosen from the entire range of the type, but small numbers are -- generated more often than big numbers. Inspired by demands from -- Phil Wadler. arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitrarySizedBoundedIntegral = sized $ \s -> do let mn = minBound mx = maxBound `asTypeOf` mn bits n | n `quot` 2 == 0 = 0 | otherwise = 1 + bits (n `quot` 2) k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100) n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) return (fromInteger n `asTypeOf` mn) -- ** Helper functions for implementing shrink -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = nub $ [ -x | x < 0, -x > x ] ++ [ x' | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) ] where -- a << b is "morally" abs a < abs b, but taking care of overflow. a << b = case (a >= 0, b >= 0) of (True, True) -> a < b (False, False) -> a > b (True, False) -> a + b < 0 (False, True) -> a + b > 0 -- | Shrink a fraction. shrinkRealFrac :: RealFrac a => a -> [a] shrinkRealFrac x = nub $ [ -x | x < 0 ] ++ [ x' | x' <- [fromInteger (truncate x)] , x' << x ] where a << b = abs a < abs b -------------------------------------------------------------------------- -- ** CoArbitrary -- | Used for random generation of functions. class CoArbitrary a where -- | Used to generate a function of type @a -> c@. The implementation -- should use the first argument to perturb the random generator -- given as the second argument. the returned generator -- is then used to generate the function result. -- You can often use 'variant' and '><' to implement -- 'coarbitrary'. coarbitrary :: a -> Gen c -> Gen c {- -- GHC definition: coarbitrary{| Unit |} Unit = id coarbitrary{| a :*: b |} (x :*: y) = coarbitrary x >< coarbitrary y coarbitrary{| a :+: b |} (Inl x) = variant 0 . coarbitrary x coarbitrary{| a :+: b |} (Inr y) = variant (-1) . coarbitrary y -} -- | 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) (><) f g gen = do n <- arbitrary (g . variant (n :: Int) . f) gen -- for the sake of non-GHC compilers, I have added definitions -- for coarbitrary here. 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 1 coarbitrary EQ = variant 0 coarbitrary LT = variant (-1) 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) instance HasResolution a => CoArbitrary (Fixed a) where coarbitrary = coarbitraryReal instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where coarbitrary (x :+ y) = coarbitrary x >< coarbitrary y instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a,b) where coarbitrary (x,y) = coarbitrary x >< coarbitrary y instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a,b,c) where coarbitrary (x,y,z) = coarbitrary x >< coarbitrary y >< coarbitrary z instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a,b,c,d) where coarbitrary (x,y,z,v) = coarbitrary x >< coarbitrary y >< coarbitrary z >< coarbitrary v instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) => CoArbitrary (a,b,c,d,e) where coarbitrary (x,y,z,v,w) = coarbitrary x >< coarbitrary y >< coarbitrary z >< coarbitrary v >< coarbitrary w -- typical instance for primitive (numerical) types instance CoArbitrary Integer where coarbitrary = coarbitraryIntegral instance CoArbitrary Int where coarbitrary = coarbitraryIntegral instance CoArbitrary Int8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word where coarbitrary = coarbitraryIntegral instance CoArbitrary Word8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Char where coarbitrary = coarbitrary . ord instance CoArbitrary Float where coarbitrary = coarbitraryReal instance CoArbitrary Double where coarbitrary = coarbitraryReal -- ** 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 of a given length. orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/All.hs0000644000000000000000000001132012116126475015560 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, Rank2Types #-} -- | Experimental features using Template Haskell. -- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in -- your module for any of these to work. module Test.QuickCheck.All( -- ** Testing all properties in a module. quickCheckAll, verboseCheckAll, forAllProperties, -- ** Testing polymorphic properties. polyQuickCheck, polyVerboseCheck, mono) where import Language.Haskell.TH import Test.QuickCheck.Property hiding (Result) import Test.QuickCheck.Test import Data.Char import Data.List import Control.Monad -- | 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 :: Name -> ExpQ polyQuickCheck x = [| quickCheck $(mono x) |] -- | Test a polymorphic property, defaulting all type variables to 'Integer'. -- This is just a convenience function that combines 'polyQuickCheck' and 'verbose'. polyVerboseCheck :: Name -> ExpQ polyVerboseCheck x = [| verboseCheck $(mono x) |] type Error = forall a. String -> a -- | Monomorphise an arbitrary name by defaulting all type variables to 'Integer'. -- -- For example, if @f@ has type @'Ord' a => [a] -> [a]@ -- then @$('mono' 'f)@ has type @['Integer'] -> ['Integer']@. mono :: Name -> ExpQ mono t = do ty0 <- fmap infoType (reify t) let err msg = error $ msg ++ ": " ++ pprint ty0 (polys, ctx, ty) <- deconstructType err ty0 case polys of [] -> return (VarE t) _ -> do integer <- [t| Integer |] ty' <- monomorphise err integer ty return (SigE (VarE t) ty') infoType :: Info -> Type infoType (ClassOpI _ ty _ _) = ty infoType (DataConI _ ty _ _) = ty infoType (VarI _ ty _ _) = ty deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) deconstructType err ty0@(ForallT xs ctx ty) = do let plain (PlainTV _) = True 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) monomorphise :: Error -> Type -> Type -> TypeQ monomorphise err mono ty@(VarT n) = return mono monomorphise err mono (AppT t1 t2) = liftM2 AppT (monomorphise err mono t1) (monomorphise err mono t2) monomorphise err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" monomorphise 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 :: Q Exp -- :: (Property -> IO Result) -> IO Bool forAllProperties = do Loc { loc_filename = filename } <- location when (filename == "") $ error "don't run this interactively" ls <- runIO (fmap lines (readFile filename)) let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile (\c -> isSpace c || c == '>')) ls idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes)) quickCheckOne :: (Int, String) -> Q [Exp] quickCheckOne (l, x) = do exists <- return False `recover` (reify (mkName x) >> return True) if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), property $(mono (mkName x))) |] ] else return [] [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] -- | 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. -- -- Using 'quickCheckAll' interactively doesn't work. -- Instead, add a definition to your module along the lines of -- -- > runTests = $quickCheckAll -- -- and then execute @runTests@. 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 :: Q Exp verboseCheckAll = [| $(forAllProperties) verboseCheckResult |] runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool runQuickCheckAll ps qc = fmap and . forM ps $ \(xs, p) -> do putStrLn $ "=== " ++ xs ++ " ===" r <- qc p putStrLn "" return $ case r of Success { } -> True Failure { } -> False NoExpectedFailure { } -> False GaveUp { } -> False QuickCheck-2.6/Test/QuickCheck/Text.hs0000644000000000000000000000711712116126475016005 0ustar0000000000000000module Test.QuickCheck.Text ( Str(..) , ranges , number , short , showErr , oneLine , isOneLine , bold , newTerminal , withStdioTerminal , withNullTerminal , terminalOutput , handle , Terminal , putTemp , putPart , putLine ) where -------------------------------------------------------------------------- -- imports import Control.Applicative import System.IO ( hFlush , hPutStr , stdout , stderr , Handle , BufferMode (..) , hGetBuffering , hSetBuffering ) import Data.IORef import Test.QuickCheck.Exception -------------------------------------------------------------------------- -- literal string newtype Str = MkStr String instance Show Str where show (MkStr s) = s ranges :: (Show a, Integral a) => a -> a -> Str ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1)) where n' = k * (n `div` k) -------------------------------------------------------------------------- -- formatting number :: Int -> String -> String number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" short :: Int -> String -> String short n s | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s | otherwise = s where k = length s i = if n >= 5 then 3 else 0 showErr :: Show a => a -> String showErr = unwords . words . show oneLine :: String -> String oneLine = unwords . words isOneLine :: String -> Bool isOneLine xs = '\n' `notElem` xs bold :: String -> String -- not portable: --bold s = "\ESC[1m" ++ s ++ "\ESC[0m" bold s = s -- for now -------------------------------------------------------------------------- -- putting strings data Terminal = MkTerminal (IORef (IO ())) Output Output data Output = Output (String -> IO ()) (IORef String) newTerminal :: Output -> Output -> IO Terminal newTerminal out err = do ref <- newIORef (return ()) return (MkTerminal ref out err) withBuffering :: IO a -> IO a withBuffering action = do mode <- hGetBuffering stderr -- By default stderr is unbuffered. This is very slow, hence we explicitly -- enable line buffering. hSetBuffering stderr LineBuffering action `finally` hSetBuffering stderr mode withStdioTerminal :: (Terminal -> IO a) -> IO a withStdioTerminal action = do out <- output (handle stdout) err <- output (handle stderr) withBuffering (newTerminal out err >>= action) withNullTerminal :: (Terminal -> IO a) -> IO a withNullTerminal action = do out <- output (const (return ())) err <- output (const (return ())) newTerminal out err >>= action terminalOutput :: Terminal -> IO String terminalOutput (MkTerminal _ out _) = get out handle :: Handle -> String -> IO () handle h s = do hPutStr h s hFlush h output :: (String -> IO ()) -> IO Output output f = do r <- newIORef "" return (Output f r) put :: Output -> String -> IO () put (Output f r) s = do f s modifyIORef r (++ s) get :: Output -> IO String get (Output _ r) = readIORef r flush :: Terminal -> IO () flush (MkTerminal ref _ _) = do io <- readIORef ref writeIORef ref (return ()) io postpone :: Terminal -> IO () -> IO () postpone (MkTerminal ref _ _) io' = do io <- readIORef ref writeIORef ref (io >> io') putPart, putTemp, putLine :: Terminal -> String -> IO () putPart tm@(MkTerminal _ out _) s = do flush tm put out s putTemp tm@(MkTerminal _ _ err) s = do flush tm put err (s ++ [ '\b' | _ <- s ]) postpone tm $ put err ( [ ' ' | _ <- s ] ++ [ '\b' | _ <- s ] ) putLine tm@(MkTerminal _ out _) s = do flush tm put out (s ++ "\n") -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/Property.hs0000644000000000000000000004107712116126475016710 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.QuickCheck.Property where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( showErr, isOneLine, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State #ifndef NO_TIMEOUT import System.Timeout(timeout) #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 type Property = Gen Prop -- | The class of things which can be tested, i.e. turned into a property. class Testable prop where property :: prop -> Property exhaustive :: prop -> Bool exhaustive _ = False instance Testable Bool where property = property . liftBool exhaustive _ = True instance Testable Result where property = return . MkProp . protectResults . return exhaustive _ = True instance Testable Prop where property (MkProp r) = return . MkProp . ioRose . return $ r exhaustive _ = True instance Testable prop => Testable (Gen prop) where property mp = do p <- mp; property p -- | Do I/O inside a property. This can obviously lead to unrepeatable -- testcases, so use with care. morallyDubiousIOProperty :: Testable prop => IO prop -> Property morallyDubiousIOProperty = fmap (MkProp . ioRose . fmap unProp) . promote . fmap property instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where property f = forAllShrink arbitrary shrink f -- ** Exception handling protect :: (AnException -> a) -> IO a -> IO a protect f x = either f id `fmap` tryEvaluateIO x -------------------------------------------------------------------------- -- ** Type Prop newtype Prop = MkProp{ unProp :: Rose Result } -- ** type Rose data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) -- Only use IORose if you know that the argument is not going to throw an exception! -- Otherwise, try ioRose. ioRose :: IO (Rose Result) -> Rose Result ioRose = IORose . protectRose joinRose :: Rose (Rose a) -> Rose a joinRose (IORose rs) = IORose (fmap joinRose rs) joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) joinRose (MkRose (MkRose x ts) tts) = -- first shrinks outer quantification; makes most sense MkRose x (map joinRose tts ++ ts) -- first shrinks inner quantification: terrible --MkRose x (ts ++ map joinRose tts) instance Functor Rose where -- f must be total fmap f (IORose rs) = IORose (fmap (fmap f) rs) fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] instance Monad Rose where return x = MkRose x [] -- k must be total m >>= k = joinRose (fmap k m) -- Execute the "IORose" bits of a rose tree, returning a tree -- constructed by MkRose. reduceRose :: Rose Result -> IO (Rose Result) reduceRose r@(MkRose _ _) = return r reduceRose (IORose m) = m >>= reduceRose -- Apply a function to the outermost MkRose constructor of a rose tree. -- The function must be total! onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a onRose f (MkRose x rs) = f x rs onRose f (IORose m) = IORose (fmap (onRose f) m) -- Wrap a rose tree in an exception handler. protectRose :: IO (Rose Result) -> IO (Rose Result) protectRose = protect (return . exception "Exception") -- Wrap all the Results in a rose tree in exception handlers. protectResults :: Rose Result -> Rose Result protectResults = onRose $ \x rs -> IORose $ do y <- protectResult (return x) return (MkRose y (map protectResults rs)) -- ** Result type -- | Different kinds of callbacks data Callback = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator | NotCounterexample -- ^ Not affected by the 'verbose' combinator -- | The result of a single test. data Result = MkResult { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard , expect :: Bool -- ^ indicates what the expected result of the property is , reason :: String -- ^ a message indicating what went wrong , interrupted :: Bool -- ^ indicates if the test case was cancelled by pressing ^C , abort :: Bool -- ^ if True, the test should not be repeated , stamp :: [(String,Int)] -- ^ the collected values for this test case , callbacks :: [Callback] -- ^ the callbacks for this test case } result :: Result result = MkResult { ok = undefined , expect = True , reason = "" , interrupted = False , abort = False , stamp = [] , callbacks = [] } exception :: String -> AnException -> Result exception msg err | isDiscard err = rejected | otherwise = failed{ reason = formatException msg err, interrupted = isInterrupt 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 :: Result succeeded = result{ ok = Just True } failed :: Result failed = result{ ok = Just False } rejected :: Result rejected = result{ ok = Nothing } -------------------------------------------------------------------------- -- ** Lifting and mapping functions liftBool :: Bool -> Result liftBool True = succeeded liftBool False = failed { reason = "Falsifiable" } mapResult :: Testable prop => (Result -> Result) -> prop -> Property mapResult f = mapRoseResult (protectResults . fmap f) mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property mapTotalResult f = mapRoseResult (fmap f) -- f here mustn't throw an exception (rose tree invariant). mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property mapProp f = fmap f . property -------------------------------------------------------------------------- -- ** Property combinators -- | Changes the maximum test case size for a property. mapSize :: Testable prop => (Int -> Int) -> prop -> Property mapSize f p = sized ((`resize` property p) . f) -- | Shrinks the argument to property if it fails. Shrinking is done -- automatically for most types. This is only needed when you want to -- override the default behavior. shrinking :: Testable prop => (a -> [a]) -- ^ 'shrink'-like function. -> a -- ^ The original argument -> (a -> prop) -> Property shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0)) where props x = MkRose (property (pf x)) [ props x' | x' <- shrinker x ] -- | Disables shrinking for a property altogether. noShrinking :: Testable prop => prop -> Property noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) -- | Adds a callback callback :: Testable prop => Callback -> prop -> Property callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) -- | Prints a message to the terminal as part of the counterexample. printTestCase :: Testable prop => String -> prop -> Property printTestCase s = callback $ PostFinalFailure Counterexample $ \st _res -> do res <- tryEvaluateIO (putLine (terminal st) s) case res of Left err -> putLine (terminal st) (formatException "Exception thrown by generator" err) Right () -> return () -- | 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, -- like 'verboseCheck' from QuickCheck 1. -- Only variables quantified over /inside/ the 'verbose' are printed. verbose :: Testable prop => prop -> Property verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res }) where newCallbacks cbs = PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")): [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] status MkResult{ok = Just True} = "Passed" status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" -- | Modifies a property so that it is expected to fail for some test cases. expectFailure :: Testable prop => prop -> Property expectFailure = mapTotalResult (\res -> res{ expect = False }) -- | Modifies a property so that it only will be tested once. once :: Testable prop => prop -> Property once = mapTotalResult (\res -> res{ abort = True }) -- | Attaches a label to a property. This is used for reporting -- test case distribution. label :: Testable prop => String -> prop -> Property label s = classify True s -- | Labels a property with a value: -- -- > collect x = label (show x) collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) -- | Conditionally labels test case. classify :: Testable prop => Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property classify b s = cover b 0 s -- | Checks that at least the given proportion of the test cases belong -- to the given class. cover :: Testable prop => Bool -- ^ @True@ if the test case belongs to the class. -> Int -- ^ The required percentage (0-100) of test cases. -> String -- ^ Label for the test case class. -> prop -> Property cover True n s = n `seq` s `listSeq` (mapTotalResult $ \res -> res { stamp = (s,n) : stamp res }) where [] `listSeq` z = z (x:xs) `listSeq` z = x `seq` xs `listSeq` z cover False _ _ = property -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded), -- or if the given property holds. (==>) :: Testable prop => Bool -> prop -> Property False ==> _ = property rejected True ==> p = property p -- | Considers a property failed if it does not complete within -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property within n = mapRoseResult f -- We rely on the fact that the property will catch the timeout -- exception and turn it into a failed test case. where f rose = ioRose $ do let m `orError` x = fmap (fromMaybe (error x)) m MkRose res roses <- timeout n (reduceRose rose) `orError` "within: timeout exception not caught in Rose Result" res' <- timeout n (protectResult (return res)) `orError` "within: timeout exception not caught in Result" return (MkRose res' (map f roses)) #ifdef NO_TIMEOUT timeout _ = fmap Just #endif -- | Explicit universal quantification: uses an explicitly given -- test case generator. forAll :: (Show a, Testable prop) => Gen a -> (a -> prop) -> Property forAll gen pf = gen >>= \x -> printTestCase (show x) (pf x) -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop) => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrink gen shrinker pf = gen >>= \x -> shrinking shrinker x $ \x' -> printTestCase (show x') (pf x') -- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of -- 'p1' and 'p2' to test. If you test the property 100 times it -- makes 100 random choices. (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 = arbitrary >>= \b -> printTestCase (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 = do roses <- mapM (fmap unProp . property) ps return (MkProp (conj [] roses)) where conj cbs [] = MkRose succeeded{callbacks = cbs} [] conj cbs (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 (cbs ++ callbacks result) ps) Just False -> return rose Nothing -> do rose2@(MkRose result2 _) <- reduceRose (conj (cbs ++ callbacks result) 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 -- | 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 = do roses <- mapM (fmap unProp . property) ps return (MkProp (foldr disj (MkRose failed []) roses)) where disj :: Rose Result -> Rose Result -> Rose Result disj p q = do result1 <- p case ok result1 of _ | not (expect result1) -> return expectFailureError Just True -> return result1 Just False -> do result2 <- q return $ if expect result2 then case ok result2 of Just True -> result2 Just False -> result1 >>> result2 Nothing -> result2 else expectFailureError Nothing -> do result2 <- q return (case ok result2 of _ | not (expect result2) -> expectFailureError Just True -> result2 _ -> result1) expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } result1 >>> result2 | not (expect result1 && expect result2) = expectFailureError result1 >>> result2 = result2 { reason = if null (reason result2) then reason result1 else reason result2 , interrupted = interrupted result1 || interrupted result2 , stamp = stamp result1 ++ stamp result2 , callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ callbacks result2 } -------------------------------------------------------------------------- -- the end. QuickCheck-2.6/Test/QuickCheck/State.hs0000644000000000000000000000361712116126475016142 0ustar0000000000000000module Test.QuickCheck.State where import Test.QuickCheck.Text import System.Random( StdGen ) -------------------------------------------------------------------------- -- State -- | State represents QuickCheck's internal state while testing a property. -- The state is made visible to callback functions. data State = MkState -- static { terminal :: Terminal -- ^ the current terminal , maxSuccessTests :: Int -- ^ maximum number of successful tests needed , maxDiscardedTests :: Int -- ^ maximum number of tests that can be discarded , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests -- dynamic , numSuccessTests :: Int -- ^ the current number of tests that have succeeded , numDiscardedTests :: Int -- ^ the current number of discarded tests , numRecentlyDiscardedTests :: Int -- ^ the number of discarded tests since the last successful test , collected :: [[(String,Int)]] -- ^ all labels that have been collected so far , expectedFailure :: Bool -- ^ indicates if the property is expected to fail , randomSeed :: StdGen -- ^ the current random seed -- shrinking , numSuccessShrinks :: Int -- ^ number of successful shrinking steps so far , numTryShrinks :: Int -- ^ number of failed shrinking steps since the last successful shrink , numTotTryShrinks :: Int -- ^ total number of failed shrinking steps } -------------------------------------------------------------------------- -- the end.