diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.1.0.2 +Version: 2.1.0.3 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 @@ -39,6 +39,10 @@ Build-depends: base >= 3 && < 4, random else Build-depends: base < 3 + if impl(ghc >= 6.7) + Build-depends: ghc + if impl(ghc >= 6.9) + Build-depends: extensible-exceptions Exposed-Modules: Test.QuickCheck, Test.QuickCheck.Arbitrary, diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs --- a/Test/QuickCheck/Exception.hs +++ b/Test/QuickCheck/Exception.hs @@ -1,31 +1,64 @@ {-# LANGUAGE CPP #-} module Test.QuickCheck.Exception where -#if defined(MIN_VERSION_base) -#if !(MIN_VERSION_base(4,0,0)) -#define SomeException Exception -#endif +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 609) +#define OLD_EXCEPTIONS #endif -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 609) -#define SomeException Exception +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 607 +#define GHC_INTERRUPT #endif -import Control.Exception - ( evaluate - , try - , SomeException +#if defined OLD_EXCEPTIONS +import Control.Exception(evaluate, try, Exception(..)) +#else +import Control.Exception.Extensible(evaluate, try, SomeException(SomeException) +#if defined(GHC_INTERRUPT) + , AsyncException(UserInterrupt) +#endif ) +#endif +#if defined(GHC_INTERRUPT) +import Panic(GhcException(Interrupted)) +import Data.Typeable +#if defined(OLD_EXCEPTIONS) +import Data.Dynamic +#endif +#endif + +#if defined(OLD_EXCEPTIONS) +type AnException = Control.Exception.Exception +#else +type AnException = SomeException +#endif + -------------------------------------------------------------------------- -- try evaluate -tryEvaluate :: a -> IO (Either SomeException a) +tryEvaluate :: a -> IO (Either AnException a) tryEvaluate x = tryEvaluateIO (return x) -tryEvaluateIO :: IO a -> IO (Either SomeException a) +tryEvaluateIO :: IO a -> IO (Either AnException a) tryEvaluateIO m = try (m >>= 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 (DynException e) = fromDynamic e == Just Interrupted +isInterrupt _ = False +#else +isInterrupt (SomeException e) = + cast e == Just Interrupted || cast e == Just UserInterrupt +#endif + +#else /* !defined(GHC_INTERRUPT) */ +isInterrupt _ = False +#endif -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs --- a/Test/QuickCheck/Monadic.hs +++ b/Test/QuickCheck/Monadic.hs @@ -35,7 +35,7 @@ MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) fail s = MkPropertyM (\k -> return (return (property result))) where - result = failed{ reason = s } + result = failed result{ reason = s } -- should think about strictness/exceptions here --assert :: Testable prop => prop -> PropertyM m () diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- a/Test/QuickCheck/Property.hs +++ b/Test/QuickCheck/Property.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} module Test.QuickCheck.Property where -------------------------------------------------------------------------- @@ -84,6 +85,10 @@ return x = MkRose x [] m >>= k = join (fmap k m) +protectRose :: Rose (IO Result) -> IO (Rose (IO Result)) +protectRose rose = either (return . return . exception result) id `fmap` tryEvaluate (unpack rose) + where unpack (MkRose mres ts) = MkRose (protectResult mres) ts + -- ** Result type -- | Different kinds of callbacks @@ -94,29 +99,35 @@ -- | 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 - , stamp :: [(String,Int)] -- ^ the collected values for this test case - , callbacks :: [Callback] -- ^ the callbacks for this test case + { 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 + , 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 = "" - , stamp = [] - , callbacks = [] + { ok = undefined + , expect = True + , reason = "" + , interrupted = False + , stamp = [] + , callbacks = [] } -failed :: Result -failed = result{ ok = Just False } +failed :: Result -> Result +failed res = res{ ok = Just False } -exception :: Show a => a -> Result -exception err = failed{ reason = "Exception: '" ++ showErr err ++ "'" } +exception res err = failed res{ reason = "Exception: '" ++ showErr err ++ "'", + interrupted = isInterrupt err } +protectResult :: IO Result -> IO Result +protectResult m = either (exception result) id `fmap` tryEvaluateIO (fmap force m) + where force res = ok res == Just False `seq` res + succeeded :: Result succeeded = result{ ok = Just True } @@ -137,30 +148,16 @@ liftResult r = liftIOResult (return r) liftIOResult :: IO Result -> Property -liftIOResult m = liftRoseIOResult (return (wrap m)) - where - wrap m = either exception id `fmap` tryEvaluateIO m +liftIOResult m = liftRoseIOResult (return m) liftRoseIOResult :: Rose (IO Result) -> Property liftRoseIOResult t = return (MkProp t) mapResult :: Testable prop => (Result -> Result) -> prop -> Property -mapResult f = mapIOResult (>>= wrap f) - where - wrap f res = - do mres <- tryEvaluate res - return $ f $ case mres of - Left err -> exception err - Right res -> res - +mapResult f = mapIOResult (fmap f) + mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property -mapIOResult f = mapRoseIOResult (fmap (f . wrap)) - where - wrap iores = - do miores <- tryEvaluate iores - case miores of - Left err -> return (exception err) - Right iores -> iores +mapIOResult f = mapRoseIOResult (fmap (f . protectResult)) mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t)) @@ -187,6 +184,11 @@ props x = MkRose (property (pf x)) [ props x' | x' <- shrink x ] +-- | Disables shrinking for a property altogether. +noShrinking :: Testable prop => prop -> Property +noShrinking = mapRoseIOResult f + where f (MkRose mres ts) = MkRose mres [] + -- | Adds a callback callback :: Testable prop => Callback -> prop -> Property callback cb = mapResult (\res -> res{ callbacks = cb : callbacks res }) @@ -236,16 +238,10 @@ -> Int -- ^ The required percentage (0-100) of test cases. -> String -- ^ Label for the test case class. -> prop -> Property -cover b n s = mapIOResult $ \ior -> - do eeb <- tryEvaluate b - res <- ior - return $ - case eeb of - Left err -> res{ ok = Just False - , reason = "Exception: '" ++ showErr err ++ "'" - } - Right True -> res{ stamp = (s,n) : stamp res } - Right False -> res +cover b n s = mapResult $ \res -> + case b of + True -> res{ stamp = (s,n) : stamp res } + False -> res -- | Implication for properties: The resulting property holds if -- the first argument is 'False', or if the given property holds. @@ -253,8 +249,6 @@ False ==> _ = property () True ==> p = property p --- INVESTIGATE: does not work --- NOTE: n is in microseconds -- | Considers a property failed if it does not complete within -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property @@ -263,46 +257,27 @@ race ior = do put "Race starts ..." resV <- newEmptyMVar - pidV <- newEmptyMVar - partResV <- newIORef failed let waitAndFail = do put "Waiting ..." threadDelay n put "Done waiting!" - partRes <- readIORef partResV - putMVar resV $ - partRes - { ok = Just False - , reason = "Time out" - } + putMVar resV (failed result{reason = "Time out"}) evalProp = do put "Evaluating Result ..." - res <- ior - writeIORef partResV res + res <- protectResult ior put "Evaluating OK ..." - mok <- tryEvaluate (ok res == Just False) - case mok of - Left err -> do put "Exception!" - putMVar resV $ - res - { ok = Just False - , reason = "Exception: '" ++ showErr err ++ "'" - } - Right _ -> do put "Done!" - putMVar resV res + putMVar resV res - -- used "mfix" here before but got non-termination problems - pid1 <- forkIO $ do pid2 <- takeMVar pidV - evalProp - killThread pid2 - pid2 <- forkIO $ do waitAndFail - killThread pid1 - putMVar pidV pid2 + pid1 <- forkIO evalProp + pid2 <- forkIO waitAndFail put "Blocking ..." res <- takeMVar resV + put "Killing threads ..." + killThread pid1 + killThread pid2 put ("Got Result: " ++ show (ok res)) return res diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -4,7 +4,7 @@ -- imports import Test.QuickCheck.Gen -import Test.QuickCheck.Property hiding ( Result( reason ) ) +import Test.QuickCheck.Property hiding ( Result( reason, interrupted ) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text import Test.QuickCheck.State @@ -44,21 +44,21 @@ -- | Result represents the test result data Result - = Success -- a successful test run - { labels :: [(String,Int)] -- ^ labels and frequencies found during all tests + = Success -- a successful test run + { labels :: [(String,Int)] -- ^ labels and frequencies found during all tests } - | GaveUp -- given up - { numTests :: Int -- ^ number of successful tests performed - , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests + | GaveUp -- given up + { numTests :: Int -- ^ number of successful tests performed + , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests } - | Failure -- failed test run - { usedSeed :: StdGen -- ^ what seed was used - , usedSize :: Int -- ^ what was the test size - , reason :: String -- ^ what was the reason - , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests + | Failure -- failed test run + { usedSeed :: StdGen -- ^ what seed was used + , usedSize :: Int -- ^ what was the test size + , reason :: String -- ^ what was the reason + , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests } - | NoExpectedFailure -- the expected failure did not happen - { labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests + | NoExpectedFailure -- the expected failure did not happen + { labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests } deriving ( Show, Read ) @@ -100,9 +100,7 @@ , maxSuccessTests = maxSuccess args , maxDiscardedTests = maxDiscard args , computeSize = case replay args of - Nothing -> \n d -> (n * maxSize args) - `div` maxSuccess args - + (d `div` 10) + Nothing -> computeSize (maxSuccess args) (maxSize args) Just (_,s) -> \_ _ -> s , numSuccessTests = 0 , numDiscardedTests = 0 @@ -113,6 +111,15 @@ , numSuccessShrinks = 0 , numTryShrinks = 0 } (unGen (property p)) + where computeSize maxSuccess maxSize 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 + maxSize <= maxSuccess || + n >= maxSuccess || + maxSuccess `mod` maxSize == 0 = n `mod` maxSize + d `div` 10 + | otherwise = + (n `mod` maxSize) * maxSize `div` (maxSuccess `mod` maxSize) + d `div` 10 + n `roundTo` m = (n `div` m) * m -------------------------------------------------------------------------- -- main test loop @@ -171,7 +178,8 @@ ++ ")" ) let size = computeSize st (numSuccessTests st) (numDiscardedTests st) - (res, ts) <- run (unProp (f rnd1 size)) + MkRose mres ts <- protectRose (unProp (f rnd1 size)) + res <- mres callbackPostTest st res case ok res of @@ -202,10 +210,10 @@ if not (expect res) then return Success{ labels = summary st } else - return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) - , usedSize = size - , reason = P.reason res - , labels = summary st + return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + , usedSize = size + , reason = P.reason res + , labels = summary st } where (rnd1,rnd2) = split (randomSeed st) @@ -266,39 +274,6 @@ showP p = (if p < 10 then " " else "") ++ show p ++ "% " --- this was there to take care of exceptions, but it does not seem to be --- needed anymore? -run rose = - do MkRose mres ts <- return rose `orElseErr` ("rose", errRose) - res <- mres `orElseErr` ("mres", errResult failed) - res <- return (strictOk res) `orElseErr` ("ok", errResult res{ ok = Just False }) - ts <- repairList ts - return (res, ts) - where - errRose err = MkRose (return (errResult failed err)) [] - errResult res err = res{ P.reason = "Exception: '" ++ showErr err ++ "'" } - - m `orElseErr` (s,f) = -- either f id `fmap` try m - do eex <- tryEvaluateIO m - case eex of - Left err -> do --putStrLn ("EX: [" ++ s ++ "]") - return s -- to make warning go away - return (f err) - Right x -> do return x - - strictOk res = - (ok res == Just False) `seq` res - - repairList xs = - return xs - {- - unsafeInterleaveIO $ - do eexs <- tryEvaluate xs - case eexs of - Right (x:xs) -> do xs' <- repairList xs; return (x:xs') - _ -> do return [] - -} - -------------------------------------------------------------------------- -- main shrinking loop @@ -307,20 +282,13 @@ do localMin st{ numTryShrinks = 0, isShrinking = True } res ts localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO () -localMin st res [] = - do putLine (terminal st) - ( P.reason res - ++ " (after " ++ number (numSuccessTests st+1) "test" - ++ concat [ " and " ++ number (numSuccessShrinks st) "shrink" - | numSuccessShrinks st > 0 - ] - ++ "): " - ) - callbackPostFinalFailure st res +localMin st res [] = localMinFound st res +localMin st res _ | P.interrupted res = localMinFound st res localMin st res (t : ts) = do -- CALLBACK before_test - (res',ts') <- run t + MkRose mres' ts' <- protectRose t + res' <- mres' putTemp (terminal st) ( short 35 (P.reason res) ++ " (after " ++ number (numSuccessTests st+1) "test" @@ -339,6 +307,18 @@ if ok res' == Just False then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts' else localMin st{ numTryShrinks = numTryShrinks st + 1 } res ts + +localMinFound :: State -> P.Result -> IO () +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 + ] + ++ "): " + ) + callbackPostFinalFailure st res -------------------------------------------------------------------------- -- callbacks