diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.5 +Version: 2.5.1 Cabal-Version: >= 1.6 Build-type: Simple License: BSD3 @@ -60,7 +60,7 @@ Build-depends: ghc -- We want to use extensible-exceptions even if linking against base-3. - if impl(ghc >= 6.9) + if impl(ghc >= 6.9) && impl (ghc < 7.0) Build-depends: extensible-exceptions -- Modules that are always built. diff --git a/README b/README --- a/README +++ b/README @@ -1,4 +1,4 @@ -This is QuickCheck 2.4.1.1, a library for random testing of program properties. +This is QuickCheck 2, a library for random testing of program properties. === Installation === @@ -15,6 +15,9 @@ 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 === diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs --- a/Test/QuickCheck/Exception.hs +++ b/Test/QuickCheck/Exception.hs @@ -14,12 +14,21 @@ #if __GLASGOW_HASKELL__ < 613 #define GHCI_INTERRUPTED_EXCEPTION #endif + +#if __GLASGOW_HASKELL__ >= 700 +#define NO_BASE_3 #endif +#endif #if defined(OLD_EXCEPTIONS) import Control.Exception(evaluate, try, Exception(..), throw) #else -import Control.Exception.Extensible(evaluate, try, SomeException(SomeException), ErrorCall(..), throw +#if defined(NO_BASE_3) +import Control.Exception +#else +import Control.Exception.Extensible +#endif + (evaluate, try, SomeException(SomeException), ErrorCall(..), throw #if defined(GHC_INTERRUPT) , AsyncException(UserInterrupt) #endif diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs --- a/Test/QuickCheck/Function.hs +++ b/Test/QuickCheck/Function.hs @@ -32,6 +32,7 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Poly +import Test.QuickCheck.Exception(discard) import Data.Char import Data.Word @@ -90,41 +91,6 @@ table (Table xys) = xys table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] --- finding a default result - --- breadth-first search (can't use depth-first search!) -data Steps a = Step (Steps a) | Fail | Result a - -(#) :: Steps a -> Steps a -> Steps a -Result x # t = Result x -s # Result y = Result y -Fail # t = t -s # Fail = s -Step s # Step t = Step (s # t) - -instance Monad Steps where - Step s >>= k = Step (s >>= k) - Result x >>= k = k x - Fail >>= k = Fail - - return x = Result x - -run :: Steps a -> Maybe a -run (Step s) = run s -run (Result x) = Just x -run Fail = Nothing - -defaultSteps :: (a :-> c) -> Steps c -defaultSteps (Pair p) = defaultSteps p >>= defaultSteps -defaultSteps (p :+: q) = Step (defaultSteps p # defaultSteps q) -defaultSteps (Unit c) = Result c -defaultSteps (Table ((_,y):_)) = Result y -defaultSteps (Map _ _ p) = defaultSteps p -defaultSteps _ = Fail - -defaultResult :: (a :-> c) -> Maybe c -defaultResult = run . defaultSteps - -------------------------------------------------------------------------- -- Function @@ -241,8 +207,8 @@ pair p = Pair p shrinkFun shr (p :+: q) = - [ p .+. Nil | not (isNil q) ] ++ - [ Nil .+. q | not (isNil p) ] ++ + [ p .+. Nil `whenever` not (isNil q) ] ++ + [ Nil .+. q `whenever` not (isNil p) ] ++ [ p .+. q' | q' <- shrinkFun shr q ] ++ [ p' .+. q | p' <- shrinkFun shr p ] where @@ -253,6 +219,9 @@ Nil .+. Nil = Nil p .+. q = p :+: q + p `whenever` True = p + p `whenever` False = discard + shrinkFun shr (Unit c) = [ Nil ] ++ [ Unit c' | c' <- shr c ] @@ -291,12 +260,12 @@ instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where arbitrary = do p <- arbitrary - return (mkFun p (fromJust (defaultResult p))) + d <- arbitrary + return (mkFun p d) shrink (Fun (p,d) _) = - [ mkFun p' d' | p' <- shrink p, Just d' <- [defaultResult p'] ] - ++ [ mkFun p' d | p' <- shrink p ] - ++ [ mkFun p d' | d' <- shrink d ] + [ mkFun p' d | p' <- shrink p ] + ++ [ mkFun p d' | d' <- shrink d ] -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs --- a/Test/QuickCheck/State.hs +++ b/Test/QuickCheck/State.hs @@ -11,23 +11,24 @@ 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 + { 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 - , 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 + -- 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 + -- 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 @@ -105,29 +105,30 @@ 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 - , collected = [] - , expectedFailure = False - , randomSeed = rnd - , numSuccessShrinks = 0 - , numTryShrinks = 0 - , numTotTryShrinks = 0 + 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 + 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 + ((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 @@ -215,7 +216,7 @@ ] ++ ")" ) - let size = computeSize st (numSuccessTests st) (numDiscardedTests st) + let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size))) callbackPostTest st res @@ -225,17 +226,19 @@ case res of MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test do continue doneTesting - st{ numSuccessTests = numSuccessTests st + 1 - , randomSeed = rnd2 - , collected = stamp : collected st - , expectedFailure = expect + 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 - , randomSeed = rnd2 - , expectedFailure = expect + st{ numDiscardedTests = numDiscardedTests st + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + , randomSeed = rnd2 + , expectedFailure = expect } f MkResult{ok = Just False} -> -- failed test