diff --git a/QuickCheck.cabal b/QuickCheck.cabal
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -1,5 +1,5 @@
 Name: QuickCheck
-Version: 2.2
+Version: 2.3
 Cabal-Version: >= 1.2
 Build-type: Simple
 License: BSD3
diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs
--- a/Test/QuickCheck/Arbitrary.hs
+++ b/Test/QuickCheck/Arbitrary.hs
@@ -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
diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs
--- a/Test/QuickCheck/Gen.hs
+++ b/Test/QuickCheck/Gen.hs
@@ -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
diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs
--- a/Test/QuickCheck/Modifiers.hs
+++ b/Test/QuickCheck/Modifiers.hs
@@ -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
diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs
--- a/Test/QuickCheck/Monadic.hs
+++ b/Test/QuickCheck/Monadic.hs
@@ -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.
diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs
--- a/Test/QuickCheck/Property.hs
+++ b/Test/QuickCheck/Property.hs
@@ -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
 
 {-
diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs
--- a/Test/QuickCheck/State.hs
+++ b/Test/QuickCheck/State.hs
@@ -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
   }
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
--- a/Test/QuickCheck/Test.hs
+++ b/Test/QuickCheck/Test.hs
@@ -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
diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs
--- a/Test/QuickCheck/Text.hs
+++ b/Test/QuickCheck/Text.hs
@@ -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.