QuickCheck 2.4.2 → 2.5

raw patch · 14 files changed

+272/−159 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +8/−8
• QuickCheck.cabal +19/−18
• Test/QuickCheck.hs +9/−4
• Test/QuickCheck/All.hs +6/−4
• Test/QuickCheck/Arbitrary.hs +67/−30
• Test/QuickCheck/Exception.hs +24/−2
• Test/QuickCheck/Function.hs +9/−9
• Test/QuickCheck/Gen.hs +5/−5
• Test/QuickCheck/Modifiers.hs +20/−17
• Test/QuickCheck/Poly.hs +0/−1
• Test/QuickCheck/Property.hs +38/−17
• Test/QuickCheck/State.hs +3/−2
• Test/QuickCheck/Test.hs +52/−38
• Test/QuickCheck/Text.hs +12/−4

@@ -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

@@ -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 <koen@chalmers.se> Maintainer: QuickCheck developers <quickcheck@projects.haskell.org> 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:

@@ -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.

@@ -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

@@ -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

@@ -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.

@@ -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 

@@ -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 ->

@@ -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)

@@ -131,4 +131,3 @@  -------------------------------------------------------------------------- -- the end.-

@@ -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

@@ -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   }  --------------------------------------------------------------------------

@@ -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) 

@@ -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