QuickCheck 2.3.0.2 → 2.4

raw patch · 11 files changed

+472/−262 lines, 11 filesdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +4/−1
• Test/QuickCheck.hs +11/−0
• Test/QuickCheck/All.hs +73/−0
• Test/QuickCheck/Arbitrary.hs +12/−21
• Test/QuickCheck/Exception.hs +1/−1
• Test/QuickCheck/Function.hs +112/−83
• Test/QuickCheck/Gen.hs +3/−2
• Test/QuickCheck/Monadic.hs +1/−1
• Test/QuickCheck/Poly.hs +4/−3
• Test/QuickCheck/Property.hs +201/−112
• Test/QuickCheck/Test.hs +50/−38

@@ -1,5 +1,5 @@ Name: QuickCheck-Version: 2.3.0.2+Version: 2.4 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3@@ -56,6 +56,9 @@     Test.QuickCheck.Text,     Test.QuickCheck.Poly,     Test.QuickCheck.State+  if impl(ghc >= 6.12)+    Build-depends: template-haskell+    Exposed-Modules: Test.QuickCheck.All   Other-Modules:     Test.QuickCheck.Exception   GHC-options:

@@ -7,6 +7,12 @@   , quickCheckWith   , quickCheckWithResult   , quickCheckResult+    -- ** Running tests verbosely+  , verboseCheck+  , verboseCheckWith+  , verboseCheckWithResult+  , verboseCheckResult+  , verbose          -- * Random generation   , Gen@@ -74,8 +80,13 @@   , forAll   , forAllShrink   , (.&.)+  , (.&&.)+  , conjoin+  , (.||.)+  , disjoin     -- *** Handling failure   , whenFail+  , printTestCase   , whenFail'   , expectFailure   , within

@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell, Rank2Types #-}+module Test.QuickCheck.All(forAllProperties, quickCheckAll, mono, polyQuickCheck) where++import Language.Haskell.TH+import Test.QuickCheck.Property hiding (Result)+import Test.QuickCheck.Test+import Data.Char+import Data.List+import Control.Monad++polyQuickCheck :: Name -> ExpQ+polyQuickCheck x = [| quickCheck $(mono x) |]++type Error = forall a. String -> a++mono :: Name -> ExpQ+mono t = do+  ty0 <- fmap infoType (reify t)+  let err msg = error $ msg ++ ": " ++ pprint ty0+  (polys, ctx, ty) <- deconstructType err ty0+  case polys of+    [] -> return (VarE t)+    _ -> do+      integer <- [t| Integer |]+      ty' <- monomorphise err integer ty+      return (SigE (VarE t) ty')++infoType :: Info -> Type+infoType (ClassOpI _ ty _ _) = ty+infoType (DataConI _ ty _ _) = ty+infoType (VarI _ ty _ _) = ty++deconstructType :: Error -> Type -> Q ([Name], Cxt, Type)+deconstructType err ty0@(ForallT xs ctx ty) = do+  let plain (PlainTV _) = True+      plain _ = False+  unless (all plain xs) $ err "Higher-kinded type variables in type"+  return (map (\(PlainTV x) -> x) xs, ctx, ty)+deconstructType _ ty = return ([], [], ty)++monomorphise :: Error -> Type -> Type -> TypeQ+monomorphise err mono ty@(VarT n) = return mono+monomorphise err mono (AppT t1 t2) = liftM2 AppT (monomorphise err mono t1) (monomorphise err mono t2)+monomorphise err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type"+monomorphise err mono ty = return ty++forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool+forAllProperties = do+  Loc { loc_filename = filename } <- location+  when (filename == "<interactive>") $ error "don't run this interactively"+  ls <- runIO (fmap lines (readFile filename))+  let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile (\c -> isSpace c || c == '>')) ls+      idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes))+      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),+                                     property $(mono (mkName x))) |] ]+         else return []+  [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |]++quickCheckAll :: Q Exp+quickCheckAll = [| $(forAllProperties) quickCheckResult |]++runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool+runQuickCheckAll ps qc =+  fmap and . forM ps $ \(xs, p) -> do+    putStrLn $ "=== " ++ xs ++ " ==="+    r <- qc p+    return $ case r of+      Success { } -> True+      Failure { } -> False+      NoExpectedFailure { } -> False

@@ -127,12 +127,23 @@   shrink xs = shrinkList shrink xs  shrinkList :: (a -> [a]) -> [a] -> [[a]]-shrinkList shr xs0 = removeChunks xs0 ++ shrinkOne xs0+shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ]+                 ++ shrinkOne xs  where+  n = length xs+   shrinkOne []     = []   shrinkOne (x:xs) = [ x':xs | x'  <- shr x ]                   ++ [ x:xs' | xs' <- shrinkOne xs ]  +  removes k n xs+    | k > n     = []+    | null xs2  = [[]]+    | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2)+   where+    xs1 = take k xs+    xs2 = drop k xs+ {-   -- "standard" definition for lists:   shrink []     = []@@ -140,26 +151,6 @@                ++ [ x:xs' | xs' <- shrink xs ]                ++ [ x':xs | x'  <- shrink x ] -}--removeChunks :: [a] -> [[a]]-removeChunks xs0 = remC (length xs0) xs0-   where-    remC 0 _  = []-    remC 1 _  = [[]]-    remC n xs = xs1-              : xs2-              : ( [ xs1' ++ xs2 | xs1' <- remC n1 xs1, not (null xs1') ]-            `ilv` [ xs1 ++ xs2' | xs2' <- remC n2 xs2, not (null xs2') ]-                )-     where-      n1  = n `div` 2-      xs1 = take n1 xs-      n2  = n - n1-      xs2 = drop n1 xs--      []     `ilv` bs     = bs-      as     `ilv` []     = as-      (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)  instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where   arbitrary = arbitrarySizedFractional

@@ -13,7 +13,7 @@ #endif #endif -#if defined OLD_EXCEPTIONS+#if defined(OLD_EXCEPTIONS) import Control.Exception(evaluate, try, Exception(..)) #else import Control.Exception.Extensible(evaluate, try, SomeException(SomeException)

@@ -3,9 +3,9 @@   ( Fun(..)   , apply   , (:->)-  , FunArbitrary(..)-  , funArbitraryMap-  , funArbitraryShow+  , Function(..)+  , functionMap+  , functionShow   )  where @@ -20,6 +20,8 @@  import Data.Char import Data.Word+import Data.List( intersperse )+import Data.Maybe( fromJust )  -------------------------------------------------------------------------- -- concrete functions@@ -42,18 +44,18 @@   fmap f (Map g h p) = Map g h (fmap f p)  instance (Show a, Show b) => Show (a:->b) where-  -- only use this on finite functions-  show p =-    "{" ++ (case table p of-             []        -> ""-             (_,c):xcs -> concat [ show x ++ "->" ++ show c ++ ","-                                 | (x,c) <- xcs-                                 ]-                       ++ "_->" ++ show c)-        ++ "}"-   where-    xcs = table p+  show p = showFunction p Nothing +-- only use this on finite functions+showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String+showFunction p md =+  "{" ++ concat (intersperse "," ( [ show x ++ "->" ++ show c+                                   | (x,c) <- table p+                                   ]+                                ++ [ "_->" ++ show d+                                   | Just d <- [md]+                                   ] )) ++ "}"+ -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) abstract (Pair p)    d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x@@ -73,54 +75,71 @@ table (Table xys) = xys table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] ------------------------------------------------------------------------------ FunArbitrary+-- finding a default result -class FunArbitrary a where-  funArbitrary :: Arbitrary c => Gen (a :-> c)+-- breadth-first search (can't use depth-first search!)+data Steps a = Step (Steps a) | Fail | Result a -instance (FunArbitrary a, Arbitrary c) => Arbitrary (a :-> c) where-  arbitrary = funArbitrary-  shrink    = shrinkFun shrink+(#) :: 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) --- basic instances: pairs, sums, units+instance Monad Steps where+  Step s   >>= k = Step (s >>= k)+  Result x >>= k = k x+  Fail     >>= k = Fail -instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (a,b) where-  funArbitrary =-    do p <- funArbitrary-       return (Pair p)+  return x = Result x -instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (Either a b) where-  funArbitrary =-    do p <- funArbitrary-       q <- funArbitrary-       return (p :+: q)+run :: Steps a -> Maybe a+run (Step s)   = run s+run (Result x) = Just x+run Fail       = Nothing -instance FunArbitrary () where-  funArbitrary =-    do c <- arbitrary-       return (Unit c)+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 -instance FunArbitrary Word8 where-  funArbitrary =-    do xys <- sequence [ do y <- arbitrary-                            return (x,y)-                       | x <- [0..255]-                       ]-       return (Table xys)+defaultResult :: (a :-> c) -> Maybe c+defaultResult = run . defaultSteps --- other instances (using Map)+--------------------------------------------------------------------------+-- Function -funArbitraryMap :: (FunArbitrary a, Arbitrary c) => (b -> a) -> (a -> b) -> Gen (b :-> c)-funArbitraryMap g h =-  do p <- funArbitrary-     return (Map g h p)+class Function a where+  function :: (a->b) -> (a:->b) -funArbitraryShow :: (Show a, Read a, Arbitrary c) => Gen (a :-> c)-funArbitraryShow = funArbitraryMap show read+-- basic instances+  +instance Function () where+  function f = Unit (f ()) -instance FunArbitrary a => FunArbitrary [a] where-  funArbitrary = funArbitraryMap g h+instance Function Word8 where+  function f = Table [(x,f x) | x <- [0..255]]++instance (Function a, Function b) => Function (a,b) where+  function f = Pair (function `fmap` function (curry f))++instance (Function a, Function b) => Function (Either a b) where+  function f = function (f . Left) :+: function (f . Right)++-- other instances++functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c)+functionMap g h f = Map g h (function (\b -> f (h b)))++functionShow :: (Show a, Read a) => (a->c) -> (a:->c)+functionShow f = functionMap show read f++instance Function a => Function [a] where+  function = functionMap g h    where     g []     = Left ()     g (x:xs) = Right (x,xs)@@ -128,8 +147,8 @@     h (Left _)       = []     h (Right (x,xs)) = x:xs -instance FunArbitrary a => FunArbitrary (Maybe a) where-  funArbitrary = funArbitraryMap g h+instance Function a => Function (Maybe a) where+  function = functionMap g h    where     g Nothing  = Left ()     g (Just x) = Right x@@ -137,8 +156,8 @@     h (Left _)  = Nothing     h (Right x) = Just x -instance FunArbitrary Bool where-  funArbitrary = funArbitraryMap g h+instance Function Bool where+  function = functionMap g h    where     g False = Left ()     g True  = Right ()@@ -146,8 +165,8 @@     h (Left _)  = False     h (Right _) = True -instance FunArbitrary Integer where-  funArbitrary = funArbitraryMap gInteger hInteger+instance Function Integer where+  function = functionMap gInteger hInteger    where     gInteger n | n < 0     = Left (gNatural (abs n - 1))                | otherwise = Right (gNatural n)@@ -161,35 +180,41 @@     hNatural []     = 0     hNatural (w:ws) = fromIntegral w + 256 * hNatural ws -instance FunArbitrary Int where-  funArbitrary = funArbitraryMap fromIntegral fromInteger+instance Function Int where+  function = functionMap fromIntegral fromInteger -instance FunArbitrary Char where-  funArbitrary = funArbitraryMap ord' chr'+instance Function Char where+  function = functionMap ord' chr'    where     ord' c = fromIntegral (ord c) :: Word8     chr' n = chr (fromIntegral n)  -- poly instances -instance FunArbitrary A where-  funArbitrary = funArbitraryMap unA A+instance Function A where+  function = functionMap unA A -instance FunArbitrary B where-  funArbitrary = funArbitraryMap unB B+instance Function B where+  function = functionMap unB B -instance FunArbitrary C where-  funArbitrary = funArbitraryMap unC C+instance Function C where+  function = functionMap unC C -instance FunArbitrary OrdA where-  funArbitrary = funArbitraryMap unOrdA OrdA+instance Function OrdA where+  function = functionMap unOrdA OrdA -instance FunArbitrary OrdB where-  funArbitrary = funArbitraryMap unOrdB OrdB+instance Function OrdB where+  function = functionMap unOrdB OrdB -instance FunArbitrary OrdC where-  funArbitrary = funArbitraryMap unOrdC OrdC+instance Function OrdC where+  function = functionMap unOrdC OrdC +-- instance Arbitrary++instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where+  arbitrary = function `fmap` arbitrary+  shrink    = shrinkFun shrink+ -------------------------------------------------------------------------- -- shrinking @@ -203,8 +228,8 @@ shrinkFun shr (p :+: q) =   [ p .+. Nil | not (isNil q) ] ++   [ Nil .+. q | not (isNil p) ] ++-  [ p' .+. q  | p' <- shrinkFun shr p ] ++-  [ p  .+. q' | q' <- shrinkFun shr q ]+  [ p  .+. q' | q' <- shrinkFun shr q ] +++  [ p' .+. q  | p' <- shrinkFun shr p ]  where   isNil :: (a :-> b) -> Bool   isNil Nil = True@@ -237,22 +262,26 @@ -------------------------------------------------------------------------- -- the Fun modifier -data Fun a b = Fun (a :-> b) (a -> b)+data Fun a b = Fun (a :-> b, b) (a -> b) -fun :: (a :-> b) -> Fun a b-fun p = Fun p (abstract p (snd (head (table p))))+mkFun :: (a :-> b) -> b -> Fun a b+mkFun p d = Fun (p,d) (abstract p d)  apply :: Fun a b -> (a -> b) apply (Fun _ f) = f  instance (Show a, Show b) => Show (Fun a b) where-  show (Fun p _) = show p+  show (Fun (p,d) _) = showFunction p (Just d) -instance (FunArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where-  arbitrary = fun `fmap` arbitrary+instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where+  arbitrary =+    do p <- arbitrary+       return (mkFun p (fromJust (defaultResult p))) -  shrink (Fun p _) =-    [ fun p' | p' <- shrink p, _:_ <- [table p'] ]+  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 ]  -------------------------------------------------------------------------- -- the end.

@@ -4,9 +4,10 @@ -- imports  import System.Random-  ( RandomGen(..)-  , Random(..)+  ( Random   , StdGen+  , randomR+  , split   , newStdGen   ) 

@@ -73,7 +73,7 @@ monadic' (MkPropertyM m) = m (const (return (return (property True))))  monadicIO :: PropertyM IO a -> Property-monadicIO = monadic property+monadicIO = monadic morallyDubiousIOProperty  monadicST :: (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m))

@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.QuickCheck.Poly   ( A(..), B(..), C(..)   , OrdA(..), OrdB(..), OrdC(..)@@ -63,7 +64,7 @@ -- OrdA  newtype OrdA = OrdA{ unOrdA :: Integer }-  deriving ( Eq, Ord )+  deriving ( Eq, Ord, Num )  instance Show OrdA where   showsPrec n (OrdA x) = showsPrec n x@@ -78,7 +79,7 @@ -- OrdB  newtype OrdB = OrdB{ unOrdB :: Integer }-  deriving ( Eq, Ord )+  deriving ( Eq, Ord, Num )  instance Show OrdB where   showsPrec n (OrdB x) = showsPrec n x@@ -93,7 +94,7 @@ -- OrdC  newtype OrdC = OrdC{ unOrdC :: Integer }-  deriving ( Eq, Ord )+  deriving ( Eq, Ord, Num )  instance Show OrdC where   showsPrec n (OrdC x) = showsPrec n x

@@ -24,13 +24,46 @@   , stdout   ) +import System.Timeout(timeout)+import Data.Maybe+ ----------------------------------------------------------------------------- fixeties+-- fixities  infixr 0 ==> infixr 1 .&.--- infixr 1 .&&.+infixr 1 .&&.+infixr 1 .||. +-- The story for exception handling:+--+-- To avoid insanity, we have rules about which terms can throw+-- exceptions when we evaluate them:+--   * A rose tree must evaluate to WHNF without throwing an exception+--   * The 'ok' component of a Result must evaluate to Just True or+--     Just False or Nothing rather than raise an exception+--   * IORose _ must never throw an exception when executed+--+-- Both rose trees and Results may loop when we evaluate them, though,+-- so we have to be careful not to force them unnecessarily.+--+-- We also have to be careful when we use fmap or >>= in the Rose+-- monad that the function we supply is total, or else use+-- protectResults afterwards to install exception handlers. The+-- mapResult function on Properties installs an exception handler for+-- us, though.+--+-- Of course, the user is free to write "error "ha ha" :: Result" if+-- they feel like it. We have to make sure that any user-supplied Rose+-- Results or Results get wrapped in exception handlers, which we do by:+--   * Making the 'property' function install an exception handler+--     round its argument. This function always gets called in the+--     right places, because all our Property-accepting functions are+--     actually polymorphic over the Testable class so they have to+--     call 'property'.+--   * Installing an exception handler round a Result before we put it+--     in a rose tree (the only place Results can end up).+ -------------------------------------------------------------------------- -- * Property and Testable types @@ -47,69 +80,89 @@   property = property . liftBool  instance Testable Result where-  property = return . MkProp . return . return+  property = return . MkProp . protectResults . return  instance Testable Prop where-  property = return . protectProp+  property (MkProp r) = return . MkProp . ioRose . return $ r  instance Testable prop => Testable (Gen prop) where   property mp = do p <- mp; property p -instance Testable prop => Testable (IO prop) where-  property = fmap (MkProp . IORose . fmap unProp) . promote . fmap property+-- | Do I/O inside a property. This can obviously lead to unrepeatable+-- testcases, so use with care.+morallyDubiousIOProperty :: Testable prop => IO prop -> Property+morallyDubiousIOProperty = fmap (MkProp . ioRose . fmap unProp) . promote . fmap property  instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where   property f = forAllShrink arbitrary shrink f +-- ** Exception handling+protect :: (AnException -> a) -> IO a -> IO a+protect f x = either f id `fmap` tryEvaluateIO x+ -------------------------------------------------------------------------- -- ** Type Prop --- is this the right level to be abstract at?--newtype Prop = MkProp{ unProp :: Rose (IO Result) }--protectProp :: Prop -> Prop-protectProp (MkProp r) =-  MkProp . IORose $ do-    (x, rs) <- unpackRose r-    return (MkRose x rs)+newtype Prop = MkProp{ unProp :: Rose Result }  -- ** type Rose --- We never allow a rose tree to be _|_. This makes avoiding--- exceptions easier.--- This relies on the fact that the 'property' function never returns _|_. data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))+-- Only use IORose if you know that the argument is not going to throw an exception!+-- Otherwise, try ioRose.+ioRose :: IO (Rose Result) -> Rose Result+ioRose = IORose . protectRose -join :: Rose (Rose a) -> Rose a-join (IORose rs) = IORose (fmap join rs)-join (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (join (MkRose r rs))-join (MkRose (MkRose x ts) tts) =+joinRose :: Rose (Rose a) -> Rose a+joinRose (IORose rs) = IORose (fmap joinRose rs)+joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs))+joinRose (MkRose (MkRose x ts) tts) =   -- first shrinks outer quantification; makes most sense-  MkRose x (map join tts ++ ts)+  MkRose x (map joinRose tts ++ ts)   -- first shrinks inner quantification-  --MkRose x (ts ++ map join tts)+  --MkRose x (ts ++ map joinRose tts)  instance Functor Rose where-  fmap f (IORose rs) = IORose (fmap (fmap f) rs)+  -- f must be total+  fmap f (IORose rs)   = IORose (fmap (fmap f) rs)   fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]  instance Monad Rose where   return x = MkRose x []-  m >>= k  = join (fmap k m)+  -- k must be total+  m >>= k  = joinRose (fmap k m) -unpackRose :: Rose (IO Result) -> IO (IO Result, [Rose (IO Result)])-unpackRose rose = either (\e -> (return (exception "Exception" e), [])) id-                  `fmap` tryEvaluateIO (unpack rose)-  where unpack (MkRose x xs) = return (x, xs)-        unpack (IORose m) = m >>= unpack+-- Execute the "IORose" bits of a rose tree, returning a tree+-- constructed by MkRose.+reduceRose :: Rose Result -> IO (Rose Result)+reduceRose r@(MkRose _ _) = return r+reduceRose (IORose m) = m >>= reduceRose +-- Apply a function to the outermost MkRose constructor of a rose tree.+-- The function must be total!+onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a+onRose f (MkRose x rs) = f x rs+onRose f (IORose m) = IORose (fmap (onRose f) m)++-- Wrap a rose tree in an exception handler.+protectRose :: IO (Rose Result) -> IO (Rose Result)+protectRose = protect (return . exception "Exception")++-- Wrap all the Results in a rose tree in exception handlers.+protectResults :: Rose Result -> Rose Result+protectResults = onRose $ \x rs ->+  IORose $ do+    y <- protectResult (return x)+    return (MkRose y (map protectResults rs))+ -- ** Result type  -- | Different kinds of callbacks data Callback-  = PostTest (State -> Result -> IO ())         -- ^ Called just after a test-  | PostFinalFailure (State -> Result -> IO ()) -- ^ Called with the final failing test-case+  = PostTest CallbackKind (State -> Result -> IO ())         -- ^ Called just after a test+  | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case+data CallbackKind = Counterexample    -- ^ Affected by the 'verbose' combinator+                  | NotCounterexample -- ^ Not affected by the 'verbose' combinator  -- | The result of a single test. data Result@@ -138,8 +191,7 @@                             interrupted = isInterrupt err }  protectResult :: IO Result -> IO Result-protectResult m = either (exception "Exception") id `fmap` tryEvaluateIO (fmap force m)-  where force res = ok res == Just False `seq` res+protectResult = protect (exception "Exception")  succeeded :: Result  succeeded = result{ ok = Just True }@@ -153,28 +205,19 @@ -------------------------------------------------------------------------- -- ** Lifting and mapping functions -liftBool :: Bool -> Property-liftBool b = liftResult $-  result-  { ok     = Just b-  , reason = if b then "" else "Falsifiable"-  }--liftResult :: Result -> Property-liftResult r = liftIOResult (return r)--liftIOResult :: IO Result -> Property-liftIOResult m = property (MkProp (return m))+liftBool :: Bool -> Result+liftBool True = succeeded+liftBool False = failed { reason = "Falsifiable" }  mapResult :: Testable prop => (Result -> Result) -> prop -> Property-mapResult f = mapIOResult (fmap f)+mapResult f = mapRoseResult (protectResults . fmap f) -mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property-mapIOResult f = mapRoseIOResult (fmap (f . protectResult))+mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property+mapTotalResult f = mapRoseResult (fmap f) --- f here has to be total.-mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property-mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t))+-- f here mustn't throw an exception (rose tree invariant).+mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property+mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t))  mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property mapProp f = fmap f . property@@ -193,31 +236,29 @@              (a -> [a])  -- ^ 'shrink'-like function.           -> a           -- ^ The original argument           -> (a -> prop) -> Property-shrinking shrinker x0 pf = fmap (MkProp . join . fmap unProp) (promote (props x0))+shrinking shrinker x0 pf = fmap (MkProp . joinRose . fmap unProp) (promote (props x0))  where   props x =     MkRose (property (pf x)) [ props x' | x' <- shrinker x ]  -- | Disables shrinking for a property altogether. noShrinking :: Testable prop => prop -> Property-noShrinking = mapRoseIOResult f-  where f (MkRose mres _ts) = MkRose mres []-        f (IORose rm) = IORose (fmap f rm)+noShrinking = mapRoseResult (onRose (\res _ -> MkRose res []))  -- | Adds a callback callback :: Testable prop => Callback -> prop -> Property-callback cb = mapResult (\res -> res{ callbacks = cb : callbacks res })+callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) --- | Prints a message to the terminal after the last failure of a property.-whenFailPrint :: Testable prop => String -> prop -> Property-whenFailPrint s =-  callback $ PostFinalFailure $ \st _res ->+-- | 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  -- | Performs an 'IO' action after the last failure of a property. whenFail :: Testable prop => IO () -> prop -> Property whenFail m =-  callback $ PostFinalFailure $ \_st _res ->+  callback $ PostFinalFailure NotCounterexample $ \_st _res ->     m  -- | Performs an 'IO' action every time a property fails. Thus,@@ -225,14 +266,26 @@ -- failures along the way. whenFail' :: Testable prop => IO () -> prop -> Property whenFail' m =-  callback $ PostTest $ \_st res ->+  callback $ PostTest NotCounterexample $ \_st res ->     if ok res == Just False       then m       else return () +-- | Prints out the generated testcase every time the property is tested,+-- like 'verboseCheck' from QuickCheck 1.+-- Only variables quantified over /inside/ the 'verbose' are printed.+verbose :: Testable prop => prop -> Property+verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res })+  where newCallbacks cbs =+          PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")):+          [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ]+        status MkResult{ok = Just True} = "Passed"+        status MkResult{ok = Just False} = "Failed"+        status MkResult{ok = Nothing} = "Skipped (precondition false)"+ -- | Modifies a property so that it is expected to fail for some test cases. expectFailure :: Testable prop => prop -> Property-expectFailure = mapResult (\res -> res{ expect = False })+expectFailure = mapTotalResult (\res -> res{ expect = False })  -- | Attaches a label to a property. This is used for reporting -- test case distribution.@@ -259,10 +312,8 @@       -> Int    -- ^ The required percentage (0-100) of test cases.       -> String -- ^ Label for the test case class.       -> prop -> Property-cover b n s = mapResult $ \res ->-        case b of-         True  -> res{ stamp  = (s,n) : stamp res }-         False -> res+cover True n s = mapTotalResult $ \res -> res { stamp = (s,n) : stamp res }+cover False _ _ = property  -- | Implication for properties: The resulting property holds if -- the first argument is 'False', or if the given property holds.@@ -273,39 +324,17 @@ -- | Considers a property failed if it does not complete within -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property-within n = mapIOResult race- where-  race ior =-    do put "Race starts ..."-       resV <- newEmptyMVar-       -       let waitAndFail =-             do put "Waiting ..."-                threadDelay n-                put "Done waiting!"-                putMVar resV (failed {reason = "Time out"})-           -           evalProp =-             do put "Evaluating Result ..."-                res <- protectResult ior-                put "Evaluating OK ..."-                putMVar resV res-       -       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-         --  put s | True      = do return ()-        | otherwise = do putStrLn s-                         hFlush stdout+within n = mapRoseResult f+  -- We rely on the fact that the property will catch the timeout+  -- exception and turn it into a failed test case.+  where+    f rose = ioRose $ do+      let m `orError` x = fmap (fromMaybe (error x)) m+      MkRose res roses <- timeout n (reduceRose rose) `orError`+                          "within: timeout exception not caught in Rose Result"+      res' <- timeout n (protectResult (return res)) `orError`+              "within: timeout exception not caught in Result"+      return (MkRose res' (map f roses))  -- | Explicit universal quantification: uses an explicitly given -- test case generator.@@ -313,8 +342,7 @@        => Gen a -> (a -> prop) -> Property forAll gen pf =   gen >>= \x ->-    whenFailPrint (show x) $-      property (pf x)+    printTestCase (show x) (pf x)  -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop)@@ -322,21 +350,82 @@ forAllShrink gen shrinker pf =   gen >>= \x ->     shrinking shrinker x $ \x' ->-      whenFailPrint (show x') $-        property (pf x')+      printTestCase (show x') (pf x')  (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 =   arbitrary >>= \b ->-    whenFailPrint (if b then "LHS" else "RHS") $+    printTestCase (if b then "LHS" else "RHS") $       if b then property p1 else property p2 -{---- TODO- (.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property-p1 .&&. p2 = error "not implemented yet"--}+p1 .&&. p2 = conjoin [property p1, property p2]++conjoin :: Testable prop => [prop] -> Property+conjoin ps = +  do roses <- mapM (fmap unProp . property) ps+     return (MkProp (conj [] roses))+ where+  conj cbs [] =+    MkRose succeeded{callbacks = cbs} []++  conj cbs (p : ps) = IORose $ do+    rose@(MkRose result _) <- reduceRose p+    case ok result of+      _ | not (expect result) ->+        return (return failed { reason = "expectFailure may not occur inside a conjunction" })+      Just True -> return (conj (cbs ++ callbacks result) ps)+      Just False -> return rose+      Nothing -> do+        rose2@(MkRose result2 _) <- reduceRose (conj (cbs ++ callbacks result) ps)+        return $+          -- Nasty work to make sure we use the right callbacks+          case ok result2 of+            Just True -> MkRose (result2 { ok = Nothing }) []+            Just False -> rose2+            Nothing -> rose2++(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property+p1 .||. p2 = disjoin [property p1, property p2]++disjoin :: Testable prop => [prop] -> Property+disjoin ps = +  do roses <- mapM (fmap unProp . property) ps+     return (MkProp (foldr disj (MkRose failed []) roses))+ where+  disj :: Rose Result -> Rose Result -> Rose Result+  disj p q =+    do result1 <- p+       case ok result1 of+         _ | not (expect result1) -> return expectFailureError+         Just True -> return result1+         Just False -> do+           result2 <- q+           return $+             if expect result2 then+               case ok result2 of+                 Just True -> result2+                 Just False -> result1 >>> result2+                 Nothing -> result2+             else expectFailureError+         Nothing -> do+           result2 <- q+           return (case ok result2 of+                     _ | not (expect result2) -> expectFailureError+                     Just True -> result2+                     _ -> result1)++  expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" }+  result1 >>> result2 | not (expect result1 && expect result2) = expectFailureError+  result1 >>> result2 =+    result2+    { reason      = if null (reason result2) then reason result1 else reason result2+    , interrupted = interrupted result1 || interrupted result2+    , stamp       = stamp result1 ++ stamp result2+    , callbacks   = callbacks result1 +++                    [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] +++                    callbacks result2+    }  -------------------------------------------------------------------------- -- the end.

@@ -12,7 +12,7 @@ import Data.IORef  import System.Random-  ( RandomGen(..)+  ( split   , newStdGen   , StdGen   )@@ -130,6 +130,26 @@             (n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10         n `roundTo` m = (n `div` m) * m +-- | Tests a property and prints the results and all test cases generated to 'stdout'.+-- This is just a convenience function that means the same as 'quickCheck' '.' 'verbose'.+verboseCheck :: Testable prop => prop -> IO ()+verboseCheck p = quickCheck (verbose p)++-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'.+-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'.+verboseCheckWith :: Testable prop => Args -> prop -> IO ()+verboseCheckWith args p = quickCheckWith args (verbose p)++-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'.+-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'.+verboseCheckResult :: Testable prop => prop -> IO Result+verboseCheckResult p = quickCheckResult (verbose p)++-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'.+-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'.+verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result+verboseCheckWithResult a p = quickCheckWithResult a (verbose p)+ -------------------------------------------------------------------------- -- main test loop @@ -194,34 +214,27 @@        ++ ")"         )      let size = computeSize st (numSuccessTests st) (numDiscardedTests st)-     (mres, ts) <- unpackRose (unProp (f rnd1 size))-     res <- mres+     MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size)))      callbackPostTest st res      -     case ok res of-       Just True -> -- successful test+     case res of+       MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test          do test st{ numSuccessTests = numSuccessTests st + 1                    , randomSeed      = rnd2-                   , collected       = stamp res : collected st-                   , expectedFailure = expect res+                   , collected       = stamp : collected st+                   , expectedFailure = expect                    } f        -       Nothing -> -- discarded test+       MkResult{ok = Nothing, expect = expect} -> -- discarded test          do test st{ numDiscardedTests = numDiscardedTests st + 1                    , randomSeed        = rnd2-                   , expectedFailure   = expect res+                   , expectedFailure   = expect                    } f          -       Just False -> -- failed test+       MkResult{ok = Just False} -> -- failed test          do if expect res               then putPart (terminal st) (bold "*** Failed! ")               else putPart (terminal st) "+++ OK, failed as expected. "-            putTemp (terminal st)-              ( short 30 (P.reason res)-             ++ " (after "-             ++ number (numSuccessTests st+1) "test"-             ++ ")..."-              )             numShrinks <- foundFailure st res ts             theOutput <- terminalOutput (terminal st)             if not (expect res) then@@ -299,40 +312,39 @@ -------------------------------------------------------------------------- -- main shrinking loop -foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int+foundFailure :: State -> P.Result -> [Rose P.Result] -> IO Int foundFailure st res ts =   do localMin st{ numTryShrinks = 0 } res ts -localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int+localMin :: State -> P.Result -> [Rose P.Result] -> IO Int localMin st res _ | P.interrupted res = localMinFound st res localMin st res ts = do+  putTemp (terminal st)+    ( short 26 (P.reason res)+   ++ " (after " ++ number (numSuccessTests st+1) "test"+   ++ concat [ " and "+            ++ show (numSuccessShrinks st)+            ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ]+            ++ " shrink"+            ++ (if numSuccessShrinks st == 1+                && numTryShrinks st == 0+                then "" else "s")+             | numSuccessShrinks st > 0 || numTryShrinks st > 0+             ]+   ++ ")..."+    )   r <- tryEvaluate ts   case r of     Left err ->       localMinFound st-         (exception "Exception while generating shrink-list" err)+         (exception "Exception while generating shrink-list" err) { callbacks = callbacks res }     Right ts' -> localMin' st res ts' -localMin' :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int+localMin' :: State -> P.Result -> [Rose P.Result] -> IO Int localMin' st res [] = localMinFound st res localMin' st res (t:ts) =   do -- CALLBACK before_test-    (mres', ts') <- unpackRose t-    res' <- mres'-    putTemp (terminal st)-      ( short 35 (P.reason res)-     ++ " (after " ++ number (numSuccessTests st+1) "test"-     ++ concat [ " and "-              ++ show (numSuccessShrinks st)-              ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ]-              ++ " shrink"-              ++ (if numSuccessShrinks st == 1-                  && numTryShrinks st == 0-                  then "" else "s")-               | numSuccessShrinks st > 0 || numTryShrinks st > 0-               ]-     ++ ")..."-      )+    MkRose res' ts' <- protectRose (reduceRose t)     callbackPostTest st res'     if ok res' == Just False       then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts'@@ -356,11 +368,11 @@  callbackPostTest :: State -> P.Result -> IO () callbackPostTest st res =-  sequence_ [ f st res | PostTest f <- callbacks res ]+  sequence_ [ f st res | PostTest _ f <- callbacks res ]  callbackPostFinalFailure :: State -> P.Result -> IO () callbackPostFinalFailure st res =-  sequence_ [ f st res | PostFinalFailure f <- callbacks res ]+  sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ]  -------------------------------------------------------------------------- -- the end.