diff --git a/Development/Shake.hs b/Development/Shake.hs
--- a/Development/Shake.hs
+++ b/Development/Shake.hs
@@ -64,16 +64,21 @@
 --
 --   /Acknowledgements/: Thanks to Austin Seipp for properly integrating the profiling code.
 module Development.Shake(
+    -- * Core
     shake,
-    -- * Core of Shake
-    ShakeOptions(..), shakeOptions, Assume(..), Progress(..),
+    shakeOptions,
 #if __GLASGOW_HASKELL__ >= 704
     ShakeValue,
 #endif
     Rule(..), Rules, defaultRule, rule, action, withoutActions,
     Action, apply, apply1, traced,
-    Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet,
     liftIO,
+    -- * Configuration
+    ShakeOptions(..), Assume(..),
+    -- ** Progress reporting
+    Progress(..), progressSimple, progressDisplay, progressTitlebar,
+    -- ** Verbosity
+    Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, quietly,
     -- * Utility functions
     module Development.Shake.Derived,
     -- * File rules
@@ -81,7 +86,7 @@
     module Development.Shake.Files,
     FilePattern, (?==),
     -- * Directory rules
-    doesFileExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
+    doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
     -- * Additional rules
     addOracle, askOracle, askOracleWith,
     alwaysRerun,
@@ -96,6 +101,7 @@
 import Development.Shake.Types
 import Development.Shake.Core
 import Development.Shake.Derived
+import Development.Shake.Progress
 
 import Development.Shake.Directory
 import Development.Shake.File
diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs
--- a/Development/Shake/Core.hs
+++ b/Development/Shake/Core.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-}
 {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-}
 
 {-# LANGUAGE CPP #-}
@@ -13,14 +13,17 @@
 #endif
     Rule(..), Rules, defaultRule, rule, action, withoutActions,
     Action, apply, apply1, traced,
-    getVerbosity, putLoud, putNormal, putQuiet,
+    getVerbosity, putLoud, putNormal, putQuiet, quietly,
     Resource, newResource, withResource
     ) where
 
 import Control.Exception as E
+import Control.Applicative
+import Control.Concurrent
 import Control.Monad
 import Control.Monad.IO.Class
-import Control.Monad.Trans.State as State
+import Control.Monad.Trans.Writer.Strict
+import Control.Monad.Trans.State.Strict as State
 import Data.Typeable
 import Data.Function
 import Data.List
@@ -36,6 +39,7 @@
 import Development.Shake.Value
 import Development.Shake.Report
 import Development.Shake.Types
+import Development.Shake.Errors
 
 
 ---------------------------------------------------------------------
@@ -107,34 +111,42 @@
 data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value))
 
 ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key
-ruleKey = undefined
+ruleKey = err "ruleKey"
 
 ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value
-ruleValue = undefined
+ruleValue = err "ruleValue"
 
 
 -- | Define a set of rules. Rules can be created with calls to 'rule', 'defaultRule' or 'action'. Rules are combined
 --   with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation.
-data Rules a = Rules
-    {value :: a -- not really used, other than for the Monad instance
-    ,actions :: [Action ()]
+newtype Rules a = Rules (Writer SRules a)
+    deriving (Monad, Functor, Applicative)
+
+newRules :: SRules -> Rules ()
+newRules = Rules . tell
+
+modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()
+modifyRules f (Rules r) = Rules $ censor f r
+
+getRules :: Rules () -> SRules
+getRules (Rules r) = execWriter r
+
+
+data SRules = SRules
+    {actions :: [Action ()]
     ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule)]) -- higher fst is higher priority
     }
 
-instance Monoid a => Monoid (Rules a) where
-    mempty = return mempty
-    mappend a b = (a >> b){value = value a `mappend` value b}
-
-instance Monad Rules where
-    return x = Rules x [] (Map.fromList [])
-    Rules v1 x1 x2 >>= f = case f v1 of
-        Rules v2 y1 y2 -> Rules v2 (x1++y1) (Map.unionWith g x2 y2)
-        where g (k, v1, xs) (_, v2, ys)
+instance Monoid SRules where
+    mempty = SRules [] (Map.fromList [])
+    mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2)
+        where f (k, v1, xs) (_, v2, ys)
                 | v1 == v2 = (k, v1, xs ++ ys)
-                | otherwise = error $ "There are two incompatible rules for " ++ show k ++ ", producing " ++ show v1 ++ " and " ++ show v2
+                | otherwise = errorIncompatibleRules k v1 v2
 
-instance Functor Rules where
-    fmap f x = return . f =<< x
+instance Monoid a => Monoid (Rules a) where
+    mempty = return mempty
+    mappend a b = do a <- a; b <- b; return $ mappend a b
 
 
 -- | Like 'rule', but lower priority, if no 'rule' exists then 'defaultRule' is checked.
@@ -153,60 +165,66 @@
 --   The function 'defaultRule' is priority 0 and 'rule' is priority 1. All rules of the same
 --   priority must be disjoint.
 rulePriority :: Rule key value => Int -> (key -> Maybe (Action value)) -> Rules ()
-rulePriority i r = mempty{rules = Map.singleton k (k, v, [(i,ARule r)])}
+rulePriority i r = newRules mempty{rules = Map.singleton k (k, v, [(i,ARule r)])}
     where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r
 
 
 -- | Run an action, usually used for specifying top-level requirements.
 action :: Action a -> Rules ()
-action a = mempty{actions=[a >> return ()]}
+action a = newRules mempty{actions=[a >> return ()]}
 
 
 -- | Remove all actions specified in a set of rules, usually used for implementing
 --   command line specification of what to build.
 withoutActions :: Rules () -> Rules ()
-withoutActions x = x{actions=[]}
+withoutActions = modifyRules $ \x -> x{actions=[]}
 
 
 ---------------------------------------------------------------------
 -- MAKE
 
-data S = S
+data RuleInfo = RuleInfo
+    {stored :: Key -> IO (Maybe Value)
+    ,execute :: Key -> Action Value
+    ,resultType :: TypeRep
+    }
+
+data SAction = SAction
     -- global constants
     {database :: Database
     ,pool :: Pool
-    ,started :: IO Time
-    ,stored :: Key -> Value -> IO Bool
-    ,execute :: Key -> Action Value
+    ,timestamp :: IO Time
+    ,ruleinfo :: Map.HashMap TypeRep RuleInfo
     ,output :: String -> IO ()
     ,verbosity :: Verbosity
     ,logger :: String -> IO ()
-    ,assume :: Maybe Assume
     -- stack variables
     ,stack :: Stack
     -- local variables
     ,depends :: [Depends] -- built up in reverse
-    ,discount :: Duration
-    ,traces :: [(String, Time, Time)] -- in reverse
+    ,discount :: !Duration
+    ,traces :: [Trace] -- in reverse
     }
 
 -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'need' to execute files.
 --   Action values are used by 'rule' and 'action'.
-newtype Action a = Action (StateT S IO a)
-    deriving (Functor, Monad, MonadIO)
+newtype Action a = Action (StateT SAction IO a)
+    deriving (Monad, MonadIO, Functor, Applicative)
 
 
 -- | Internal main function (not exported publicly)
 run :: ShakeOptions -> Rules () -> IO ()
 run opts@ShakeOptions{..} rs = do
     start <- startTime
+    rs <- return $ getRules rs
     registerWitnesses rs
 
-    output <- do
+    outputLocked <- do
         lock <- newLock
         return $ withLock lock . putStrLn
 
-    let logger = if shakeVerbosity >= Diagnostic then output . ("% "++) else const $ return ()
+    let logger = if shakeVerbosity >= Diagnostic then outputLocked . ("% "++) else const $ return ()
+    let output = outputLocked . abbreviate shakeAbbreviations
 
     except <- newVar (Nothing :: Maybe SomeException)
     let staunch act | not shakeStaunch = act >> return ()
@@ -219,17 +237,16 @@
                     when (shakeVerbosity >= Quiet) $ output msg
                 Right _ -> return ()
 
-    let stored = createStored shakeAssume rs
-    let execute = createExecute shakeAssume rs
+    let ruleinfo = createRuleinfo shakeAssume rs
     running <- newIORef True
     flip finally (writeIORef running False) $ do
-        withDatabase logger shakeFiles shakeVersion shakeFlush $ \database -> do
-            shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}
+        withDatabase opts logger $ \database -> do
+            forkIO $ shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}
             runPool shakeDeterministic shakeThreads $ \pool -> do
-                let s0 = S database pool start stored execute output shakeVerbosity logger shakeAssume emptyStack [] 0 []
+                let s0 = SAction database pool start ruleinfo output shakeVerbosity logger emptyStack [] 0 []
                 mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs)
             when shakeLint $ do
-                checkValid database stored
+                checkValid database (runStored ruleinfo)
                 when (shakeVerbosity >= Loud) $ output "Lint checking succeeded"
             when (isJust shakeReport) $ do
                 let file = fromJust shakeReport
@@ -240,6 +257,18 @@
         maybe (return ()) throwIO =<< readVar except
 
 
+abbreviate :: [(String,String)] -> String -> String
+abbreviate [] = id
+abbreviate abbrev = f
+    where
+        -- order so longer appreviations are preferred
+        ordAbbrev = reverse $ sortBy (compare `on` length . fst) abbrev
+
+        f [] = []
+        f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest
+        f (x:xs) = x : f xs
+
+
 wrapStack :: IO [String] -> IO a -> IO a
 wrapStack stk act = E.catch act $ \(SomeException e) -> case cast e of
     Just s@ShakeException{} -> throw s
@@ -248,102 +277,77 @@
         throw $ ShakeException stk $ SomeException e
 
 
-registerWitnesses :: Rules () -> IO ()
-registerWitnesses Rules{..} =
+registerWitnesses :: SRules -> IO ()
+registerWitnesses SRules{..} =
     forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do
         registerWitness $ ruleKey r
         registerWitness $ ruleValue r
 
 
-createStored :: Maybe Assume -> Rules () -> (Key -> Value -> IO Bool)
-createStored assume Rules{..} = \k v ->
-    let (tk,tv) = (typeKey k, typeValue v) in
-    case Map.lookup tk mp of
-        Nothing -> error $
-            "Error: couldn't find instance Rule " ++ showTypeRepBracket tk ++ " " ++ showTypeRepBracket tv ++
-            ", perhaps you are missing a call to " ++
-            (if isOracleTypes tk tv then "addOracle" else "defaultRule/rule") ++ "?"
-        Just (tv2,_) | tv2 /= tv -> error $
-            "Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++
-            ", but did find an instance Rule " ++ show tk ++ " " ++ show tv2 ++
-            ", perhaps you have the types wrong in your call to apply?"
-        Just (_, r) -> r k v
+createRuleinfo :: Maybe Assume -> SRules -> Map.HashMap TypeRep RuleInfo
+createRuleinfo assume SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv
     where
-        mp = flip Map.map rules $ \(_,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx))
-
-        -- NOTE: We change the storedValue type so that we always pass in both key and value, rather than having
-        --       value as a return param. That allows us to give better error messages (see createStored)
-        ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> IO Bool)
-        ruleStored _ = if assume == Just AssumeDirty
-                       then \k v -> return False
-                       else \k v -> fmap (== Just v) $ storedValue k
-
-
-isOracleTypes :: TypeRep -> TypeRep -> Bool
-isOracleTypes tk tv = f tk "OracleQ" && f tv "OracleA"
-    where f t s = show (fst $ splitTyConApp t) == s
-
-showTypeRepBracket :: TypeRep -> String
-showTypeRepBracket ty = ['(' | not safe] ++ show ty ++ [')' | not safe]
-    where (t1,args) = splitTyConApp ty
-          st1 = show t1
-          safe = null args || st1 == "[]" || "(" `isPrefixOf` st1
-
+        stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey
+            where f :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value))
+                  f _ = storedValue
 
-createExecute :: Maybe Assume -> Rules () -> (Key -> Action Value)
-createExecute assume Rules{..} = \k ->
-    let tk = typeKey k
-        norm = case Map.lookup tk mp of
-            Nothing -> error $
-                "Error: couldn't find any rules to build " ++ show k ++ " of type " ++ show tk ++
-                ", perhaps you are missing a call to defaultRule/rule?"
-            Just rs -> case filter (not . null) $ map (mapMaybe ($ k)) rs of
+        execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of
                [r]:_ -> r
-               rs ->
-                  let s = if null rs then "no" else show (length $ head rs)
-                  in error $ "Error: " ++ s ++ " rules match for Rule " ++ show k ++ " of type " ++ show tk
-        clean = case Map.lookup tk mpClean of
-            Nothing -> norm -- should reraise an error
-            Just stored -> do res <- liftIO $ stored k; maybe norm return res
-    in if assume == Just AssumeClean then clean else norm
-    where
-        mp = flip Map.map rules $ \(_,_,rs) -> sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs]
+               rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)
+            where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] 
 
         sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest
         sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
 
-        mpClean = flip Map.map rules $ \(_,_,(_,ARule r):_) -> \k -> fmap (fmap newValue) $ ruleStored r $ fromKey k
+runStored :: Map.HashMap TypeRep RuleInfo -> Key -> IO (Maybe Value)
+runStored mp k = case Map.lookup (typeKey k) mp of
+    Nothing -> return Nothing
+    Just RuleInfo{..} -> stored k
 
-        ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value))
-        ruleStored _ = storedValue
+runExecute :: Map.HashMap TypeRep RuleInfo -> Key -> Action Value
+runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of
+    Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing -- Not sure if this is even possible, but best be safe
+    Just RuleInfo{..} -> execute k
 
 
-runAction :: S -> Action a -> IO (a, S)
+runAction :: SAction -> Action a -> IO (a, SAction)
 runAction s (Action x) = runStateT x s
 
 
 -- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.
 --   This function requires that appropriate rules have been added with 'rule' or 'defaultRule'.
 apply :: Rule key value => [key] -> Action [value]
-apply ks = fmap (map fromValue) $ applyKeyValue $ map newKey ks
+apply = f
+    where
+        -- We don't want the forall in the Haddock docs
+        f :: forall key value . Rule key value => [key] -> Action [value]
+        f ks = do
+            ruleinfo <- Action $ State.gets ruleinfo
+            let tk = typeOf (err "apply key" :: key)
+                tv = typeOf (err "apply type" :: value)
+            case Map.lookup tk ruleinfo of
+                Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv)
+                Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv
+                _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks
 
+
 applyKeyValue :: [Key] -> Action [Value]
-applyKeyValue ks = Action $ do
-    s <- State.get
+applyKeyValue ks = do
+    s <- Action State.get
     let exec stack k = try $ wrapStack (showStack (database s) stack) $ do
             evaluate $ rnf k
             let s2 = s{depends=[], stack=stack, discount=0, traces=[]}
             (dur,(res,s2)) <- duration $ runAction s2 $ do
-                putNormal $ "# " ++ show k
-                execute s k
+                putLoud $ "# " ++ show k
+                runExecute (ruleinfo s) k
             let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2)
             evaluate $ rnf ans
             return ans
-    res <- liftIO $ build (pool s) (database s) (Ops (stored s) exec) (assume s) (stack s) ks
+    res <- liftIO $ build (pool s) (database s) (Ops (runStored (ruleinfo s)) exec) (stack s) ks
     case res of
         Left err -> throw err
         Right (dur, dep, vs) -> do
-            State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s}
+            Action $ State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s}
             return vs
 
 
@@ -357,18 +361,19 @@
 --   The 'Develoment.Shake.system'' command automatically calls 'traced'. The trace list is used for profile reports
 --   (see 'shakeReport').
 traced :: String -> IO a -> Action a
-traced msg act = Action $ do
-    s <- State.get
-    start <- liftIO $ started s
+traced msg act = do
+    s <- Action State.get
+    start <- liftIO $ timestamp s
+    putNormal $ "# " ++ topStack (stack s) ++ " " ++ msg
     res <- liftIO act
-    stop <- liftIO $ started s
-    State.modify $ \s -> s{traces = (msg,start,stop):traces s}
+    stop <- liftIO $ timestamp s
+    Action $ State.modify $ \s -> s{traces = (pack msg,start,stop):traces s}
     return res
 
 
 putWhen :: (Verbosity -> Bool) -> String -> Action ()
-putWhen f msg = Action $ do
-    s <- State.get
+putWhen f msg = do
+    s <- Action State.get
     when (f $ verbosity s) $
         liftIO $ output s msg
 
@@ -389,11 +394,26 @@
 getVerbosity :: Action Verbosity
 getVerbosity = Action $ gets verbosity
 
+-- | Run an action with a particular verbosity level.
+withVerbosity :: Verbosity -> Action a -> Action a
+withVerbosity new act = do
+    old <- Action $ State.gets verbosity
+    Action $ State.modify $ \s -> s{verbosity=new}
+    res <- act
+    Action $ State.modify $ \s -> s{verbosity=old}
+    return res
 
+
+-- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'
+--   (including from 'Development.Shake.system'') will not be printed to the screen.
+quietly :: Action a -> Action a
+quietly = withVerbosity Quiet
+
+
 -- | Run an action which uses part of a finite resource. For an example see 'Resource'.
 withResource :: Resource -> Int -> Action a -> Action a
-withResource r i act = Action $ do
-    s <- State.get
+withResource r i act = do
+    s <- Action State.get
     (res,s) <- liftIO $ bracket_
         (do res <- acquireResource r i
             case res of
@@ -405,5 +425,5 @@
         (do releaseResource r i
             logger s $ show r ++ " released " ++ show i)
         (runAction s act)
-    State.put s
+    Action $ State.put s
     return res
diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs
--- a/Development/Shake/Database.hs
+++ b/Development/Shake/Database.hs
@@ -7,7 +7,7 @@
     Database, withDatabase,
     Ops(..), build, Depends,
     progress,
-    Stack, emptyStack, showStack,
+    Stack, emptyStack, showStack, topStack,
     showJSON, checkValid,
     ) where
 
@@ -15,6 +15,7 @@
 import Development.Shake.Binary
 import Development.Shake.Pool
 import Development.Shake.Value
+import Development.Shake.Errors
 import Development.Shake.Locks
 import Development.Shake.Storage
 import Development.Shake.Types
@@ -27,6 +28,7 @@
 import Data.IORef
 import Data.Maybe
 import Data.List
+import Data.Monoid
 import Data.Time.Clock
 
 type Map = Map.HashMap
@@ -68,30 +70,32 @@
 ---------------------------------------------------------------------
 -- CALL STACK
 
-newtype Stack = Stack [Id]
+data Stack = Stack (Maybe Key) [Id]
 
 showStack :: Database -> Stack -> IO [String]
-showStack Database{..} (Stack xs) = do
+showStack Database{..} (Stack _ xs) = do
     status <- withLock lock $ readIORef status
     return $ reverse $ map (maybe "<unknown>" (show . fst) . flip Map.lookup status) xs
 
-addStack :: Id -> Stack -> Stack
-addStack x (Stack xs) = Stack $ x : xs
+addStack :: Id -> Key -> Stack -> Stack
+addStack x key (Stack _ xs) = Stack (Just key) $ x : xs
 
+topStack :: Stack -> String
+topStack (Stack key _) = maybe "<unknown>" show key
+
 checkStack :: [Id] -> Stack -> Maybe Id
-checkStack new (Stack old)
+checkStack new (Stack _ old)
     | bad:_ <- old `intersect` new = Just bad
     | otherwise = Nothing
 
 emptyStack :: Stack
-emptyStack = Stack []
+emptyStack = Stack Nothing []
 
 
 ---------------------------------------------------------------------
 -- CENTRAL TYPES
 
-type Trace = (String, Time, Time)
-
+type Trace = (BS, Time, Time) -- (message, start, end)
 
 -- | Invariant: The database does not have any cycles when a Key depends on itself
 data Database = Database
@@ -101,6 +105,7 @@
     ,step :: Step
     ,journal :: Id -> (Key, Status {- Loaded or Missing -}) -> IO ()
     ,logger :: String -> IO () -- logging function
+    ,assume :: Maybe Assume
     }
 
 data Status
@@ -109,9 +114,7 @@
     | Loaded Result -- Loaded from the database
     | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building
     | Missing -- I am only here because I got into the Intern table
-      deriving Show
 
--- FIXME: Probably want Step's to be strict and unpacked? Benchmark on a large example
 data Result = Result
     {result :: Value -- the result associated with the Key
     ,built :: {-# UNPACK #-} !Step -- when it was actually run
@@ -119,7 +122,7 @@
     ,depends :: [[Id]] -- dependencies
     ,execution :: {-# UNPACK #-} !Duration -- how long it took when it was last run (seconds)
     ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run)
-    } deriving Show
+    }
 
 
 newtype Pending = Pending (IORef (IO ()))
@@ -129,6 +132,12 @@
 instance Show Pending where show _ = "Pending"
 
 
+statusType Ready{} = "Ready"
+statusType Error{} = "Error"
+statusType Loaded{} = "Loaded"
+statusType Waiting{} = "Waiting"
+statusType Missing{} = "Missing"
+
 isError Error{} = True; isError _ = False
 isWaiting Waiting{} = True; isWaiting _ = False
 isReady Ready{} = True; isReady _ = False
@@ -173,16 +182,16 @@
     deriving (NFData)
 
 data Ops = Ops
-    {valid :: Key -> Value -> IO Bool
+    {stored :: Key -> IO (Maybe Value)
         -- ^ Given a Key and a Value from the database, check it still matches the value stored on disk
-    ,exec :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace]))
+    ,execute :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace]))
         -- ^ Given a chunk of stack (bottom element first), and a key, either raise an exception or successfully build it
     }
 
 
 -- | Return either an exception (crash), or (how much time you spent waiting, the value)
-build :: Pool -> Database -> Ops -> Maybe Assume -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value]))
-build pool Database{..} Ops{..} assume stack ks = do
+build :: Pool -> Database -> Ops -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value]))
+build pool Database{..} Ops{..} stack ks = do
     join $ withLock lock $ do
         is <- forM ks $ \k -> do
             is <- readIORef intern
@@ -196,7 +205,9 @@
 
         whenJust (checkStack is stack) $ \bad -> do
             status <- readIORef status
-            error $ "Invalid rules, recursion detected when trying to build: " ++ maybe "<unknown>" (show . fst) (Map.lookup bad status)
+            uncurry errorRuleRecursion $ case Map.lookup bad status of
+                Nothing -> (Nothing, Nothing)
+                Just (k,_) -> (Just $ typeKey k, Just $ show k)
 
         vs <- mapM (reduce stack) is
         let errs = [e | Error e <- vs]
@@ -223,8 +234,7 @@
         i #= (k,v) = do
             s <- readIORef status
             writeIORef status $ Map.insert i (k,v) s
-            let shw = head . words . show
-            logger $ maybe "Missing" (shw . snd) (Map.lookup i s) ++ " -> " ++ shw v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s)
+            logger $ maybe "Missing" (statusType . snd) (Map.lookup i s) ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s)
             return v
 
         atom x = let s = show x in if ' ' `elem` s then "(" ++ s ++ ")" else s
@@ -238,10 +248,10 @@
         reduce stack i = do
             s <- readIORef status
             case Map.lookup i s of
-                Nothing -> error $ "Shake internal error: interned value " ++ show i ++ " is missing from the database"
+                Nothing -> err $ "interned value missing from database, " ++ show i
                 Just (k, Missing) -> run stack i k Nothing
                 Just (k, Loaded r) -> do
-                    b <- valid k $ result r
+                    b <- if assume == Just AssumeDirty then return False else fmap (== Just (result r)) $ stored k
                     logger $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (result r)
                     if not b then run stack i k $ Just r else check stack i k r (depends r)
                 Just (k, res) -> return res
@@ -250,16 +260,24 @@
         run stack i k r = do
             w <- newWaiting r
             addPool pool $ do
-                res <- exec (addStack i stack) k
+                let norm = do
+                        res <- execute (addStack i k stack) k
+                        return $ case res of
+                            Left err -> Error err
+                            Right (v,deps,execution,traces) ->
+                                let c | Just r <- r, result r == v = changed r
+                                      | otherwise = step
+                                in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..}
+                res <- case r of
+                    Just r | assume == Just AssumeClean -> do
+                        v <- stored k
+                        case v of
+                            Just v -> return $ Ready r{result=v}
+                            Nothing -> norm
+                    _ -> norm
+
                 ans <- withLock lock $ do
-                    ans <- i #= (k, case res of
-                        Left err -> Error err
-                        Right (v,deps,execution,traces) ->
-                            case assume of
-                                Just AssumeClean | Just r <- r -> Ready r{result=v}
-                                _ -> let c | Just r <- r, result r == v = changed r
-                                           | otherwise = step
-                                     in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..})
+                    ans <- i #= (k, res)
                     runWaiting w
                     return ans
                 case ans of
@@ -276,7 +294,7 @@
         check stack i k r [] =
             i #= (k, Ready r)
         check stack i k r (ds:rest) = do
-            vs <- mapM (reduce (addStack i stack)) ds
+            vs <- mapM (reduce (addStack i k stack)) ds
             let ws = filter (isWaiting . snd) $ zip ds vs
             if any isError vs || any (> built r) [changed | Ready Result{..} <- vs] then
                 run stack i k $ Just r
@@ -311,8 +329,7 @@
 progress :: Database -> IO Progress
 progress Database{..} = do
     s <- readIORef status
-    let zero = Progress False 0 0 0 0 0 0 0 (0,0)
-    return $ foldl' f zero $ map snd $ Map.elems s
+    return $ foldl' f mempty $ map snd $ Map.elems s
     where
         f s (Ready Result{..}) = if step == built
             then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + execution}
@@ -385,18 +402,18 @@
                      ,"execution:" ++ show execution] ++
                      ["traces:[" ++ intercalate "," (map showTrace traces) ++ "]" | traces /= []]
                 showStep i = show $ fromJust $ Map.lookup i steps
-                showTrace (a,b,c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show a ++ "}"
+                showTrace (a,b,c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show (unpack a) ++ "}"
             in  ["{" ++ intercalate ", " xs ++ "}"]
     return $ "[" ++ intercalate "\n," (concat [maybe (error "Internal error in showJSON") f $ Map.lookup i status | i <- order]) ++ "\n]"
 
 
-checkValid :: Database -> (Key -> Value -> IO Bool) -> IO ()
-checkValid Database{..} valid = do
+checkValid :: Database -> (Key -> IO (Maybe Value)) -> IO ()
+checkValid Database{..} stored = do
     status <- readIORef status
     logger "Starting validity/lint checking"
     bad <- fmap concat $ forM (Map.toList status) $ \(i,v) -> case v of
         (key, Ready Result{..}) -> do
-            good <- valid key result
+            good <- fmap (== Just result) $ stored key
             logger $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if good then "passed" else "FAILED"
             return [show key ++ " is no longer " ++ show result | not good && not (special key)]
         _ -> return []
@@ -427,12 +444,12 @@
 fromStepResult = fromValue . result
 
 
-withDatabase :: (String -> IO ()) -> FilePath -> Int -> Maybe Double -> (Database -> IO a) -> IO a
-withDatabase logger filename version flush act = do
+withDatabase :: ShakeOptions -> (String -> IO ()) -> (Database -> IO a) -> IO a
+withDatabase opts logger act = do
     registerWitness $ StepKey ()
     registerWitness $ Step 0
     witness <- currentWitness
-    withStorage logger filename version flush witness $ \mp2 journal -> do
+    withStorage opts logger witness $ \mp2 journal -> do
         let mp1 = Intern.fromList [(k, i) | (i, (k,_)) <- Map.toList mp2]
 
         (mp1, stepId) <- case Intern.lookup stepKey mp1 of
@@ -448,7 +465,7 @@
                         _ -> Step 1
         journal stepId (stepKey, Loaded $ toStepResult step)
         lock <- newLock
-        act Database{..}
+        act Database{assume=shakeAssume opts,..}
 
 
 instance BinaryWith Witness Step where
@@ -462,5 +479,5 @@
 instance BinaryWith Witness Status where
     putWith ctx Missing = putWord8 0
     putWith ctx (Loaded x) = putWord8 1 >> putWith ctx x
-    putWith ctx x = error $ "putWith: Cannot write Status with constructor " ++ head (words $ show x)
+    putWith ctx x = err $ "putWith, Cannot write Status with constructor " ++ statusType x
     getWith ctx = do i <- getWord8; if i == 0 then return Missing else fmap Loaded $ getWith ctx
diff --git a/Development/Shake/Derived.hs b/Development/Shake/Derived.hs
--- a/Development/Shake/Derived.hs
+++ b/Development/Shake/Derived.hs
@@ -1,5 +1,10 @@
 
-module Development.Shake.Derived where
+module Development.Shake.Derived(
+    system', systemCwd, systemOutput,
+    copyFile',
+    readFile', readFileLines,
+    writeFile', writeFileLines, writeFileChanged
+    ) where
 
 import Control.Monad
 import Control.Monad.IO.Class
@@ -13,6 +18,10 @@
 import Development.Shake.FilePath
 
 
+checkExitCode :: String -> ExitCode -> Action ()
+checkExitCode cmd ExitSuccess = return ()
+checkExitCode cmd (ExitFailure i) = error $ "System command failed (code " ++ show i ++ "):\n" ++ cmd
+
 -- | Execute a system command. This function will raise an error if the exit code is non-zero.
 --   Before running 'system'' make sure you 'need' any required files.
 system' :: FilePath -> [String] -> Action ()
@@ -21,8 +30,7 @@
     let cmd = unwords $ path2 : args
     putLoud cmd
     res <- traced (takeBaseName path) $ rawSystem path2 args
-    when (res /= ExitSuccess) $
-        error $ "System command failed:\n" ++ cmd
+    checkExitCode cmd res
 
 
 -- | Execute a system command with a specified current working directory (first argument).
@@ -40,8 +48,7 @@
         --        That installs/removes signal handlers.
         hdl <- runProcess path2 args (Just cwd) Nothing Nothing Nothing Nothing
         waitForProcess hdl
-    when (res /= ExitSuccess) $
-        error $ "System command failed:\n" ++ cmd
+    checkExitCode cmd res
 
 
 -- | Execute a system command, returning @(stdout,stderr)@.
@@ -53,8 +60,7 @@
     let cmd = unwords $ path2 : args
     putLoud cmd
     (res,stdout,stderr) <- traced (takeBaseName path) $ readProcessWithExitCode path2 args ""
-    when (res /= ExitSuccess) $
-        error $ "System command failed:\n" ++ cmd ++ "\n" ++ stderr
+    checkExitCode cmd res
     return (stdout, stderr)
 
 
diff --git a/Development/Shake/Directory.hs b/Development/Shake/Directory.hs
--- a/Development/Shake/Directory.hs
+++ b/Development/Shake/Directory.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}
 
 module Development.Shake.Directory(
-    doesFileExist,
+    doesFileExist, doesDirectoryExist,
     getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
     defaultRuleDirectory
     ) where
@@ -31,9 +31,22 @@
     show (DoesFileExistA a) = show a
 
 
+newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath
+    deriving (Typeable,Eq,Hashable,Binary,NFData)
+
+instance Show DoesDirectoryExistQ where
+    show (DoesDirectoryExistQ a) = "Exists dir? " ++ a
+
+newtype DoesDirectoryExistA = DoesDirectoryExistA Bool
+    deriving (Typeable,Eq,Hashable,Binary,NFData)
+
+instance Show DoesDirectoryExistA where
+    show (DoesDirectoryExistA a) = show a
+
+
 data GetDirectoryQ
     = GetDir {dir :: FilePath}
-    | GetDirFiles {dir :: FilePath, pat :: FilePattern}
+    | GetDirFiles {dir :: FilePath, pat :: [FilePattern]}
     | GetDirDirs {dir :: FilePath}
     deriving (Typeable,Eq)
 newtype GetDirectoryA = GetDirectoryA [FilePath]
@@ -41,7 +54,8 @@
 
 instance Show GetDirectoryQ where
     show (GetDir x) = "Listing " ++ x
-    show (GetDirFiles a b) = "Files " ++ a </> b
+    show (GetDirFiles a b) = "Files " ++ a </> ['{'|m] ++ unwords b ++ ['}'|m]
+        where m = length b > 1
     show (GetDirDirs x) = "Dirs " ++ x
 
 instance NFData GetDirectoryQ where
@@ -51,9 +65,9 @@
 
 instance Hashable GetDirectoryQ where
     hashWithSalt salt = hashWithSalt salt . f
-        where f (GetDir x) = (0 :: Int, x, "")
+        where f (GetDir x) = (0 :: Int, x, [])
               f (GetDirFiles x y) = (1, x, y)
-              f (GetDirDirs x) = (2, x, "")
+              f (GetDirDirs x) = (2, x, [])
 
 instance Binary GetDirectoryQ where
     get = do
@@ -72,6 +86,10 @@
     storedValue (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x
     -- invariant _ = True
 
+instance Rule DoesDirectoryExistQ DoesDirectoryExistA where
+    storedValue (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x
+    -- invariant _ = True
+
 instance Rule GetDirectoryQ GetDirectoryA where
     storedValue x = fmap Just $ getDir x
     -- invariant _ = True
@@ -82,6 +100,8 @@
 defaultRuleDirectory = do
     defaultRule $ \(DoesFileExistQ x) -> Just $
         liftIO $ fmap DoesFileExistA $ IO.doesFileExist x
+    defaultRule $ \(DoesDirectoryExistQ x) -> Just $
+        liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x
     defaultRule $ \(x :: GetDirectoryQ) -> Just $
         liftIO $ getDir x
 
@@ -92,6 +112,12 @@
     DoesFileExistA res <- apply1 $ DoesFileExistQ file
     return res
 
+-- | Returns 'True' if the directory exists.
+doesDirectoryExist :: FilePath -> Action Bool
+doesDirectoryExist file = do
+    DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ file
+    return res
+
 -- | Get the contents of a directory. The result will be sorted, and will not contain
 --   the files @.@ or @..@ (unlike the standard Haskell version). It is usually better to
 --   call either 'getDirectoryFiles' or 'getDirectoryDirs'. The resulting paths will be relative
@@ -99,9 +125,9 @@
 getDirectoryContents :: FilePath -> Action [FilePath]
 getDirectoryContents x = getDirAction $ GetDir x
 
--- | Get the files in a directory that match a particular pattern.
+-- | Get the files in a directory that match any of a set of patterns.
 --   For the interpretation of the pattern see '?=='.
-getDirectoryFiles :: FilePath -> FilePattern -> Action [FilePath]
+getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]
 getDirectoryFiles x f = getDirAction $ GetDirFiles x f
 
 -- | Get the directories contained by a directory, does not include @.@ or @..@.
@@ -110,13 +136,17 @@
 
 getDirAction x = do GetDirectoryA y <- apply1 x; return y
 
+contents :: FilePath -> IO [FilePath]
+contents = fmap (filter $ not . all (== '.')) . IO.getDirectoryContents
 
+answer :: [FilePath] -> GetDirectoryA
+answer = GetDirectoryA . sort
+
 getDir :: GetDirectoryQ -> IO GetDirectoryA
-getDir x = fmap (GetDirectoryA . sort) $ f x . filter validName =<< IO.getDirectoryContents (dir x)
-    where
-        validName = not . all (== '.')
+getDir GetDir{..} = fmap answer $ contents dir
 
-        f GetDir{} xs = return xs
-        f GetDirFiles{} xs = flip filterM xs $ \s ->
-            if not $ pat x ?== s then return False else IO.doesFileExist $ dir x </> s
-        f GetDirDirs{} xs = flip filterM xs $ \s -> IO.doesDirectoryExist $ dir x </> s
+getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir
+    where f x = IO.doesDirectoryExist $ dir </> x
+
+getDir GetDirFiles{..} = fmap answer $ filterM f =<< contents dir
+    where f x = if not $ any (?== x) pat then return False else IO.doesFileExist $ dir </> x
diff --git a/Development/Shake/Errors.hs b/Development/Shake/Errors.hs
new file mode 100644
--- /dev/null
+++ b/Development/Shake/Errors.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
+
+-- | Errors seen by the user
+module Development.Shake.Errors(
+    ShakeException(..),
+    errorNoRuleToBuildType, errorRuleTypeMismatch, errorIncompatibleRules,
+    errorMultipleRulesMatch, errorRuleRecursion,
+    err
+    ) where
+
+import Control.Arrow
+import Control.Exception
+import Data.Typeable
+import Data.List
+
+
+err :: String -> a
+err msg = error $ "Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")"
+
+alternatives = let (*) = (,) in
+    ["_rule_" * "oracle"
+    ,"_Rule_" * "Oracle"
+    ,"_key_" * "question"
+    ,"_Key_" * "Question"
+    ,"_result_" * "answer"
+    ,"_Result_" * "Answer"
+    ,"_rule/defaultRule_" * "addOracle"
+    ,"_apply_" * "askOracle"]
+
+structured :: Bool -> String -> [(String, Maybe String)] -> String -> a
+structured alt msg args hint = structured_ (f msg) (map (first f) args) (f hint)
+    where
+        f = filter (/= '_') . (if alt then g else id)
+        g xs | (a,b):_ <- filter (\(a,b) -> a `isPrefixOf` xs) alternatives = b ++ g (drop (length a) xs)
+        g (x:xs) = x : g xs
+        g [] = []
+
+structured_ :: String -> [(String, Maybe String)] -> String -> a
+structured_ msg args hint = error $
+        msg ++ ":\n" ++ unlines ["  " ++ a ++ ":" ++ replicate (as - length a + 2) ' ' ++ drp b | (a,b) <- args2] ++ hint
+    where
+        drp x | "OracleA " `isPrefixOf` x = drop 8 x
+              | "OracleQ " `isPrefixOf` x = drop 8 x
+              | otherwise = x
+        as = maximum $ 0 : map (length . fst) args2
+        args2 = [(a,b) | (a,Just b) <- args]
+
+
+errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> a
+errorNoRuleToBuildType tk k tv = structured (isOracle tk)
+    "Build system error - no _rule_ matches the _key_ type"
+    [("_Key_ type", Just $ show tk)
+    ,("_Key_ value", k)
+    ,("_Result_ type", fmap show tv)]
+    "Either you are missing a call to _rule/defaultRule_, or your call to _apply_ has the wrong _key_ type"
+
+errorRuleTypeMismatch :: TypeRep -> Maybe String -> TypeRep -> TypeRep -> a
+errorRuleTypeMismatch tk k tvReal tvWant = structured (isOracle tk)
+    "Build system error - _rule_ used at the wrong _result_ type"
+    [("_Key_ type", Just $ show tk)
+    ,("_Key_ value", k)
+    ,("_Rule_ _result_ type", Just $ show tvReal)
+    ,("Requested _result_ type", Just $ show tvWant)]
+    "Either the function passed to _rule/defaultRule_ has the wrong _result_ type, or the result of _apply_ is used at the wrong type"
+
+errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> a
+errorIncompatibleRules tk tv1 tv2 = if isOracle tk then errorDuplicateOracle tk Nothing [tv1,tv2] else structured_
+    "Build system error - rule has multiple result types"
+    [("Key type", Just $ show tk)
+    ,("First result type", Just $ show tv1)
+    ,("Second result type", Just $ show tv2)]
+    "A function passed to rule/defaultRule has the wrong result type"
+
+errorMultipleRulesMatch :: TypeRep -> String -> Int -> a
+errorMultipleRulesMatch tk k count
+    | isOracle tk = if count == 0 then err $ "no oracle match for " ++ show tk else errorDuplicateOracle tk (Just k) []
+    | otherwise = structured_
+    ("Build system error - key matches " ++ (if count == 0 then "no" else "multiple") ++ " rules")
+    [("Key type",Just $ show tk)
+    ,("Key value",Just k)
+    ,("Rules matched",Just $ show count)]
+    (if count == 0 then "Either add a rule that produces the above key, or stop requiring the above key"
+     else "Modify your rules/defaultRules so only one can produce the above key")
+
+errorRuleRecursion :: Maybe TypeRep -> Maybe String -> a
+errorRuleRecursion tk k = structured_ -- may involve both rules and oracle, so report as a rule
+    "Build system error - recursion detected"
+    [("Key type",fmap show tk)
+    ,("Key value",k)]
+    "Rules may not be recursive"
+
+errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> a
+errorDuplicateOracle tk k tvs = structured_
+    "Build system error - duplicate oracles for the same question type"
+    ([("Question type",Just $ show tk)
+     ,("Question value",k)] ++
+     [("Answer type " ++ show i, Just $ show tv) | (i,tv) <- zip [1..] tvs])
+    "Only one call to addOracle is allowed per question type"
+
+
+isOracle :: TypeRep -> Bool
+isOracle t = con `elem` ["OracleQ","OracleA"]
+    where con = show $ fst $ splitTyConApp t
+
+
+-- NOTE: Not currently public, to avoid pinning down the API yet
+-- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing
+--   rules, will be raised using this exception type.
+data ShakeException = ShakeException
+        [String] -- Entries on the stack, starting at the top of the stack.
+        SomeException -- Inner exception that was raised.
+        -- If I make these Haddock comments, then Haddock dies
+    deriving Typeable
+
+instance Exception ShakeException
+
+instance Show ShakeException where
+    show (ShakeException stack inner) = unlines $
+        "Error when running Shake build system:" :
+        map ("* " ++) stack ++
+        [show inner]
diff --git a/Development/Shake/File.hs b/Development/Shake/File.hs
--- a/Development/Shake/File.hs
+++ b/Development/Shake/File.hs
@@ -8,9 +8,9 @@
 
 import Control.Monad.IO.Class
 import System.Directory
-import qualified Data.ByteString.Char8 as BS
 
 import Development.Shake.Core
+import Development.Shake.Types
 import Development.Shake.Classes
 import Development.Shake.FilePath
 import Development.Shake.FilePattern
@@ -19,19 +19,16 @@
 infix 1 *>, ?>, **>
 
 
-newtype FileQ = FileQ BS.ByteString
-    deriving (Typeable,Eq,Hashable,Binary)
-
-instance NFData FileQ where
-    rnf (FileQ x) = x `seq` () -- since ByteString is strict
+newtype FileQ = FileQ BS
+    deriving (Typeable,Eq,Hashable,Binary,NFData)
 
-instance Show FileQ where show (FileQ x) = BS.unpack x
+instance Show FileQ where show (FileQ x) = unpack x
 
 newtype FileA = FileA FileTime
     deriving (Typeable,Eq,Hashable,Binary,Show,NFData)
 
 instance Rule FileQ FileA where
-    storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x
+    storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe $ unpack_ x
 
 {-
     observed act = do
@@ -91,7 +88,7 @@
 -- | This function is not actually exported, but Haddock is buggy. Please ignore.
 defaultRuleFile :: Rules ()
 defaultRuleFile = defaultRule $ \(FileQ x) -> Just $
-    liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x
+    liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" $ unpack_ x
 
 
 -- | Require that the following files are built before continuing. Particularly
@@ -104,7 +101,7 @@
 --     'Development.Shake.system'' [\"rot13\",src,\"-o\",out]
 -- @
 need :: [FilePath] -> Action ()
-need xs = (apply $ map (FileQ . BS.pack) xs :: Action [FileA]) >> return ()
+need xs = (apply $ map (FileQ . pack) xs :: Action [FileA]) >> return ()
 
 -- | Require that the following are built by the rules, used to specify the target.
 --
@@ -120,11 +117,11 @@
 
 
 root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()
-root help test act = rule $ \(FileQ x_) -> let x = BS.unpack x_ in
+root help test act = rule $ \(FileQ x_) -> let x = unpack x_ in
     if not $ test x then Nothing else Just $ do
         liftIO $ createDirectoryIfMissing True $ takeDirectory x
         act x
-        liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_
+        liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") $ unpack_ x_
 
 
 
diff --git a/Development/Shake/FilePattern.hs b/Development/Shake/FilePattern.hs
--- a/Development/Shake/FilePattern.hs
+++ b/Development/Shake/FilePattern.hs
@@ -1,12 +1,19 @@
+{-# LANGUAGE PatternGuards #-}
 
 module Development.Shake.FilePattern(
     FilePattern, (?==),
-    compatible, extract, substitute
+    compatible, extract, substitute,
+    directories, directories1
     ) where
 
 import System.FilePath(pathSeparators)
+import Data.List
+import Control.Arrow
 
 
+---------------------------------------------------------------------
+-- BASIC FILE PATTERN MATCHING
+
 -- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax
 --   and semantics of 'FilePattern' see '?=='.
 type FilePattern = String
@@ -15,7 +22,10 @@
 data Lexeme = Star | SlashSlash | Char Char deriving (Show, Eq)
 
 isChar (Char _) = True; isChar _ = False
+isDull (Char x) = x /= '/'; isDull _ = False
+fromChar (Char x) = x
 
+
 data Regex = Lit [Char] | Not [Char] | Any
            | Start | End
            | Bracket Regex
@@ -89,6 +99,46 @@
 (?==) :: FilePattern -> FilePath -> Bool
 (?==) p x = not $ null $ match (pattern $ lexer p) (True, x)
 
+
+---------------------------------------------------------------------
+-- DIRECTORY PATTERNS
+
+-- | Given a pattern, return the directory that requires searching,
+--   with 'True' if it requires a recursive search. Must be conservative.
+--   Examples:
+--
+-- > directories1 "*.xml" == ("",False)
+-- > directories1 "//*.xml" == ("",True)
+-- > directories1 "foo//*.xml" == ("foo",True)
+-- > directories1 "foo/bar/*.xml" == ("foo/bar",False)
+-- > directories1 "*/bar/*.xml" == ("",True)
+directories1 :: FilePattern -> (FilePath, Bool)
+directories1 = first (intercalate "/") . f . lexer
+    where
+        f xs | (a@(_:_),b:bs) <- span isDull xs, b `elem` [Char '/',SlashSlash] =
+                if b == SlashSlash then ([map fromChar a],True) else first (map fromChar a:) $ f bs
+             | all (\x -> isDull x || x == Star) xs = ([],False)
+             | otherwise = ([], True)
+
+
+-- | Given a set of patterns, produce a set of directories that require searching,
+--   with 'True' if it requires a recursive search. Must be conservative. Examples:
+--
+-- > directories ["*.xml","//*.c"] == [("",True)]
+-- > directories ["bar/*.xml","baz//*.c"] == [("bar",False),("baz",True)]
+-- > directories ["bar/*.xml","baz//*.c"] == [("bar",False),("baz",True)]
+directories :: [FilePattern] -> [(FilePath,Bool)]
+directories ps = foldl f xs xs
+    where
+        xs = nub $ map directories1 ps 
+
+        -- Eliminate anything which is a strict subset
+        f xs (x,True) = filter (\y -> not $ (x,False) == y || (x ++ "/") `isPrefixOf` fst y) xs
+        f xs _ = xs
+
+
+---------------------------------------------------------------------
+-- MULTIPATTERN COMPATIBLE SUBSTITUTIONS
 
 -- | Do they have the same * and // counts in the same order
 compatible :: [FilePattern] -> Bool
diff --git a/Development/Shake/FileTime.hs b/Development/Shake/FileTime.hs
--- a/Development/Shake/FileTime.hs
+++ b/Development/Shake/FileTime.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}
-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
 
 module Development.Shake.FileTime(
     FileTime,
diff --git a/Development/Shake/Files.hs b/Development/Shake/Files.hs
--- a/Development/Shake/Files.hs
+++ b/Development/Shake/Files.hs
@@ -7,9 +7,9 @@
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Maybe
-import qualified Data.ByteString.Char8 as BS
 
 import Development.Shake.Core
+import Development.Shake.Types
 import Development.Shake.Classes
 import Development.Shake.File
 import Development.Shake.FilePattern
@@ -18,22 +18,17 @@
 infix 1 ?>>, *>>
 
 
-newtype FilesQ = FilesQ [BS.ByteString]
-    deriving (Typeable,Eq,Hashable,Binary)
-
-instance NFData FilesQ where
-    -- some versions of ByteString do not have NFData instances, but seq is equivalent
-    -- for a strict bytestring. Therefore, we write our own instance.
-    rnf (FilesQ xs) = rnf $ map (`seq` ()) xs
+newtype FilesQ = FilesQ [BS]
+    deriving (Typeable,Eq,Hashable,Binary,NFData)
 
 newtype FilesA = FilesA [FileTime]
     deriving (Typeable,Show,Eq,Hashable,Binary,NFData)
 
-instance Show FilesQ where show (FilesQ xs) = unwords $ map BS.unpack xs
+instance Show FilesQ where show (FilesQ xs) = unwords $ map unpack xs
 
 
 instance Rule FilesQ FilesA where
-    storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs
+    storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe $ map unpack_ xs
 
 
 -- | Define a rule for building multiple files at the same time.
@@ -57,9 +52,9 @@
     | otherwise = do
         forM_ ps $ \p ->
             p *> \file -> do
-                _ :: FilesA <- apply1 $ FilesQ $ map (BS.pack . substitute (extract p file)) ps
+                _ :: FilesA <- apply1 $ FilesQ $ map (pack . substitute (extract p file)) ps
                 return ()
-        rule $ \(FilesQ xs_) -> let xs = map BS.unpack xs_ in
+        rule $ \(FilesQ xs_) -> let xs = map unpack xs_ in
             if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do
                 act xs
                 liftIO $ getFileTimes "*>>" xs_
@@ -93,10 +88,10 @@
                     | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x
 
     isJust . checkedTest ?> \x -> do
-        _ :: FilesA <- apply1 $ FilesQ $ map BS.pack $ fromJust $ test x
+        _ :: FilesA <- apply1 $ FilesQ $ map pack $ fromJust $ test x
         return ()
 
-    rule $ \(FilesQ xs_) -> let xs@(x:_) = map BS.unpack xs_ in
+    rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpack xs_ in
         case checkedTest x of
             Just ys | ys == xs -> Just $ do
                 act xs
@@ -105,13 +100,13 @@
             Nothing -> Nothing
 
 
-getFileTimes :: String -> [BS.ByteString] -> IO FilesA
+getFileTimes :: String -> [BS] -> IO FilesA
 getFileTimes name xs = do
-    ys <- mapM getModTimeMaybe xs
+    ys <- mapM (getModTimeMaybe . unpack_) xs
     case sequence ys of
         Just ys -> return $ FilesA ys
         Nothing -> do
             let missing = length $ filter isNothing ys
             error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++
                     " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
-                    concat ["\n  " ++ BS.unpack x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
+                    concat ["\n  " ++ unpack x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
diff --git a/Development/Shake/Oracle.hs b/Development/Shake/Oracle.hs
--- a/Development/Shake/Oracle.hs
+++ b/Development/Shake/Oracle.hs
@@ -61,17 +61,17 @@
 --newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
 --
 --do
---    getPkgList <- 'addOracle' $ \\GhcPkgList{} -> do
---        (out,_) <- 'systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"]
+--    getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do
+--        (out,_) <- 'Development.Shake.systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"]
 --        return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]
 --    --
---    getPkgVersion <- 'addOracle' $ \\(GhcPkgVersion pkg) -> do
+--    getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do
 --        pkgs <- getPkgList
 --        return $ lookup pkg pkgs
 -- @
 --
 --   Using these definitions, any rule depending on the version of @shake@
---   should call @getPkgVersion "shake"@ to rebuild when @shake@ is upgraded.
+--   should call @getPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.
 addOracle :: (
 #if __GLASGOW_HASKELL__ >= 704
     ShakeValue q, ShakeValue a
diff --git a/Development/Shake/Progress.hs b/Development/Shake/Progress.hs
new file mode 100644
--- /dev/null
+++ b/Development/Shake/Progress.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ForeignFunctionInterface #-}
+
+-- | Progress tracking
+module Development.Shake.Progress(
+    Progress(..),
+    progressSimple, progressDisplay, progressTitlebar,
+    ) where
+
+import Control.Concurrent
+import Data.Data
+import Data.Monoid
+import qualified Data.ByteString.Char8 as BS
+
+#ifdef mingw32_HOST_OS
+
+import Foreign
+import Foreign.C.Types
+
+type LPCSTR = Ptr CChar
+
+foreign import stdcall "Windows.h SetConsoleTitleA" c_setConsoleTitle :: LPCSTR -> IO Bool
+
+#endif
+
+
+-- | Information about the current state of the build, obtained by passing a callback function
+--   to 'Development.Shake.shakeProgress'. Typically a program will use 'progressDisplay' to poll this value and produce
+--   status messages, which is implemented using this data type.
+data Progress = Progress
+    {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.
+    ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.
+    ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.
+    ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.
+    ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.
+    ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.
+    ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.
+    ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.
+    ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).
+    }
+    deriving (Eq,Ord,Show,Data,Typeable)
+
+instance Monoid Progress where
+    mempty = Progress True 0 0 0 0 0 0 0 (0,0)
+    mappend a b = Progress
+        {isRunning = isRunning a && isRunning b
+        ,countSkipped = countSkipped a + countSkipped b
+        ,countBuilt = countBuilt a + countBuilt b
+        ,countUnknown = countUnknown a + countUnknown b
+        ,countTodo = countTodo a + countTodo b
+        ,timeSkipped = timeSkipped a + timeSkipped b
+        ,timeBuilt = timeBuilt a + timeBuilt b
+        ,timeUnknown = timeUnknown a + timeUnknown b
+        ,timeTodo = let (a1,a2) = timeTodo a; (b1,b2) = timeTodo b
+                        x1 = a1 + b1; x2 = a2 + b2
+                    in x1 `seq` x2 `seq` (x1,x2)
+        }
+
+-- Including timeSkipped gives a more truthful percent, but it drops more sharply
+-- which isn't what users probably want
+progressDone :: Progress -> Double
+progressDone Progress{..} = timeBuilt
+
+
+-- | Make a guess at the number of seconds to go, ignoring multiple threads
+progressTodo :: Progress -> Double
+progressTodo Progress{..} =
+        fst timeTodo + (if avgSamples == 0 || snd timeTodo == 0 then 0 else fromIntegral (snd timeTodo) * avgTime)
+    where
+        avgTime = (timeBuilt + fst timeTodo) / fromIntegral avgSamples
+        avgSamples = countBuilt + countTodo - snd timeTodo
+
+
+-- | Given a sampling interval (in seconds) and a way to display the status message,
+--   produce a function suitable for using as 'Development.Shake.shakeProgress'.
+--   This function polls the progress information every /n/ seconds, produces a status
+--   message and displays it using the display function.
+--
+--   Typical status messages will take the form of @1:25m (15%)@, indicating that the build
+--   is predicted to complete in 1min 25sec, and 15% of the necessary build time has elapsed.
+--   This function uses past observations to predict future behaviour, and as such, is only
+--   guessing. The time is likely to go up as well as down, and will be less accurate from a
+--   clean build (as the system has fewer past observations).
+--
+--   The current implementation is to predict the time remaining (based on 'timeTodo') and the
+--   work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,
+--   while time left is calculated by scaling @remaining@ by the observed work rate in this build,
+--   namely @done / time_elapsed@.
+progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
+progressDisplay sample disp prog = loop 0
+    where
+        loop steps = do
+            p <- prog
+            if not $ isRunning p then
+                disp "Finished"
+             else do
+                disp $ if steps == 0
+                    then "Starting..."
+                    else let done = progressDone p
+                             todo = progressTodo p
+                             comp = if done == 0 then todo else sample * todo / (done / fromIntegral steps)
+                             (mins,secs) = divMod (ceiling comp) (60 :: Int)
+                             time = show mins ++ ":" ++ ['0' | secs < 10] ++ show secs
+                             perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int)
+                         in time ++ "m (" ++ perc ++ "%)" ++ "\a"
+                threadDelay $ ceiling $ sample * 1000000
+                loop $! steps+1
+
+
+-- | Set the title of the current console window to the given text. On Windows
+--   this function uses the @SetConsoleTitle@ API, elsewhere it uses an xterm
+--   escape sequence. This function may not work for all terminals.
+progressTitlebar :: String -> IO ()
+progressTitlebar x =
+#ifdef mingw32_HOST_OS
+    BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()
+#else
+    BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"
+#endif
+
+
+-- | A simple method for displaying progress messages, suitable for using as
+--   'Development.Shake.shakeProgress'. This function writes the current progress to
+--   the titlebar every five seconds. The function is defined as:
+--
+-- @
+--progressSimple = 'progressDisplay' 5 'progressTitlebar'
+-- @
+progressSimple :: IO Progress -> IO ()
+progressSimple = progressDisplay 5 progressTitlebar
diff --git a/Development/Shake/Storage.hs b/Development/Shake/Storage.hs
--- a/Development/Shake/Storage.hs
+++ b/Development/Shake/Storage.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, PatternGuards, FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables, PatternGuards, NamedFieldPuns, FlexibleInstances, MultiParamTypeClasses #-}
 {-
 This module stores the meta-data so its very important its always accurate
 We can't rely on getting any exceptions or termination at the end, so we'd better write out a journal
@@ -11,6 +11,7 @@
 
 import Development.Shake.Binary
 import Development.Shake.Locks
+import Development.Shake.Types
 
 import Control.Arrow
 import Control.Exception as E
@@ -34,23 +35,21 @@
 
 -- Increment every time the on-disk format/semantics change,
 -- @i@ is for the users version number
-databaseVersion i = "SHAKE-DATABASE-6-" ++ show (i :: Int) ++ "\r\n"
+databaseVersion i = "SHAKE-DATABASE-8-" ++ show (i :: Int) ++ "\r\n"
 
 
 withStorage
     :: (Eq w, Eq k, Hashable k
        ,Binary w, BinaryWith w k, BinaryWith w v)
-    => (String -> IO ())        -- ^ Logging function
-    -> FilePath                 -- ^ File prefix to use
-    -> Int                      -- ^ User supplied version number
-    -> Maybe Double             -- ^ How often to flush (Nothing = never, Just = seconds)
+    => ShakeOptions             -- ^ Storage options
+    -> (String -> IO ())        -- ^ Logging function
     -> w                        -- ^ Witness
     -> (Map k v -> (k -> v -> IO ()) -> IO a)  -- ^ Execute
     -> IO a
-withStorage logger file version flush witness act = do
-    let dbfile = file <.> "database"
-        bupfile = file <.> "bup"
-    createDirectoryIfMissing True $ takeDirectory file
+withStorage ShakeOptions{shakeVerbosity,shakeVersion,shakeFlush,shakeFiles} logger witness act = do
+    let dbfile = shakeFiles <.> "database"
+        bupfile = shakeFiles <.> "bup"
+    createDirectoryIfMissing True $ takeDirectory shakeFiles
 
     -- complete a partially failed compress
     b <- doesFileExist bupfile
@@ -68,18 +67,18 @@
             unless (LBS.null src) $ do
                 let good x = isAlphaNum x || x `elem` "-_ "
                 let bad = LBS.takeWhile good $ LBS.take 50 src
-                putStr $ unlines
+                outputErr $ unlines
                     ["Error when reading Shake database " ++ dbfile
                     ,"  Invalid version stamp detected"
                     ,"  Expected: " ++ takeWhile good (LBS.unpack ver)
                     ,"  Found   : " ++ LBS.unpack bad
-                    ,"All files will be rebuilt"]
+                    ,"All rules will be rebuilt"]
             continue h Map.empty
          else
             -- make sure you are not handling exceptions from inside
             join $ handleJust (\e -> if asyncException e then Nothing else Just e) (\err -> do
                 msg <- showException err
-                putStrLn $ unlines $
+                outputErr $ unlines $
                     ("Error when reading Shake database " ++ dbfile) :
                     map ("  "++) (lines msg) ++
                     ["All files will be rebuilt"]
@@ -118,7 +117,8 @@
                                     logger "Compression complete"
                                     continue h mp
     where
-        ver = LBS.pack $ databaseVersion version
+        outputErr = when (shakeVerbosity >= Quiet) . putStr
+        ver = LBS.pack $ databaseVersion shakeVersion
 
         writeChunk h s = do
             logger $ "Writing chunk " ++ show (LBS.length s)
@@ -139,14 +139,14 @@
             when (Map.null mp) $
                 reset h mp -- might as well, no data to lose, and need to ensure a good witness table
             lock <- newLock
-            flushThread flush h $ \out ->
+            flushThread outputErr shakeFlush h $ \out ->
                 act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v)
 
 
 -- We avoid calling flush too often on SSD drives, as that can be slow
 -- Do not move writes to a separate thread, as then we'd have to marshal exceptions back which is tricky
-flushThread :: Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a
-flushThread flush h act = do
+flushThread :: (String -> IO ()) -> Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a
+flushThread outputErr flush h act = do
     alive <- newVar True
     kick <- newEmptyMVar
 
@@ -165,7 +165,7 @@
                     when b loop
             forkIO $ do
                 let msg = "Warning: Flushing Shake journal failed, on abnormal termination you may lose some data, "
-                (loop >> return ()) `E.catch` \(e :: SomeException) -> putStrLn $ msg ++ show e
+                (loop >> return ()) `E.catch` \(e :: SomeException) -> outputErr $ msg ++ show e ++ "\n"
             return ()
 
     lock <- newLock
diff --git a/Development/Shake/Types.hs b/Development/Shake/Types.hs
--- a/Development/Shake/Types.hs
+++ b/Development/Shake/Types.hs
@@ -1,48 +1,17 @@
-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, PatternGuards #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, PatternGuards #-}
 
 -- | Types exposed to the user
 module Development.Shake.Types(
     Progress(..), Verbosity(..), Assume(..),
     ShakeOptions(..), shakeOptions,
-    ShakeException(..)
+    BS, pack, unpack, pack_, unpack_
     ) where
 
-import Control.Exception
 import Data.Data
 import Data.List
-
-
--- | Information about the current state of the build, obtained by passing a callback function
---   to 'shakeProgress'. Typically a program will poll this value to provide progress messages.
---   The following example displays the approximate single-threaded time remaining
---   as the console title.
---
--- @
---showProgress :: IO 'Progress' -> IO ()
---showProgress progress = void $ forkIO loop
---    where loop = do
---        current <- progress
---        when ('isRunning' current) $ do
---            let (s,c) = timeTodo current
---            setTitle $ \"Todo = \" ++ show (ceiling s) ++ \"s (+ \" ++ show c ++ \" unknown)\"
---            threadDelay $ 5 * 1000000
---            loop
---
---setTitle :: String -> IO ()
---setTitle s = putStr $ \"\\ESC]0;\" ++ s ++ \"\\BEL\"
--- @
-data Progress = Progress
-    {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.
-    ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.
-    ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.
-    ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.
-    ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.
-    ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.
-    ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.
-    ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.
-    ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).
-    }
-    deriving (Eq,Ord,Show,Data,Typeable)
+import Development.Shake.Progress
+import Development.Shake.Classes
+import qualified Data.ByteString.Char8 as BS
 
 
 -- | The current assumptions made by the build system, used by 'shakeAssume'. These options
@@ -108,27 +77,31 @@
     ,shakeAssume :: Maybe Assume
         -- ^ Defaults to 'Nothing'. Assume all build objects are clean/dirty, see 'Assume' for details.
         --   Can be used to implement @make --touch@.
+    ,shakeAbbreviations :: [(String,String)]
+        -- ^ Defaults to @[]@. A list of substrings that should be abbreviated in status messages, and their corresponding abbreviation.
+        --   Commonly used to replace the long paths (e.g. @.make/i586-linux-gcc/output@) with an abbreviation (e.g. @$OUT@).
     ,shakeProgress :: IO Progress -> IO ()
-        -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported,
-        --   see 'Progress' for details.
+        -- ^ Defaults to no action. A function called on a separate thread when the build starts, allowing progress to be reported.
+        --   For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced
+        --   users should look at the 'Progress' data type.
     }
     deriving Typeable
 
 -- | The default set of 'ShakeOptions'.
 shakeOptions :: ShakeOptions
-shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False (Just 10) Nothing (const $ return ())
+shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False (Just 10) Nothing [] (const $ return ())
 
 fieldsShakeOptions =
     ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"
-    ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeProgress"]
+    ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeProgress"]
 tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions]
 conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix
-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 (fromProgress x11)
+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 (fromProgress x12)
 
 instance Data ShakeOptions where
-    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) =
-        z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` ShakeProgress x11
-    gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide
+    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) =
+        z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` ShakeProgress x12
+    gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide
     toConstr ShakeOptions{} = conShakeOptions
     dataTypeOf _ = tyShakeOptions
 
@@ -144,6 +117,7 @@
                 | Just x <- cast x = show (x :: Maybe FilePath)
                 | Just x <- cast x = show (x :: Maybe Assume)
                 | Just x <- cast x = show (x :: Maybe Double)
+                | Just x <- cast x = show (x :: [(String,String)])
                 | Just x <- cast x = show (x :: ShakeProgress)
                 | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x)
 
@@ -163,25 +137,6 @@
 tyShakeProgress = mkDataType "Development.Shake.Types.ShakeProgress" []
 
 
-
--- NOTE: Not currently public, to avoid pinning down the API yet
--- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing
---   rules, will be raised using this exception type.
-data ShakeException = ShakeException
-        [String] -- Entries on the stack, starting at the top of the stack.
-        SomeException -- Inner exception that was raised.
-        -- If I make these Haddock comments, then Haddock dies
-    deriving Typeable
-
-instance Exception ShakeException
-
-instance Show ShakeException where
-    show (ShakeException stack inner) = unlines $
-        "Error when running Shake build system:" :
-        map ("* " ++) stack ++
-        [show inner]
-
-
 -- | The verbosity data type, used by 'shakeVerbosity'.
 data Verbosity
     = Silent -- ^ Don't print any messages.
@@ -191,3 +146,27 @@
     | Diagnostic -- ^ Print messages for virtually everything (for debugging a build system).
       deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)
 
+
+---------------------------------------------------------------------
+-- BYTESTRING WRAPPER
+-- Only purpose is because ByteString does not have an NFData instance in older GHC
+
+newtype BS = BS BS.ByteString
+    deriving (Hashable, Binary, Eq)
+
+instance NFData BS where
+    -- some versions of ByteString do not have NFData instances, but seq is equivalent
+    -- for a strict bytestring. Therefore, we write our own instance.
+    rnf (BS x) = x `seq` ()
+
+pack :: String -> BS
+pack = pack_ . BS.pack
+
+unpack :: BS -> String
+unpack = BS.unpack . unpack_
+
+pack_ :: BS.ByteString -> BS
+pack_ = BS
+
+unpack_ :: BS -> BS.ByteString
+unpack_ (BS x) = x
diff --git a/Development/Shake/Value.hs b/Development/Shake/Value.hs
--- a/Development/Shake/Value.hs
+++ b/Development/Shake/Value.hs
@@ -11,6 +11,7 @@
 
 import Development.Shake.Binary
 import Development.Shake.Classes
+import Development.Shake.Errors
 import Data.Typeable
 
 import Data.Bits
@@ -46,8 +47,7 @@
 fromKey (Key v) = fromValue v
 
 fromValue :: Typeable a => Value -> a
-fromValue (Value x) = fromMaybe (error msg) $ cast x
-    where msg = "Internal error in Shake.fromValue, bad cast"
+fromValue (Value x) = fromMaybe (err "fromValue, bad cast") $ cast x
 
 instance Show Key where
     show (Key a) = show a
@@ -75,8 +75,8 @@
 witness = unsafePerformIO $ newIORef Map.empty
 
 registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> IO ()
-registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ error msg `asTypeOf` x) mp, ())
-    where msg = "Development.Shake.Value.registerWitness, witness of type " ++ show (typeOf x) ++ " demanded"
+registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ err msg `asTypeOf` x) mp, ())
+    where msg = "registerWitness, type " ++ show (typeOf x)
 
 
 -- Produce a list in a predictable order from a Map TypeRep, which should be consistent regardless of the order
@@ -119,9 +119,8 @@
 
 
 instance BinaryWith Witness Value where
-    -- FIXME: Should probably be writing out bytes, rather than 64 bit Int's
     putWith ws (Value x) = do
-        let msg = "Internal error, could not find witness type for " ++ show (typeOf x)
+        let msg = "no witness for " ++ show (typeOf x)
         put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws)
         put x
 
diff --git a/Examples/C/Main.hs b/Examples/C/Main.hs
--- a/Examples/C/Main.hs
+++ b/Examples/C/Main.hs
@@ -10,7 +10,7 @@
     want [obj "Main.exe"]
 
     obj "Main.exe" *> \out -> do
-        cs <- getDirectoryFiles src "*.c"
+        cs <- getDirectoryFiles src ["*.c"]
         let os = map (obj . (<.> "o")) cs
         need os
         system' "gcc" $ ["-o",out] ++ os
diff --git a/Examples/Self/Main.hs b/Examples/Self/Main.hs
--- a/Examples/Self/Main.hs
+++ b/Examples/Self/Main.hs
@@ -16,7 +16,7 @@
 newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
 newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
 
-main :: IO ()
+
 main = shaken noTest $ \args obj -> do
     let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext
     want $ if null args then [obj "Main.exe"] else args
@@ -25,7 +25,7 @@
     let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x
 
     ghcPkg <- addOracle $ \GhcPkg{} -> do
-        (out,_) <- systemOutput "ghc-pkg" ["list","--simple-output"]
+        (out,_) <- quietly $ systemOutput "ghc-pkg" ["list","--simple-output"]
         return $ words out
 
     ghcFlags <- addOracle $ \GhcFlags{} -> do
diff --git a/Examples/Tar/Main.hs b/Examples/Tar/Main.hs
--- a/Examples/Tar/Main.hs
+++ b/Examples/Tar/Main.hs
@@ -5,7 +5,6 @@
 import Examples.Util
 
 
-main :: IO ()
 main = shaken noTest $ \args obj -> do
     want [obj "result.tar"]
     obj "result.tar" *> \out -> do
diff --git a/Examples/Test/Assume.hs b/Examples/Test/Assume.hs
--- a/Examples/Test/Assume.hs
+++ b/Examples/Test/Assume.hs
@@ -23,25 +23,21 @@
     ask "abc" "abc"
 
     set 'b' 'd'
-    sleepFileTime
-    build ["abc.out"]
+    build ["--sleep","abc.out"]
     ask "abc" "adc"
     set 'b' 'p'
-    sleepFileTime
-    build ["abc.out","--assume-clean"]
+    build ["--sleep","abc.out","--assume-clean"]
     build ["abc.out"]
     ask "abc" "adc"
     set 'c' 'z'
-    sleepFileTime
-    build ["abc.out"]
+    build ["--sleep","abc.out"]
     ask "abc" "apz"
 
     build ["bc.out","c.out"]
     ask "bc" "pz"
     set 'b' 'r'
     set 'c' 'n'
-    sleepFileTime
-    build ["abc.out","--assume-clean"]
+    build ["--sleep","abc.out","--assume-clean"]
     ask "abc" "apz"
     build ["ab.out","--assume-dirty"]
     ask "ab" "ar"
diff --git a/Examples/Test/Basic.hs b/Examples/Test/Basic.hs
--- a/Examples/Test/Basic.hs
+++ b/Examples/Test/Basic.hs
@@ -29,22 +29,19 @@
     writeFile (obj "B.txt") "BBB"
     build ["AB.txt"]
     assertContents (obj "AB.txt") "AAABBB"
-    sleepFileTime
     appendFile (obj "A.txt") "aaa"
     build ["AB.txt"]
     assertContents (obj "AB.txt") "AAAaaaBBB"
 
     writeFile (obj "zero.txt") "xxx"
-    build ["twice.txt"]
+    build ["twice.txt","--sleep"]
     assertContents (obj "twice.txt") "xxx"
-    sleepFileTime
     writeFile (obj "zero.txt") "yyy"
-    build ["once.txt"]
+    build ["once.txt","--sleep"]
     assertContents (obj "twice.txt") "xxx"
     assertContents (obj "once.txt") "yyy"
-    sleepFileTime
     writeFile (obj "zero.txt") "zzz"
-    build ["once.txt","twice.txt"]
+    build ["once.txt","twice.txt","--sleep"]
     assertContents (obj "twice.txt") "zzz"
     assertContents (obj "once.txt") "zzz"
 
diff --git a/Examples/Test/Directory.hs b/Examples/Test/Directory.hs
--- a/Examples/Test/Directory.hs
+++ b/Examples/Test/Directory.hs
@@ -7,9 +7,9 @@
 
 
 main = shaken test $ \args obj -> do
-    want $ map obj ["files.lst","dirs.lst","exist.lst"]
+    want $ map obj ["files.lst","dirs.lst","exist.lst","foodirexist.lst"]
     obj "files.lst" *> \out -> do
-        x <- getDirectoryFiles (obj "") "*.txt"
+        x <- getDirectoryFiles (obj "") ["*.txt"]
         writeFileLines out x
     obj "dirs.lst" *> \out -> do
         x <- getDirectoryDirs (obj "")
@@ -18,7 +18,9 @@
         xs <- readFileLines $ obj "files.lst"
         ys <- mapM (doesFileExist . obj) $ xs ++ map reverse xs
         writeFileLines out $ map show ys
-
+    obj "foodirexist.lst" *> \out -> do
+        x <- doesDirectoryExist $ obj "Foo.txt"
+        writeFileLines out [show x]
 
 test build obj = do
     build ["clean"]
@@ -26,12 +28,13 @@
     assertContents (obj "files.lst") $ unlines []
     assertContents (obj "dirs.lst") $ unlines []
     assertContents (obj "exist.lst") $ unlines []
+    assertContents (obj "foodirexist.lst") $ unlines ["False"]
 
     writeFile (obj "A.txt") ""
     writeFile (obj "B.txt") ""
     createDirectory (obj "Foo.txt")
-    sleepFileTime
-    build []
+    build ["--sleep"]
     assertContents (obj "files.lst") $ unlines ["A.txt","B.txt"]
     assertContents (obj "dirs.lst") $ unlines ["Foo.txt"]
     assertContents (obj "exist.lst") $ unlines ["True","True","False","False"]
+    assertContents (obj "foodirexist.lst") $ unlines ["True"]
diff --git a/Examples/Test/Errors.hs b/Examples/Test/Errors.hs
--- a/Examples/Test/Errors.hs
+++ b/Examples/Test/Errors.hs
@@ -58,6 +58,6 @@
     crash ["staunch1","staunch2","--threads2"] ["crash"]
     b <- IO.doesFileExist $ obj "staunch1"
     assert (not b) "File should not exist, should have crashed first"
-    crash ["staunch1","staunch2","--threads2","--staunch"] ["crash"]
+    crash ["staunch1","staunch2","--threads2","--staunch","--silent"] ["crash"]
     b <- IO.doesFileExist $ obj "staunch1"
     assert b "File should exist, staunch should have let it be created"
diff --git a/Examples/Test/FilePattern.hs b/Examples/Test/FilePattern.hs
--- a/Examples/Test/FilePattern.hs
+++ b/Examples/Test/FilePattern.hs
@@ -29,6 +29,15 @@
     substitute ["","test","da"] "//*a*.txt" === "testada.txt"
     substitute  ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt"
 
+    directories1 "*.xml" === ("",False)
+    directories1 "//*.xml" === ("",True)
+    directories1 "foo//*.xml" === ("foo",True)
+    directories1 "foo/bar/*.xml" === ("foo/bar",False)
+    directories1 "*/bar/*.xml" === ("",True)
+    directories ["*.xml","//*.c"] === [("",True)]
+    directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]
+    directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]
+
 
 ---------------------------------------------------------------------
 -- LAZY SMALLCHECK PROPERTIES
diff --git a/Examples/Test/Files.hs b/Examples/Test/Files.hs
--- a/Examples/Test/Files.hs
+++ b/Examples/Test/Files.hs
@@ -23,9 +23,8 @@
 
 test build obj = do
     forM_ [[],["fun"]] $ \args -> do
-        sleepFileTime
         let nums = unlines . map show
         writeFile (obj "numbers.txt") $ nums [1,2,4,5,2,3,1]
-        build args
+        build ("--sleep":args)
         assertContents (obj "even.txt") $ nums [2,4,2]
         assertContents (obj "odd.txt" ) $ nums [1,5,3,1]
diff --git a/Examples/Test/Journal.hs b/Examples/Test/Journal.hs
--- a/Examples/Test/Journal.hs
+++ b/Examples/Test/Journal.hs
@@ -27,8 +27,7 @@
     let change x = writeFile (obj $ x <.> "in") x
     let count x = do
             before <- readIORef rebuilt
-            build []
-            sleepFileTime
+            build ["--sleep"]
             after <- readIORef rebuilt
             x === after - before
 
diff --git a/Examples/Test/Oracle.hs b/Examples/Test/Oracle.hs
new file mode 100644
--- /dev/null
+++ b/Examples/Test/Oracle.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
+
+module Examples.Test.Oracle(main) where
+
+import Development.Shake
+import Examples.Util
+import Control.Exception
+import Control.Monad
+import Data.List
+
+
+main = shaken test $ \args obj -> do
+    let f name lhs rhs = (,) name $
+            (do addOracle $ \k -> let _ = k `asTypeOf` lhs in return rhs; return ()
+            ,let o = obj name ++ ".txt" in do want [o]; o *> \_ -> do v <- askOracleWith lhs rhs; writeFile' o $ show v)
+    let tbl = [f "str-bool" "" True
+              ,f "str-int" "" (0::Int)
+              ,f "bool-str" True ""
+              ,f "int-str" (0::Int) ""]
+
+    forM_ args $ \a -> case a of
+        '+':x | Just (add,_) <- lookup x tbl -> add
+        '*':x | Just (_,use) <- lookup x tbl -> use
+        '@':key -> do addOracle $ \() -> return key; return ()
+        '%':name -> let o = obj "unit.txt" in do want [o]; o *> \_ -> do {askOracleWith () ""; writeFile' o name}
+
+
+test build obj = do
+    build ["clean"]
+
+    -- check it rebuilds when it should
+    build ["@key","%name"]
+    assertContents (obj "unit.txt") "name"
+    build ["@key","%test"]
+    assertContents (obj "unit.txt") "name"
+    build ["@foo","%test"]
+    assertContents (obj "unit.txt") "test"
+
+    -- check adding/removing redundant oracles does not trigger a rebuild
+    build ["@foo","%newer","+str-bool"]
+    assertContents (obj "unit.txt") "test"
+    build ["@foo","%newer","+str-int"]
+    assertContents (obj "unit.txt") "test"
+    build ["@foo","%newer"]
+    assertContents (obj "unit.txt") "test"
+
+    -- check error messages are good
+    let errors args err = do
+            r <- try $ build args
+            case r of
+                Right _ -> error $ "Expected to fail but succeeded, wanted: " ++ err
+                Left (msg :: SomeException)
+                    | err `isInfixOf` show msg -> return ()
+                    | otherwise -> error $ "Bad error message, wanted: " ++ err ++ ", got: " ++ show msg
+
+    build ["+str-int","*str-int"]
+    errors ["*str-int"] -- Building with an an Oracle that has been removed
+        "missing a call to addOracle"
+
+    errors ["*str-bool"] -- Building with an Oracle that I know nothing about
+        "missing a call to addOracle"
+
+    build ["+str-int","*str-int"]
+    errors ["+str-bool","*str-int"] -- Building with an Oracle that has changed type
+        "askOracle is used at the wrong type"
+
+    errors ["+str-int","+str-bool"] -- Two Oracles with the same question type
+        "Only one call to addOracle is allowed"
+
+    errors ["+str-int","*str-bool"] -- Using an Oracle at the wrong answer type
+        "askOracle is used at the wrong type"
+
+    build ["+str-int","+str-int"] -- Two Oracles work if they aren't used
+    errors ["+str-int","+str-int","*str-int"] -- Two Oracles fail if they are used
+        "Only one call to addOracle is allowed"
+
+    errors ["+str-int","+str-bool"] -- Two Oracles with the same answer type
+        "Only one call to addOracle is allowed"
diff --git a/Examples/Test/Progress.hs b/Examples/Test/Progress.hs
new file mode 100644
--- /dev/null
+++ b/Examples/Test/Progress.hs
@@ -0,0 +1,61 @@
+
+module Examples.Test.Progress(main) where
+
+import Development.Shake.Progress
+import Examples.Util
+import Data.IORef
+import Data.Monoid
+import Data.Char
+
+
+main = shaken test $ \args obj -> return ()
+
+
+-- | Given a list of todo times, get out a list of how long is predicted
+prog = progEx 10000000000000000
+
+progEx :: Double -> [Double] -> IO [Double]
+progEx mxDone todo = do
+    let scale = 100 -- Use scale so we can run the test faster
+    let resolution = 10000 -- Use resolution to get extra detail on the numbers
+    let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)
+    pile <- newIORef $ zipWith (\t d -> mempty{timeBuilt=d,timeTodo=(t*scale*resolution,0)}) todo done
+    let get = do a <- readIORef pile
+                 case a of
+                     [] -> return mempty{isRunning=False}
+                     x:xs -> do writeIORef pile xs; return x
+
+    out <- newIORef []
+    let put x = do let (mins,secs) = break (== ':') $ takeWhile (/= '(') x
+                   let f x = let y = filter isDigit x in if null y then 0/0 else read y
+                   modifyIORef out (++ [(f mins * 60 + f secs) / resolution])
+    progressDisplay (1/scale) put get
+    fmap (take $ length todo) $ readIORef out
+
+
+test build obj = do
+    -- perfect functions should match perfectly
+    xs <- prog [10,9..1]
+    drop 2 xs === [8,7..1]
+    xs <- prog $ map (*5) [10,9..1]
+    drop 2 xs === [8,7..1]
+    xs <- prog $ map (*0.2) [10,9..1]
+    let dp3 x = fromIntegral (round $ x * 1000 :: Int) / 1000
+    map dp3 (drop 2 xs) === [8,7..1]
+
+    -- The properties below this line could  be weakened
+
+    -- increasing functions can't match
+    xs <- prog [5,6,7]
+    last xs === 700 -- because of the scale issues
+
+    -- the first value must be plausible, or missing
+    xs <- prog [187]
+    assert (isNaN $ head xs) "No first value"
+
+    -- desirable properties, could be weakened
+    xs <- progEx 2 $ 100:map (*2) [10,9..1]
+    drop 5 xs === [6,5..1]
+    xs <- progEx 1 $ [10,9,100,8,7,6,5,4,3,2,1]
+    assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"
+
diff --git a/Examples/Test/Resources.hs b/Examples/Test/Resources.hs
--- a/Examples/Test/Resources.hs
+++ b/Examples/Test/Resources.hs
@@ -7,12 +7,12 @@
 import Data.IORef
 
 
-main = do
+main extra = do
     let cap = 2
 
     ref <- newIORef 0
     res <- newResource "test" cap
-    shaken test $ \args obj -> do
+    flip (shaken test) extra $ \args obj -> do
         want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"]
         obj "*.txt" *> \out ->
             withResource res 1 $ do
diff --git a/Examples/Util.hs b/Examples/Util.hs
--- a/Examples/Util.hs
+++ b/Examples/Util.hs
@@ -16,8 +16,10 @@
     :: (([String] -> IO ()) -> (String -> String) -> IO ())
     -> ([String] -> (String -> String) -> Rules ())
     -> IO ()
-shaken test rules = do
+    -> IO ()
+shaken test rules sleeper = do
     name:args <- getArgs
+    when ("--sleep" `elem` args) sleeper
     putStrLn $ "## BUILD " ++ unwords (name:args)
     let out = "output/" ++ name ++ "/"
     createDirectoryIfMissing True out
@@ -25,7 +27,7 @@
         "test":extra -> do
             putStrLn $ "## TESTING " ++ name
             -- if the extra arguments are not --quiet/--loud it's probably going to go wrong
-            test (\args -> withArgs (name:args ++ extra) $ shaken test rules) (out++)
+            test (\args -> withArgs (name:args ++ extra) $ shaken test rules sleeper) (out++)
             putStrLn $ "## FINISHED TESTING " ++ name
         "clean":_ -> removeDirectoryRecursive out
 {-
@@ -49,10 +51,10 @@
         args -> do
             (flags,args) <- return $ partition ("-" `isPrefixOf`) args
             flags <- return $ map (dropWhile (== '-')) flags
-            let f o x = case lookup x flagList of
+            let f o x = case lookup x $ flagList name of
                     Just op -> op o
                     Nothing | "threads" `isPrefixOf` x -> o{shakeThreads=read $ drop 7 x}
-                            | x == "clean" -> o -- handled elsewhere
+                            | x `elem` ["clean","sleep"] -> o -- handled elsewhere
                             | otherwise -> error $ "Don't know how to deal with flag: " ++ x
             when ("clean" `elem` flags) $ removeDirectoryRecursive out
             let opts = foldl' f shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html"} flags
@@ -60,11 +62,11 @@
 
 
 flags :: [String]
-flags = "threads#" : map fst flagList ++ ["clean"]
+flags = "threads#" : map fst (flagList "") ++ ["clean","sleep"]
 
 
-flagList :: [(String, ShakeOptions -> ShakeOptions)]
-flagList = let (*) = (,) in
+flagList :: String -> [(String, ShakeOptions -> ShakeOptions)]
+flagList name = let (*) = (,) in
     ["no-dump" * \o -> o{shakeReport=Nothing}
     ,"silent" * \o -> o{shakeVerbosity=Silent}
     ,"quiet" * \o -> o{shakeVerbosity=Quiet}
@@ -74,21 +76,13 @@
     ,"staunch" * \o -> o{shakeStaunch=True}
     ,"deterministic" * \o -> o{shakeDeterministic=True}
     ,"lint" * \o -> o{shakeLint=True}
-    ,"stats" * \o -> o{shakeProgress=showProgress}
+    ,"progress" * \o -> o{shakeProgress=progressSimple}
     ,"assume-clean" * \o -> o{shakeAssume=Just AssumeClean}
     ,"assume-dirty" * \o -> o{shakeAssume=Just AssumeDirty}
+    ,"abbrev" * \o -> o{shakeAbbreviations=[(if name == "" then "output" else "output/" ++ name, "$OUT")]}
     ]
 
-showProgress s = forkIO loop >> return ()
-    where loop = do
-            res <- s
-            when (isRunning res) $ do
-                let (s,c) = timeTodo res
-                putStrLn $ "PROGRESS: timeTodo = " ++ show (ceiling s) ++ "s (+ " ++ show c ++ " unknown)"
-                sleep 5
-                loop
 
-
 unobj :: FilePath -> FilePath
 unobj = dropDirectory1 . dropDirectory1
 
@@ -109,7 +103,7 @@
 
 noTest :: ([String] -> IO ()) -> (String -> String) -> IO ()
 noTest build obj = do
-    build []
+    build ["--abbrev"]
     build []
 
 
@@ -134,7 +128,7 @@
 getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
 getDirectoryContentsRecursive dir = do
     xs <- IO.getDirectoryContents dir
-    (dirs,files) <- partitionM doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x]
+    (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x]
     rest <- concatMapM getDirectoryContentsRecursive dirs
     return $ files++rest
     where
diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -1,9 +1,12 @@
 module Main where
 
+import Control.Concurrent
+import Control.Monad
+import Data.List
 import Data.Maybe
 import System.Environment
 
-import Examples.Util(flags)
+import Examples.Util(flags, sleepFileTime)
 import qualified Examples.Tar.Main as Tar
 import qualified Examples.Self.Main as Self
 import qualified Examples.C.Main as C
@@ -16,7 +19,9 @@
 import qualified Examples.Test.FilePath as FilePath
 import qualified Examples.Test.FilePattern as FilePattern
 import qualified Examples.Test.Journal as Journal
+import qualified Examples.Test.Oracle as Oracle
 import qualified Examples.Test.Pool as Pool
+import qualified Examples.Test.Progress as Progress
 import qualified Examples.Test.Random as Random
 import qualified Examples.Test.Resources as Resources
 
@@ -28,7 +33,8 @@
         ,"basic" * Basic.main, "directory" * Directory.main, "errors" * Errors.main
         ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main
         ,"journal" * Journal.main, "pool" * Pool.main, "random" * Random.main
-        ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main]
+        ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main
+        ,"oracle" * Oracle.main, "progress" * Progress.main]
     where (*) = (,)
 
 
@@ -48,14 +54,27 @@
             ,"  main self --threads2 --loud"
             ,""
             ,"Which will build Shake, using Shake, on 2 threads."]
-        Just main -> main
+        Just main -> main sleepFileTime
 
 
-clean :: IO ()
-clean = sequence_ [withArgs [name,"clean"] main | (name,main) <- mains]
+clean :: IO () -> IO ()
+clean extra = sequence_ [withArgs [name,"clean"] $ main extra | (name,main) <- mains]
 
 
-test :: IO ()
-test = do
+test :: IO () -> IO ()
+test _ = do
     args <- getArgs
-    sequence_ [withArgs (name:"test":drop 1 args) main | (name,main) <- mains, name /= "random"]
+    one <- newMVar () -- Only one may execute at a time
+    let pause = do putMVar one (); sleepFileTime; takeMVar one
+    let tests = filter ((/= "random") . fst) mains
+    -- priority tests have more pauses in, so doing them sooner gets the whole tests done faster
+    let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests
+    dones <- forM (priority ++ normal) $ \(name,main) -> do
+        done <- newEmptyMVar
+        forkIO $ do
+            takeMVar one
+            withArgs (name:"test":drop 1 args) $ main pause
+            putMVar one ()
+            putMVar done ()
+        return done
+    mapM_ takeMVar dones
diff --git a/shake.cabal b/shake.cabal
--- a/shake.cabal
+++ b/shake.cabal
@@ -1,7 +1,7 @@
 cabal-version:      >= 1.8
 build-type:         Simple
 name:               shake
-version:            0.6
+version:            0.7
 license:            BSD3
 license-file:       LICENSE
 category:           Development
@@ -100,6 +100,7 @@
         Development.Shake.Database
         Development.Shake.Derived
         Development.Shake.Directory
+        Development.Shake.Errors
         Development.Shake.File
         Development.Shake.FilePattern
         Development.Shake.Files
@@ -108,6 +109,7 @@
         Development.Shake.Locks
         Development.Shake.Oracle
         Development.Shake.Pool
+        Development.Shake.Progress
         Development.Shake.Report
         Development.Shake.Rerun
         Development.Shake.Storage
@@ -156,6 +158,8 @@
         Examples.Test.FilePattern
         Examples.Test.Files
         Examples.Test.Journal
+        Examples.Test.Oracle
         Examples.Test.Pool
+        Examples.Test.Progress
         Examples.Test.Random
         Examples.Test.Resources