QuickCheck 2.1.0.2 → 2.1.0.3

raw patch · 5 files changed

+142/−150 lines, 5 filesdep +extensible-exceptionsdep +ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: extensible-exceptions, ghc

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +5/−1
• Test/QuickCheck/Exception.hs +45/−12
• Test/QuickCheck/Monadic.hs +1/−1
• Test/QuickCheck/Property.hs +46/−71
• Test/QuickCheck/Test.hs +45/−65

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

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

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

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

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