diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,18 +1,18 @@ -Copyright (c) 2000-2011, Koen Claessen +Copyright (c) 2000-2012, Koen Claessen Copyright (c) 2006-2008, Björn Bringert -Copyright (c) 2009-2011, Nick Smallbone +Copyright (c) 2009-2012, Nick Smallbone All rights reserved. -Redistribution and use in source and binary forms, with or without +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, +- 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 +- 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 +- 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 diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,31 +1,31 @@ Name: QuickCheck -Version: 2.4.2 +Version: 2.5 Cabal-Version: >= 1.6 Build-type: Simple License: BSD3 License-file: LICENSE Extra-source-files: README -Copyright: 2000-2011 Koen Claessen, 2006-2008 Björn Bringert, 2009-2011 Nick Smallbone +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 +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. + 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: darcs @@ -55,7 +55,7 @@ else Build-depends: base < 3 - -- On old versions of GHC use the ghc package to catch ctrl-C. + -- 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 @@ -76,6 +76,8 @@ 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. @@ -96,4 +98,3 @@ cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES Other-Modules: Test.QuickCheck.Exception - GHC-options: diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} module Test.QuickCheck - ( + ( -- * Running tests quickCheck , Args(..), Result(..) @@ -14,7 +14,7 @@ , verboseCheckWithResult , verboseCheckResult , verbose - + -- * Random generation , Gen -- ** Generator combinators @@ -41,13 +41,15 @@ -- * 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 @@ -80,6 +82,7 @@ , mapSize , shrinking , (==>) + , discard , forAll , forAllShrink -- *** Experimental combinators for conjunction and disjunction @@ -99,7 +102,8 @@ , collect , classify , cover - + , once + -- * Text formatting , Str(..) , ranges @@ -115,6 +119,7 @@ import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Text +import Test.QuickCheck.Exception -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs --- a/Test/QuickCheck/All.hs +++ b/Test/QuickCheck/All.hs @@ -72,7 +72,7 @@ -- | 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'@. @@ -86,7 +86,7 @@ quickCheckOne :: (Int, String) -> Q [Exp] quickCheckOne (l, x) = do exists <- return False `recover` (reify (mkName x) >> return True) - if exists then sequence [ [| ($(stringE $ x ++ " on " ++ filename ++ ":" ++ show l), + if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), property $(mono (mkName x))) |] ] else return [] [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] @@ -98,9 +98,9 @@ -- -- 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 |] @@ -115,7 +115,9 @@ 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 --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -1,15 +1,16 @@ module 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]] @@ -20,7 +21,8 @@ , 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] @@ -50,6 +52,11 @@ , isSpace ) +import Data.Fixed + ( Fixed + , HasResolution + ) + import Data.Ratio ( Ratio , (%) @@ -88,7 +95,7 @@ -- | 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] @@ -107,18 +114,24 @@ 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) @@ -134,7 +147,7 @@ shrinkOne [] = [] shrinkOne (x:xs) = [ x':xs | x' <- shr x ] - ++ [ x:xs' | xs' <- shrinkOne xs ] + ++ [ x:xs' | xs' <- shrinkOne xs ] removes k n xs | k > n = [] @@ -161,44 +174,48 @@ 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 @@ -262,7 +279,7 @@ , not (isSpace a) , a) ) - + instance Arbitrary Float where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac @@ -308,6 +325,14 @@ 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 @@ -325,13 +350,13 @@ -- ** Helper functions for implementing shrink --- | Returns no shrinking alternatives. +-- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] -shrinkIntegral x = +shrinkIntegral x = nub $ [ -x | x < 0, -x > x @@ -368,9 +393,9 @@ 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 + -- given as the second argument. the returned generator -- is then used to generate the function result. - -- You can often use 'variant' and '><' to implement + -- You can often use 'variant' and '><' to implement -- 'coarbitrary'. coarbitrary :: a -> Gen c -> Gen c @@ -382,12 +407,12 @@ coarbitrary{| a :+: b |} (Inr y) = variant (-1) . coarbitrary y -} --- | Combine two generator perturbing functions, for example the +-- | 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) +(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) (><) f g gen = do n <- arbitrary - (g . variant (n :: Int) . f) gen + (g . variant (n :: Int) . f) gen -- for the sake of non-GHC compilers, I have added definitions -- for coarbitrary here. @@ -396,7 +421,7 @@ coarbitrary f gen = do xs <- arbitrary coarbitrary (map f xs) gen - + instance CoArbitrary () where coarbitrary _ = id @@ -404,6 +429,11 @@ 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 @@ -411,7 +441,7 @@ 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) @@ -419,6 +449,9 @@ 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 @@ -427,14 +460,14 @@ 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 @@ -442,7 +475,7 @@ >< coarbitrary y >< coarbitrary z >< coarbitrary v - + instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) => CoArbitrary (a,b,c,d,e) where @@ -451,7 +484,7 @@ >< coarbitrary z >< coarbitrary v >< coarbitrary w - + -- typical instance for primitive (numerical) types instance CoArbitrary Integer where @@ -509,6 +542,10 @@ -- | '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 diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs --- a/Test/QuickCheck/Exception.hs +++ b/Test/QuickCheck/Exception.hs @@ -17,9 +17,9 @@ #endif #if defined(OLD_EXCEPTIONS) -import Control.Exception(evaluate, try, Exception(..)) +import Control.Exception(evaluate, try, Exception(..), throw) #else -import Control.Exception.Extensible(evaluate, try, SomeException(SomeException) +import Control.Exception.Extensible(evaluate, try, SomeException(SomeException), ErrorCall(..), throw #if defined(GHC_INTERRUPT) , AsyncException(UserInterrupt) #endif @@ -70,6 +70,28 @@ #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) = (throw (ErrorCall msg), isDiscard) + where + msg = "DISCARD. " ++ + "You should not see this exception, it is internal to QuickCheck." +#if defined(OLD_EXCEPTIONS) + isDiscard (ErrorCall msg') = msg' == msg + isDiscard _ = False +#else + isDiscard (SomeException e) = + case cast e of + Just (ErrorCall msg') -> msg' == msg + _ -> False +#endif + -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs --- a/Test/QuickCheck/Function.hs +++ b/Test/QuickCheck/Function.hs @@ -3,13 +3,13 @@ -- 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): +-- *** Failed! Falsifiable (after 3 tests and 134 shrinks): -- {"elephant"->1, "monkey"->1, _->0} -- -- To generate random values of type @'Fun' a b@, @@ -132,7 +132,7 @@ function :: (a->b) -> (a:->b) -- basic instances - + instance Function () where function f = Unit (f ()) @@ -176,7 +176,7 @@ where g False = Left () g True = Right () - + h (Left _) = False h (Right _) = True @@ -185,13 +185,13 @@ 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 @@ -249,7 +249,7 @@ isNil :: (a :-> b) -> Bool isNil Nil = True isNil _ = False - + Nil .+. Nil = Nil p .+. q = p :+: q @@ -261,7 +261,7 @@ [ table xys' | xys' <- shrinkList shrXy xys ] where shrXy (x,y) = [(x,y') | y' <- shr y] - + table [] = Nil table xys = Table xys diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs --- a/Test/QuickCheck/Gen.hs +++ b/Test/QuickCheck/Gen.hs @@ -37,7 +37,7 @@ instance Monad Gen where return x = MkGen (\_ _ -> x) - + MkGen m >>= k = MkGen (\r n -> let (r1,r2) = split r @@ -84,7 +84,7 @@ -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO () -sample g = +sample g = do cases <- sample' g sequence_ (map print cases) @@ -101,7 +101,7 @@ -- | 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) +gen `suchThatMaybe` p = sized (try 0 . max 1) where try _ 0 = return Nothing try k n = do x <- resize (2*k+n) gen @@ -144,7 +144,7 @@ log' = round . log . fromIntegral size n = (log' n + 1) * k `div` log' mx -{- WAS: +{- WAS: growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) where k = length xs @@ -157,7 +157,7 @@ do k <- choose (0,n) vectorOf k gen --- | Generates a non-empty list of random length. The maximum length +-- | 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 -> diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs --- a/Test/QuickCheck/Modifiers.hs +++ b/Test/QuickCheck/Modifiers.hs @@ -10,9 +10,9 @@ -- 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']) = @@ -90,12 +90,12 @@ 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 [a] +newtype OrderedList a = Ordered {getOrdered :: [a]} deriving ( Eq, Ord, Show, Read ) instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where @@ -109,7 +109,7 @@ -------------------------------------------------------------------------- -- | @NonEmpty xs@: guarantees that xs is non-empty. -newtype NonEmptyList a = NonEmpty [a] +newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} deriving ( Eq, Ord, Show, Read ) instance Arbitrary a => Arbitrary (NonEmptyList a) where @@ -123,7 +123,7 @@ -------------------------------------------------------------------------- -- | @Positive x@: guarantees that @x \> 0@. -newtype Positive a = Positive a +newtype Positive a = Positive {getPositive :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum @@ -131,7 +131,8 @@ ) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where arbitrary = - (Positive . abs) `fmap` (arbitrary `suchThat` (/= 0)) + ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0 + where gt0 (Positive x) = x > 0 shrink (Positive x) = [ Positive x' @@ -141,7 +142,7 @@ -------------------------------------------------------------------------- -- | @NonZero x@: guarantees that @x \/= 0@. -newtype NonZero a = NonZero a +newtype NonZero a = NonZero {getNonZero :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum @@ -155,7 +156,7 @@ -------------------------------------------------------------------------- -- | @NonNegative x@: guarantees that @x \>= 0@. -newtype NonNegative a = NonNegative a +newtype NonNegative a = NonNegative {getNonNegative :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum @@ -164,11 +165,13 @@ 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)) - ] + (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' @@ -219,14 +222,14 @@ [] `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 @@ -235,7 +238,7 @@ -- 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) diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs --- a/Test/QuickCheck/Poly.hs +++ b/Test/QuickCheck/Poly.hs @@ -131,4 +131,3 @@ -------------------------------------------------------------------------- -- the end. - diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- a/Test/QuickCheck/Property.hs +++ b/Test/QuickCheck/Property.hs @@ -6,7 +6,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Text( showErr, putLine ) +import Test.QuickCheck.Text( showErr, isOneLine, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State @@ -60,18 +60,20 @@ -- | The class of things which can be tested, i.e. turned into a property. class Testable prop where property :: prop -> Property - -instance Testable () where - property _ = property rejected + 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 @@ -107,7 +109,7 @@ joinRose (MkRose (MkRose x ts) tts) = -- first shrinks outer quantification; makes most sense MkRose x (map joinRose tts ++ ts) - -- first shrinks inner quantification + -- first shrinks inner quantification: terrible --MkRose x (ts ++ map joinRose tts) instance Functor Rose where @@ -159,6 +161,7 @@ , 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 } @@ -170,18 +173,26 @@ , expect = True , reason = "" , interrupted = False + , abort = False , stamp = [] , callbacks = [] } exception :: String -> AnException -> Result -exception msg err = failed{ reason = msg ++ ": '" ++ showErr err ++ "'", - interrupted = isInterrupt err } +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 succeeded = result{ ok = Just True } failed :: Result @@ -240,8 +251,13 @@ -- | Prints a message to the terminal as part of the counterexample. printTestCase :: Testable prop => String -> prop -> Property printTestCase s = - callback $ PostFinalFailure Counterexample $ \st _res -> - putLine (terminal st) 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 @@ -250,7 +266,7 @@ m -- | Performs an 'IO' action every time a property fails. Thus, --- if shrinking is done, this can be used to keep track of the +-- 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 = @@ -275,6 +291,10 @@ 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 @@ -287,7 +307,7 @@ collect x = label (show x) -- | Conditionally labels test case. -classify :: Testable prop => +classify :: Testable prop => Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property @@ -295,7 +315,7 @@ -- | Checks that at least the given proportion of the test cases belong -- to the given class. -cover :: Testable prop => +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. @@ -306,9 +326,10 @@ cover False _ _ = property -- | Implication for properties: The resulting property holds if --- the first argument is 'False', or if the given property holds. +-- 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 () +False ==> _ = property rejected True ==> p = property p -- | Considers a property failed if it does not complete within @@ -360,7 +381,7 @@ -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property -conjoin ps = +conjoin ps = do roses <- mapM (fmap unProp . property) ps return (MkProp (conj [] roses)) where @@ -389,7 +410,7 @@ -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property -disjoin ps = +disjoin ps = do roses <- mapM (fmap unProp . property) ps return (MkProp (foldr disj (MkRose failed []) roses)) where diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs --- a/Test/QuickCheck/State.hs +++ b/Test/QuickCheck/State.hs @@ -16,17 +16,18 @@ , 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 , 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 } -------------------------------------------------------------------------- diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -34,11 +34,11 @@ -- | 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 - , maxDiscard :: Int -- ^ maximum number of discarded tests before giving up - , maxSize :: Int -- ^ size to use for the biggest test cases - , chatty :: Bool -- ^ whether to print anything + { 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 ) @@ -78,11 +78,11 @@ -- | stdArgs are the default test arguments used stdArgs :: Args stdArgs = Args - { replay = Nothing - , maxSuccess = 100 - , maxDiscard = 500 - , maxSize = 100 - , chatty = True + { replay = Nothing + , maxSuccess = 100 + , maxDiscardRatio = 10 + , maxSize = 100 + , chatty = True -- noShrinking flag? } @@ -106,8 +106,8 @@ Nothing -> newStdGen Just (rnd,_) -> return rnd test MkState{ terminal = tm - , maxSuccessTests = maxSuccess a - , maxDiscardedTests = maxDiscard a + , 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 @@ -118,6 +118,7 @@ , 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: @@ -186,7 +187,7 @@ return NoExpectedFailure{ labels = summary st, numTests = numSuccessTests st, output = theOutput } - + giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result giveUp st _f = do -- CALLBACK gave_up? @@ -217,21 +218,26 @@ let size = computeSize st (numSuccessTests st) (numDiscardedTests 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 test st{ numSuccessTests = numSuccessTests st + 1 - , randomSeed = rnd2 - , collected = stamp : collected st - , expectedFailure = expect - } f - + do continue doneTesting + st{ numSuccessTests = numSuccessTests st + 1 + , randomSeed = rnd2 + , collected = stamp : collected st + , expectedFailure = expect + } f + MkResult{ok = Nothing, expect = expect} -> -- discarded test - do test st{ numDiscardedTests = numDiscardedTests st + 1 - , randomSeed = rnd2 - , expectedFailure = expect - } f - + do continue giveUp + st{ numDiscardedTests = numDiscardedTests st + 1 + , randomSeed = rnd2 + , expectedFailure = expect + } f + MkResult{ok = Just False} -> -- failed test do if expect res then putPart (terminal st) (bold "*** Failed! ") @@ -288,7 +294,7 @@ , let s' = [ t | (t,0) <- s ] , not (null s') ] - + covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%") | lps <- groupBy first . sort @@ -301,9 +307,9 @@ reqP = maximum (map snd lps) , occurP < reqP ] - - (x,_) `first` (y,_) = x == y + (x,_) `first` (y,_) = x == y + maxi = map (\lps -> (fst (head lps), maximum (map snd lps))) . groupBy first . sort @@ -321,7 +327,7 @@ localMin st res _ | P.interrupted res = localMinFound st res localMin st res ts = do putTemp (terminal st) - ( short 26 (P.reason res) + ( short 26 (oneLine (P.reason res)) ++ " (after " ++ number (numSuccessTests st+1) "test" ++ concat [ " and " ++ show (numSuccessShrinks st) @@ -349,18 +355,26 @@ callbackPostTest st res' if ok res' == Just False then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts' - else localMin st{ numTryShrinks = numTryShrinks 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 putLine (terminal st) - ( P.reason res - ++ " (after " ++ number (numSuccessTests st+1) "test" - ++ concat [ " and " ++ number (numSuccessShrinks st) "shrink" - | numSuccessShrinks st > 0 - ] - ++ "): " - ) + 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) diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs --- a/Test/QuickCheck/Text.hs +++ b/Test/QuickCheck/Text.hs @@ -1,12 +1,14 @@ module Test.QuickCheck.Text ( Str(..) , ranges - + , number , short , showErr + , oneLine + , isOneLine , bold - + , newTerminal , newStdioTerminal , newNullTerminal @@ -62,6 +64,12 @@ 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" @@ -129,7 +137,7 @@ putPart tm@(MkTerminal _ out _) s = do flush tm put out s - + putTemp tm@(MkTerminal _ _ err) s = do flush tm put err s @@ -138,7 +146,7 @@ put err ( [ ' ' | _ <- s ] ++ [ '\b' | _ <- s ] ) - + putLine tm@(MkTerminal _ out _) s = do flush tm put out s