diff --git a/QuickCheck.cabal b/QuickCheck.cabal
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -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:
diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs
--- a/Test/QuickCheck.hs
+++ b/Test/QuickCheck.hs
@@ -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
diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs
new file mode 100644
--- /dev/null
+++ b/Test/QuickCheck/All.hs
@@ -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
diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs
--- a/Test/QuickCheck/Arbitrary.hs
+++ b/Test/QuickCheck/Arbitrary.hs
@@ -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
diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs
--- a/Test/QuickCheck/Exception.hs
+++ b/Test/QuickCheck/Exception.hs
@@ -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)
diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs
--- a/Test/QuickCheck/Function.hs
+++ b/Test/QuickCheck/Function.hs
@@ -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.
diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs
--- a/Test/QuickCheck/Gen.hs
+++ b/Test/QuickCheck/Gen.hs
@@ -4,9 +4,10 @@
 -- imports
 
 import System.Random
-  ( RandomGen(..)
-  , Random(..)
+  ( Random
   , StdGen
+  , randomR
+  , split
   , newStdGen
   )
 
diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs
--- a/Test/QuickCheck/Monadic.hs
+++ b/Test/QuickCheck/Monadic.hs
@@ -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))
diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs
--- a/Test/QuickCheck/Poly.hs
+++ b/Test/QuickCheck/Poly.hs
@@ -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
diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs
--- a/Test/QuickCheck/Property.hs
+++ b/Test/QuickCheck/Property.hs
@@ -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.
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
--- a/Test/QuickCheck/Test.hs
+++ b/Test/QuickCheck/Test.hs
@@ -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.