QuickCheck 2.2 → 2.3

raw patch · 9 files changed

+268/−241 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +1/−1
• Test/QuickCheck/Arbitrary.hs +30/−26
• Test/QuickCheck/Gen.hs +6/−6
• Test/QuickCheck/Modifiers.hs +1/−1
• Test/QuickCheck/Monadic.hs +16/−78
• Test/QuickCheck/Property.hs +53/−32
• Test/QuickCheck/State.hs +0/−1
• Test/QuickCheck/Test.hs +101/−70
• Test/QuickCheck/Text.hs +60/−26

@@ -1,5 +1,5 @@ Name: QuickCheck-Version: 2.2+Version: 2.3 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3

@@ -104,6 +104,8 @@  instance Arbitrary Bool where   arbitrary = choose (False,True)+  shrink True = [False]+  shrink False = []  instance Arbitrary a => Arbitrary (Maybe a) where   arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)]@@ -125,27 +127,8 @@   shrink xs = shrinkList shrink xs  shrinkList :: (a -> [a]) -> [a] -> [[a]]-shrinkList shr xs = removeChunks xs ++ shrinkOne xs+shrinkList shr xs0 = removeChunks xs0 ++ shrinkOne xs0  where-  removeChunks xs = rem (length xs) xs-   where-    rem 0 _  = []-    rem 1 _  = [[]]-    rem n xs = xs1-             : xs2-             : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]-           `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]-               )-     where-      n1  = n `div` 2-      xs1 = take n1 xs-      n2  = n - n1-      xs2 = drop n1 xs--      []     `ilv` ys     = ys-      xs     `ilv` []     = xs-      (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)-   shrinkOne []     = []   shrinkOne (x:xs) = [ x':xs | x'  <- shr x ]                   ++ [ x:xs' | xs' <- shrinkOne xs ] @@ -158,6 +141,26 @@                ++ [ 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   shrink    = shrinkRealFrac@@ -346,11 +349,12 @@   | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ])   ]  where-   -- x << y is "morally" abs x < abs y, but taking care of overflow.-   x << y | x >= 0 && y >= 0 = x < y-          | x < 0 && y < 0 = x > y-          | x >= 0 && y < 0 = x + y < 0-          | x < 0 && y >= 0 = x + y > 0+   -- a << b is "morally" abs a < abs b, but taking care of overflow.+   a << b = case (a >= 0, b >= 0) of+            (True,  True)  -> a < b+            (False, False) -> a > b+            (True,  False) -> a + b < 0+            (False, True)  -> a + b > 0  -- | Shrink a fraction. shrinkRealFrac :: RealFrac a => a -> [a]@@ -364,7 +368,7 @@   , x' << x   ]  where-  x << y = abs x < abs y+  a << b = abs a < abs b  -------------------------------------------------------------------------- -- ** CoArbitrary

@@ -56,7 +56,7 @@  -- | Modifies a generator using an integer seed. variant :: Integral n => n -> Gen a -> Gen a-variant k (MkGen m) = MkGen (\r n -> m (var k r) n)+variant k0 (MkGen m) = MkGen (\r n -> m (var k0 r) n)  where   var k = (if k == k' then id  else var k')         . (if even k  then fst else snd)@@ -77,16 +77,16 @@ choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) --- | Promotes a generator to a generator of monadic values.+-- | Promotes a monadic generator to a generator of monadic values. promote :: Monad m => m (Gen a) -> Gen (m a) promote m = MkGen (\r n -> liftM (\(MkGen m') -> m' r n) m)  -- | Generates some example values. sample' :: Gen a -> IO [a] sample' (MkGen m) =-  do rnd <- newStdGen+  do rnd0 <- newStdGen      let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = split rnd-     return [(m r n) | (r,n) <- rnds rnd `zip` [0,2..20] ]+     return [(m r n) | (r,n) <- rnds rnd0 `zip` [0,2..20] ]  -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO ()@@ -123,9 +123,9 @@ -- The input list must be non-empty. frequency :: [(Int, Gen a)] -> Gen a frequency [] = error "QuickCheck.frequency used with empty list"-frequency xs = choose (1, tot) >>= (`pick` xs)+frequency xs0 = choose (1, tot) >>= (`pick` xs0)  where-  tot = sum (map fst xs)+  tot = sum (map fst xs0)    pick n ((k,x):xs)     | n <= k    = x

@@ -177,7 +177,7 @@    shrink (Smart i x) = take i' ys `ilv` drop i' ys    where-    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]+    ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ]     i' = 0 `max` (i-2)      []     `ilv` bs     = bs

@@ -7,7 +7,6 @@  import Test.QuickCheck.Gen import Test.QuickCheck.Property-import Test.QuickCheck.Arbitrary  import Control.Monad   ( liftM@@ -15,10 +14,6 @@  import Control.Monad.ST -import System.IO.Unsafe-  ( unsafePerformIO-  )- -- instance of monad transformer?  --------------------------------------------------------------------------@@ -33,34 +28,21 @@ instance Monad m => Monad (PropertyM m) where   return x            = MkPropertyM (\k -> k x)   MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k))-  fail s              = MkPropertyM (\k -> return (return (property result)))-   where-    result = failed result{ reason = s }+  fail s              = stop (failed { reason = s }) +stop :: (Testable prop, Monad m) => prop -> PropertyM m a+stop p = MkPropertyM (\_k -> return (return (property p)))+ -- should think about strictness/exceptions here --assert :: Testable prop => prop -> PropertyM m () assert :: Monad m => Bool -> PropertyM m ()-assert b = MkPropertyM $ \k ->-  if b-    then k ()-    else return (return (property False))--{--let Prop p = property a in Monadic $ \k ->-  do r <- p-     case ok r of-       Just True -> do m <- k ()-                       return (do p' <- m-		                  return (r &&& p'))-       _ -> return (return (property r))--}+assert True = return ()+assert False = fail "Assertion failed"  -- should think about strictness/exceptions here pre :: Monad m => Bool -> PropertyM m ()-pre b = MkPropertyM $ \k ->-  if b-    then k ()-    else return (return (property ()))+pre True = return ()+pre False = stop rejected  -- should be called lift? run :: Monad m => m a -> PropertyM m a@@ -85,63 +67,19 @@ -- run functions  monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property-monadic run (MkPropertyM m) =-  do mp <- m (const (return (return (property True))))-     run mp+monadic runner m = property (fmap runner (monadic' m)) -{--monadicIO :: Monad m => (m Property -> IO Property) -> PropertyM m a -> IO Property-monadicIO run (MkPropertyM m) =-  do mp <- m (const (return (return (property True))))-     run mp--}+monadic' :: Monad m => PropertyM m a -> Gen (m Property)+monadic' (MkPropertyM m) = m (const (return (return (property True)))) --- Can't make this work in any other way... :-( monadicIO :: PropertyM IO a -> Property-monadicIO (MkPropertyM m) =-  property $-    unsafePerformIO `fmap`-      m (const (return (return (property True))))--newtype IdM m s a = MkIdM { unIdM :: m s a }--data MonadS' m-  = MkMonadS-  { ret :: forall a   s . a -> m s a-  , bin :: forall a b s . m s a -> (a -> m s b) -> m s b-  }----grab () = MkMonadS return (>>=)--class MonadS m where-  return' :: a -> m s a-  bind'   :: m s a -> (a -> m s b) -> m s b--instance MonadS m => Monad (IdM m s) where-  return = MkIdM . return'-  MkIdM m >>= k = MkIdM (m `bind'` (unIdM . k))--{--monadicS :: MonadS m => ((forall s . m s Property) -> Property) -> (forall s . PropertyM (m s) a) -> Property-monadicS run mp = MkGen $ \r n ->-  let MkGen g'      = run (let MkPropertyM f = mp'                                        -                               MkGen g       = f (const (return (return (property True))))-                            in unIdM (g r n))-   in g' undefined undefined- where-  mp' = MkPropertyM (\k -> fmap MkIdM (unPropertyM mp (\a -> fmap unIdM (k a))))--}+monadicIO = monadic property -{-+monadicST :: (forall s. PropertyM (ST s) a) -> Property+monadicST m = property (runSTGen (monadic' m)) --- does not compile with GHC 6.6-imperative :: (forall s. PropertyM (ST s) a) -> Property-imperative m = MkGen $ \r n ->-  let MkPropertyM f = m-      MkGen g = f (const (return (return (property True))))-      MkGen q = runST (g r n)-   in q undefined undefined--}+runSTGen :: (forall s. Gen (ST s a)) -> Gen a+runSTGen g = MkGen $ \r n -> runST (unGen g r n)  -------------------------------------------------------------------------- -- the end.

@@ -6,7 +6,7 @@  import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Text( showErr )+import Test.QuickCheck.Text( showErr, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State @@ -19,8 +19,6 @@   , putMVar   ) -import Data.IORef- import System.IO   ( hFlush   , stdout@@ -52,11 +50,14 @@   property = return . MkProp . return . return  instance Testable Prop where-  property = return+  property = return . protectProp  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+ instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where   property f = forAllShrink arbitrary shrink f @@ -67,27 +68,41 @@  newtype Prop = MkProp{ unProp :: Rose (IO Result) } +protectProp :: Prop -> Prop+protectProp (MkProp r) =+  MkProp . IORose $ do+    (x, rs) <- unpackRose r+    return (MkRose x rs)+ -- ** type Rose -data Rose a = MkRose a [Rose a]+-- 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))  join :: Rose (Rose a) -> Rose a-join (MkRose ~(MkRose x ts) tts) =+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) =   -- first shrinks outer quantification; makes most sense   MkRose x (map join tts ++ ts)   -- first shrinks inner quantification   --MkRose x (ts ++ map join tts)  instance Functor Rose where-  fmap f ~(MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]+  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) -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+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  -- ** Result type @@ -118,19 +133,20 @@   , callbacks   = []   } -failed :: Result -> Result-failed res = res{ ok = Just False }--exception res err = failed res{ reason = "Exception: '" ++ showErr err ++ "'",-                                interrupted = isInterrupt err }+exception :: String -> AnException -> Result+exception msg err = failed{ reason = msg ++ ": '" ++ showErr err ++ "'",+                            interrupted = isInterrupt err }  protectResult :: IO Result -> IO Result-protectResult m = either (exception result) id `fmap` tryEvaluateIO (fmap force m)+protectResult m = either (exception "Exception") id `fmap` tryEvaluateIO (fmap force m)   where force res = ok res == Just False `seq` res  succeeded :: Result  succeeded = result{ ok = Just True } +failed :: Result+failed = result{ ok = Just False }+ rejected :: Result rejected = result{ ok = Nothing } @@ -148,10 +164,7 @@ liftResult r = liftIOResult (return r)  liftIOResult :: IO Result -> Property-liftIOResult m = liftRoseIOResult (return m)--liftRoseIOResult :: Rose (IO Result) -> Property-liftRoseIOResult t = return (MkProp t)+liftIOResult m = property (MkProp (return m))  mapResult :: Testable prop => (Result -> Result) -> prop -> Property mapResult f = mapIOResult (fmap f)@@ -159,11 +172,12 @@ mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property mapIOResult f = mapRoseIOResult (fmap (f . protectResult)) +-- 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))  mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property-mapProp f = fmap f . property +mapProp f = fmap f . property  -------------------------------------------------------------------------- -- ** Property combinators@@ -179,24 +193,31 @@              (a -> [a])  -- ^ 'shrink'-like function.           -> a           -- ^ The original argument           -> (a -> prop) -> Property-shrinking shrink x pf = fmap (MkProp . join . fmap unProp) (promote (props x))+shrinking shrinker x0 pf = fmap (MkProp . join . fmap unProp) (promote (props x0))  where   props x =-    MkRose (property (pf x)) [ props x' | x' <- shrink 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 []+  where f (MkRose mres _ts) = MkRose mres []+        f (IORose rm) = IORose (fmap f rm)  -- | Adds a callback callback :: Testable prop => Callback -> prop -> Property callback cb = mapResult (\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 ->+    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 $ \_st _res ->     m  -- | Performs an 'IO' action every time a property fails. Thus,@@ -204,7 +225,7 @@ -- failures along the way. whenFail' :: Testable prop => IO () -> prop -> Property whenFail' m =-  callback $ PostTest $ \st res ->+  callback $ PostTest $ \_st res ->     if ok res == Just False       then m       else return ()@@ -262,7 +283,7 @@              do put "Waiting ..."                 threadDelay n                 put "Done waiting!"-                putMVar resV (failed result{reason = "Time out"})+                putMVar resV (failed {reason = "Time out"})                        evalProp =              do put "Evaluating Result ..."@@ -292,22 +313,22 @@        => Gen a -> (a -> prop) -> Property forAll gen pf =   gen >>= \x ->-    whenFail (putStrLn (show x)) $+    whenFailPrint (show x) $       property (pf x)  -- | Like 'forAll', but tries to shrink the argument for failing test cases. forAllShrink :: (Show a, Testable prop)              => Gen a -> (a -> [a]) -> (a -> prop) -> Property-forAllShrink gen shrink pf =+forAllShrink gen shrinker pf =   gen >>= \x ->-    shrinking shrink x $ \x' ->-      whenFail (putStrLn (show x')) $+    shrinking shrinker x $ \x' ->+      whenFailPrint (show x') $         property (pf x')  (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 =   arbitrary >>= \b ->-    whenFail (putStrLn (if b then "LHS" else "RHS")) $+    whenFailPrint (if b then "LHS" else "RHS") $       if b then property p1 else property p2  {-

@@ -25,7 +25,6 @@   , randomSeed        :: StdGen     -- ^ the current random seed      -- shrinking-  , isShrinking       :: Bool       -- ^ are we in a shrinking phase?   , numSuccessShrinks :: Int        -- ^ number of successful shrinking steps so far   , numTryShrinks     :: Int        -- ^ number of failed shrinking steps since the last successful shrink   }

@@ -9,6 +9,7 @@ import Test.QuickCheck.Text import Test.QuickCheck.State import Test.QuickCheck.Exception+import Data.IORef  import System.Random   ( RandomGen(..)@@ -26,7 +27,6 @@   , groupBy   , intersperse   )- -------------------------------------------------------------------------- -- quickCheck @@ -39,26 +39,35 @@   , 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   }  deriving ( Show, Read )  -- | 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+    { numTests       :: Int            -- ^ number of successful tests performed+    , labels         :: [(String,Int)] -- ^ labels and frequencies found during all tests+    , output         :: String         -- ^ printed output     }-  | 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+    , output         :: String         -- ^ printed output     }-  | 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+    { numTests       :: Int            -- ^ number of tests performed+    , numShrinks     :: Int            -- ^ number of successful shrinking steps performed+    , 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+    , output         :: String         -- ^ printed output     }-  | 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+    { numTests       :: Int            -- ^ number of tests performed+    , labels         :: [(String,Int)] -- ^ labels and frequencies found during all successful tests+    , output         :: String         -- ^ printed output     }  deriving ( Show, Read ) @@ -74,6 +83,7 @@   , maxSuccess = 100   , maxDiscard = 500   , maxSize    = 100+  , chatty     = True -- noShrinking flag?   } @@ -91,34 +101,33 @@  -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. quickCheckWithResult :: Testable prop => Args -> prop -> IO Result-quickCheckWithResult args p =-  do tm  <- newTerminal-     rnd <- case replay args of+quickCheckWithResult a p =+  do tm <- if chatty a then newStdioTerminal else newNullTerminal+     rnd <- case replay a of               Nothing      -> newStdGen               Just (rnd,_) -> return rnd      test MkState{ terminal          = tm-                 , maxSuccessTests   = maxSuccess args-                 , maxDiscardedTests = maxDiscard args-                 , computeSize       = case replay args of-                                         Nothing    -> computeSize (maxSuccess args) (maxSize args)+                 , maxSuccessTests   = maxSuccess a+                 , maxDiscardedTests = maxDiscard a+                 , computeSize       = case replay a of+                                         Nothing    -> computeSize'                                          Just (_,s) -> \_ _ -> s                  , numSuccessTests   = 0                  , numDiscardedTests = 0                  , collected         = []                  , expectedFailure   = False                  , randomSeed        = rnd-                 , isShrinking       = False                  , numSuccessShrinks = 0                  , numTryShrinks     = 0                  } (unGen (property p))-  where computeSize maxSuccess maxSize n d+  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 + maxSize <= maxSuccess ||-            n >= maxSuccess ||-            maxSuccess `mod` maxSize == 0 = n `mod` maxSize + d `div` 10+          | n `roundTo` maxSize a + maxSize a <= maxSuccess a ||+            n >= maxSuccess a ||+            maxSuccess a `mod` maxSize a == 0 = n `mod` maxSize a + d `div` 10           | otherwise =-            (n `mod` maxSize) * maxSize `div` (maxSuccess `mod` maxSize) + d `div` 10+            (n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10         n `roundTo` m = (n `div` m) * m  --------------------------------------------------------------------------@@ -131,7 +140,7 @@   | otherwise                                    = runATest st f  doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result-doneTesting st f =+doneTesting st _f =   do -- CALLBACK done_testing?      if expectedFailure st then        putPart (terminal st)@@ -147,13 +156,18 @@         ++ " tests (expected failure)"          )      success st+     theOutput <- terminalOutput (terminal st)      if expectedFailure st then-       return Success{ labels = summary st }+       return Success{ labels = summary st,+                       numTests = numSuccessTests st,+                       output = theOutput }       else-       return NoExpectedFailure{ labels = summary st }+       return NoExpectedFailure{ labels = summary st,+                                 numTests = numSuccessTests st,+                                 output = theOutput }    giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result-giveUp st f =+giveUp st _f =   do -- CALLBACK gave_up?      putPart (terminal st)        ( bold ("*** Gave up!")@@ -162,8 +176,10 @@       ++ " tests"        )      success st+     theOutput <- terminalOutput (terminal st)      return GaveUp{ numTests = numSuccessTests st                   , labels   = summary st+                  , output   = theOutput                   }  runATest :: State -> (StdGen -> Int -> Prop) -> IO Result@@ -178,7 +194,7 @@        ++ ")"         )      let size = computeSize st (numSuccessTests st) (numDiscardedTests st)-     MkRose mres ts <- protectRose (unProp (f rnd1 size))+     (mres, ts) <- unpackRose (unProp (f rnd1 size))      res <- mres      callbackPostTest st res      @@ -206,12 +222,18 @@              ++ number (numSuccessTests st+1) "test"              ++ ")..."               )-            foundFailure st res ts+            numShrinks <- foundFailure st res ts+            theOutput <- terminalOutput (terminal st)             if not (expect res) then-              return Success{ labels = summary st }+              return Success{ labels = summary st,+                              numTests = numSuccessTests st+1,+                              output = theOutput }              else               return Failure{ usedSeed    = randomSeed st -- correct! (this will be split first)                             , usedSize    = size+                            , numTests    = numSuccessTests st+1+                            , numShrinks  = numShrinks+                            , output      = theOutput                             , reason      = P.reason res                             , labels      = summary st                             }@@ -232,7 +254,7 @@  success :: State -> IO () success st =-  case labels ++ covers of+  case allLabels ++ covers of     []    -> do putLine (terminal st) "."     [pt]  -> do putLine (terminal st)                   ( " ("@@ -242,16 +264,16 @@     cases -> do putLine (terminal st) ":"                 sequence_ [ putLine (terminal st) pt | pt <- cases ]  where-  labels = reverse-         . sort-         . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))-         . group-         . sort-         $ [ concat (intersperse ", " s')-           | s <- collected st-           , let s' = [ t | (t,0) <- s ]-           , not (null s')-           ]+  allLabels = reverse+            . sort+            . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))+            . group+            . sort+            $ [ concat (intersperse ", " s')+              | s <- collected st+              , let s' = [ t | (t,0) <- s ]+              , not (null s')+              ]      covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%")            | lps <- groupBy first@@ -277,38 +299,46 @@ -------------------------------------------------------------------------- -- main shrinking loop -foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()+foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int foundFailure st res ts =-  do localMin st{ numTryShrinks = 0, isShrinking = True } res ts+  do localMin st{ numTryShrinks = 0 } res ts -localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()+localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int localMin st res _ | P.interrupted res = localMinFound st res-localMin st res [] = localMinFound st res+localMin st res ts = do+  r <- tryEvaluate ts+  case r of+    Left err ->+      localMinFound st+         (exception "Exception while generating shrink-list" err)+    Right ts' -> localMin' st res ts' -localMin st res (t : ts) =+localMin' :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int+localMin' st res [] = localMinFound st res+localMin' st res (t:ts) =   do -- CALLBACK before_test-     MkRose mres' ts' <- protectRose 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-                ]-      ++ ")..."-       )-     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+    (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+               ]+     ++ ")..."+      )+    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 -localMinFound :: State -> P.Result -> IO ()+localMinFound :: State -> P.Result -> IO Int localMinFound st res =   do putLine (terminal st)        ( P.reason res@@ -319,6 +349,7 @@       ++ "):  "        )      callbackPostFinalFailure st res+     return (numSuccessShrinks st)  -------------------------------------------------------------------------- -- callbacks

@@ -8,6 +8,10 @@   , bold      , newTerminal+  , newStdioTerminal+  , newNullTerminal+  , terminalOutput+  , handle   , Terminal   , putTemp   , putPart@@ -23,6 +27,7 @@   , hPutStr   , stdout   , stderr+  , Handle   )  import Data.IORef@@ -65,50 +70,79 @@ -------------------------------------------------------------------------- -- putting strings -newtype Terminal-  = MkTerminal (IORef (IO ()))+data Terminal+  = MkTerminal (IORef (IO ())) Output Output -newTerminal :: IO Terminal-newTerminal =-  do hFlush stdout-     hFlush stderr-     ref <- newIORef (return ())-     return (MkTerminal ref)+data Output+  = Output (String -> IO ()) (IORef String) +newTerminal :: Output -> Output -> IO Terminal+newTerminal out err =+  do ref <- newIORef (return ())+     return (MkTerminal ref out err)++newStdioTerminal :: IO Terminal+newStdioTerminal = do+  out <- output (handle stdout)+  err <- output (handle stderr)+  newTerminal out err++newNullTerminal :: IO Terminal+newNullTerminal = do+  out <- output (const (return ()))+  err <- output (const (return ()))+  newTerminal out err++terminalOutput :: Terminal -> IO String+terminalOutput (MkTerminal _ out _) = get out++handle :: Handle -> String -> IO ()+handle h s = do+  hPutStr h s+  hFlush h++output :: (String -> IO ()) -> IO Output+output f = do+  r <- newIORef ""+  return (Output f r)++put :: Output -> String -> IO ()+put (Output f r) s = do+  f s+  modifyIORef r (++ s)++get :: Output -> IO String+get (Output _ r) = readIORef r+ flush :: Terminal -> IO ()-flush (MkTerminal ref) =+flush (MkTerminal ref _ _) =   do io <- readIORef ref      writeIORef ref (return ())      io  postpone :: Terminal -> IO () -> IO ()-postpone (MkTerminal ref) io' =+postpone (MkTerminal ref _ _) io' =   do io <- readIORef ref      writeIORef ref (io >> io')  putPart, putTemp, putLine :: Terminal -> String -> IO ()-putPart tm s =+putPart tm@(MkTerminal _ out _) s =   do flush tm-     putStr s-     hFlush stdout+     put out s      -putTemp tm s =+putTemp tm@(MkTerminal _ _ err) s =   do flush tm-     hPutStr h s-     hPutStr h [ '\b' | _ <- s ]-     hFlush h+     put err s+     put err [ '\b' | _ <- s ]      postpone tm $-       do hPutStr h ( [ ' ' | _ <- s ]-                   ++ [ '\b' | _ <- s ]-                    )- where-  --h = stdout-  h = stderr+       put err ( [ ' ' | _ <- s ]+              ++ [ '\b' | _ <- s ]+               )      -putLine tm s =+putLine tm@(MkTerminal _ out _) s =   do flush tm-     putStrLn s-     hFlush stdout    +     put out s+     put out "\n"  -------------------------------------------------------------------------- -- the end.