shake 0.10.3 → 0.10.4

raw patch · 36 files changed

+888/−275 lines, 36 files

Files

• Development/Make/All.hs +135/−0
• Development/Make/Main.hs +0/−161
• Development/Ninja/All.hs +120/−0
• Development/Ninja/Parse.hs +163/−0
• Development/Ninja/Type.hs +76/−0
• Development/Shake.hs +4/−2
• Development/Shake/Args.hs +13/−3
• Development/Shake/Command.hs +6/−3
• Development/Shake/Core.hs +58/−25
• Development/Shake/Database.hs +6/−8
• Development/Shake/Derived.hs +7/−4
• Development/Shake/Errors.hs +17/−16
• Development/Shake/File.hs +6/−1
• Development/Shake/FilePath.hs +7/−0
• Development/Shake/FileTime.hs +2/−2
• Development/Shake/Files.hs +1/−1
• Development/Shake/Locks.hs +25/−9
• Development/Shake/Progress.hs +4/−2
• Development/Shake/Shake.hs +2/−0
• Development/Shake/Special.hs +21/−0
• Development/Shake/Storage.hs +6/−1
• Development/Shake/Timing.hs +58/−0
• Development/Shake/Types.hs +16/−9
• Examples/Self/Main.hs +6/−6
• Examples/Test/Cache.hs +1/−1
• Examples/Test/Docs.hs +1/−1
• Examples/Test/Journal.hs +1/−2
• Examples/Test/Lint.hs +8/−2
• Examples/Test/Makefile.hs +7/−5
• Examples/Test/Resources.hs +2/−0
• LICENSE +1/−1
• Main.hs +1/−1
• Paths.hs +12/−1
• Start.hs +42/−0
• Test.hs +38/−5
• shake.cabal +15/−3

@@ -0,0 +1,135 @@+{-# LANGUAGE RecordWildCards, PatternGuards, CPP #-}
+
+module Development.Make.All(runMakefile) where
+
+import System.Environment
+import Development.Shake
+import Development.Shake.FilePath
+import Development.Make.Parse
+import Development.Make.Env
+import Development.Make.Rules
+import Development.Make.Type
+import qualified System.Directory as IO
+import Data.List
+import Data.Maybe
+import Control.Arrow
+import Control.Monad
+import System.Cmd
+import System.Exit
+import Control.Monad.Trans.State.Strict
+
+
+runMakefile :: FilePath -> [String] -> IO (Rules ())
+runMakefile file args = do
+    env <- defaultEnv
+    mk <- parse file
+    rs <- eval env mk
+    return $ do
+        defaultRuleFile_
+        case filter (not . isPrefixOf "." . target) rs of
+            Ruler x _ _ : _ | null args, '%' `notElem` x -> want_ [x]
+            _ -> return ()
+        mapM_ (want_ . return) args
+        convert rs
+
+
+data Ruler = Ruler
+    {target :: String
+    ,prereq :: (Env, Expr) -- Env is the Env at this point
+    ,cmds :: (Env, [Command]) -- Env is the Env at the end
+    }
+
+
+eval :: Env -> Makefile -> IO [Ruler]
+eval env (Makefile xs) = do
+    (rs, env) <- runStateT (fmap concat $ mapM f xs) env
+    return [r{cmds=(env,snd $ cmds r)} | r <- rs]
+    where
+        f :: Stmt -> StateT Env IO [Ruler]
+        f Assign{..} = do
+            e <- get
+            e <- liftIO $ addEnv name assign expr e
+            put e
+            return []
+
+        f Rule{..} = do
+            e <- get
+            target <- liftIO $ fmap words $ askEnv e targets
+            return $ map (\t -> Ruler t (e, prerequisites) (undefined, commands)) target
+
+
+convert :: [Ruler] -> Rules ()
+convert rs = match ??> run
+    where
+        match s = any (isJust . check s) rs
+        check s r = makePattern (target r) s
+
+        run target =  do
+            let phony = has False ".PHONY" target
+            let silent = has True ".SILENT" target
+            (deps, cmds) <- fmap (first concat . second concat . unzip) $ forM rs $ \r ->
+                case check target r of
+                    Nothing -> return ([], [])
+                    Just op -> do
+                        let (preEnv,preExp) = prereq r
+                        env <- liftIO $ addEnv "@" Equals (Lit target) preEnv
+                        pre <- liftIO $ askEnv env preExp
+                        vp <- liftIO $ fmap splitSearchPath $ askEnv env $ Var "VPATH"
+                        pre <- mapM (vpath vp) $ words $ op pre
+                        return (pre, [cmds r])
+            mapM_ (need_ . return) deps
+            forM_ cmds $ \(env,cmd) -> do
+                env <- liftIO $ addEnv "@" Equals (Lit target) env
+                env <- liftIO $ addEnv "^" Equals (Lit $ unwords deps) env
+                env <- liftIO $ addEnv "<" Equals (Lit $ head $ deps ++ [""]) env
+                forM_ cmd $ \c ->
+                    case c of
+                        Expr c -> (if silent then quietly else id) $
+                            runCommand =<< liftIO (askEnv env c)
+            return $ if phony then Phony else NotPhony
+
+        has auto name target =
+            or [(null ws && auto) || target `elem` ws | Ruler t (_,Lit s) _ <- rs, t == name, let ws = words s]
+
+
+runCommand :: String -> Action ()
+runCommand x = do
+    res <- if "@" `isPrefixOf` x then sys $ drop 1 x
+           else putNormal x >> sys x
+    when (res /= ExitSuccess) $
+        error $ "System command failed: " ++ x
+    where sys = quietly . traced (unwords $ take 1 $ words x) . system
+
+
+makePattern :: String -> FilePath -> Maybe (String -> String)
+makePattern pat v = case break (== '%') pat of
+    (pre,'%':post) -> if pre `isPrefixOf` v && post `isSuffixOf` v && rest >= 0
+                      then Just $ concatMap (\x -> if x == '%' then subs else [x])
+                      else Nothing
+        where rest = length v - (length pre + length post)
+              subs = take rest $ drop (length pre) v
+    otherwise -> if pat == v then Just id else Nothing
+
+
+vpath :: [FilePath] -> FilePath -> Action FilePath
+vpath [] y = return y
+vpath (x:xs) y = do
+    b <- doesFileExist $ x </> y
+    if b then return $ x </> y else vpath xs y
+
+
+defaultEnv :: IO Env
+defaultEnv = do
+#if __GLASGOW_HASKELL__ >= 706
+    exePath <- getExecutablePath
+#else
+    exePath <- getProgName
+#endif
+
+    env <- getEnvironment
+    cur <- IO.getCurrentDirectory
+    return $ newEnv $
+        ("EXE",if null exe then "" else "." ++ exe) :
+        ("MAKE",normalise exePath) :
+        ("CURDIR",normalise cur) :
+        env

@@ -1,161 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards, CPP #-}
-
-module Development.Make.Main(main) where
-
-import System.Environment
-import Development.Shake
-import Development.Shake.FilePath
-import Development.Make.Parse
-import Development.Make.Env
-import Development.Make.Rules
-import Development.Make.Type
-import qualified System.Directory as IO
-import Data.List
-import Data.Maybe
-import Control.Arrow
-import Control.Monad
-import System.Cmd
-import System.Exit
-import Control.Monad.Trans.State.Strict
-import System.Console.GetOpt
-
-
-main :: IO ()
-main = do
-    args <- getArgs
-    withArgs ("--no-time":args) $
-        shakeArgsWith shakeOptions flags $ \opts targets -> do
-            makefile <- case reverse [x | UseMakefile x <- opts] of
-                x:_ -> return x
-                _ -> findMakefile
-            fmap Just $ runMakefile makefile targets
-
-
-data Flag = UseMakefile FilePath
-
-flags = [Option "f" ["file","makefile"] (ReqArg (Right . UseMakefile) "FILE") "Read FILE as a makefile."]
-
-
-findMakefile :: IO FilePath
-findMakefile = do
-    b <- IO.doesFileExist "makefile"
-    if b then return "makefile" else do
-        b <- IO.doesFileExist "Makefile"
-        if b then return "Makefile" else
-            error "Could not find either `makefile' or `Makefile'"
-
-
-runMakefile :: FilePath -> [String] -> IO (Rules ())
-runMakefile file args = do
-    env <- defaultEnv
-    mk <- parse file
-    rs <- eval env mk
-    return $ do
-        defaultRuleFile_
-        case filter (not . isPrefixOf "." . target) rs of
-            Ruler x _ _ : _ | null args, '%' `notElem` x -> want_ [x]
-            _ -> return ()
-        mapM_ (want_ . return) args
-        convert rs
-
-
-data Ruler = Ruler
-    {target :: String
-    ,prereq :: (Env, Expr) -- Env is the Env at this point
-    ,cmds :: (Env, [Command]) -- Env is the Env at the end
-    }
-
-
-eval :: Env -> Makefile -> IO [Ruler]
-eval env (Makefile xs) = do
-    (rs, env) <- runStateT (fmap concat $ mapM f xs) env
-    return [r{cmds=(env,snd $ cmds r)} | r <- rs]
-    where
-        f :: Stmt -> StateT Env IO [Ruler]
-        f Assign{..} = do
-            e <- get
-            e <- liftIO $ addEnv name assign expr e
-            put e
-            return []
-
-        f Rule{..} = do
-            e <- get
-            target <- liftIO $ fmap words $ askEnv e targets
-            return $ map (\t -> Ruler t (e, prerequisites) (undefined, commands)) target
-
-
-convert :: [Ruler] -> Rules ()
-convert rs = match ??> run
-    where
-        match s = any (isJust . check s) rs
-        check s r = makePattern (target r) s
-
-        run target =  do
-            let phony = has False ".PHONY" target
-            let silent = has True ".SILENT" target
-            (deps, cmds) <- fmap (first concat . second concat . unzip) $ forM rs $ \r ->
-                case check target r of
-                    Nothing -> return ([], [])
-                    Just op -> do
-                        let (preEnv,preExp) = prereq r
-                        env <- liftIO $ addEnv "@" Equals (Lit target) preEnv
-                        pre <- liftIO $ askEnv env preExp
-                        vp <- liftIO $ fmap splitSearchPath $ askEnv env $ Var "VPATH"
-                        pre <- mapM (vpath vp) $ words $ op pre
-                        return (pre, [cmds r])
-            mapM_ (need_ . return) deps
-            forM_ cmds $ \(env,cmd) -> do
-                env <- liftIO $ addEnv "@" Equals (Lit target) env
-                env <- liftIO $ addEnv "^" Equals (Lit $ unwords deps) env
-                env <- liftIO $ addEnv "<" Equals (Lit $ head $ deps ++ [""]) env
-                forM_ cmd $ \c ->
-                    case c of
-                        Expr c -> (if silent then quietly else id) $
-                            runCommand =<< liftIO (askEnv env c)
-            return $ if phony then Phony else NotPhony
-
-        has auto name target =
-            or [(null ws && auto) || target `elem` ws | Ruler t (_,Lit s) _ <- rs, t == name, let ws = words s]
-
-
-runCommand :: String -> Action ()
-runCommand x = do
-    res <- if "@" `isPrefixOf` x then sys $ drop 1 x
-           else putNormal x >> sys x
-    when (res /= ExitSuccess) $
-        error $ "System command failed: " ++ x
-    where sys = quietly . traced (unwords $ take 1 $ words x) . system
-
-
-makePattern :: String -> FilePath -> Maybe (String -> String)
-makePattern pat v = case break (== '%') pat of
-    (pre,'%':post) -> if pre `isPrefixOf` v && post `isSuffixOf` v && rest >= 0
-                      then Just $ concatMap (\x -> if x == '%' then subs else [x])
-                      else Nothing
-        where rest = length v - (length pre + length post)
-              subs = take rest $ drop (length pre) v
-    otherwise -> if pat == v then Just id else Nothing
-
-
-vpath :: [FilePath] -> FilePath -> Action FilePath
-vpath [] y = return y
-vpath (x:xs) y = do
-    b <- doesFileExist $ x </> y
-    if b then return $ x </> y else vpath xs y
-
-
-defaultEnv :: IO Env
-defaultEnv = do
-#if __GLASGOW_HASKELL__ >= 706
-    exePath <- getExecutablePath
-#else
-    exePath <- getProgName
-#endif
-
-    env <- getEnvironment
-    cur <- IO.getCurrentDirectory
-    return $ newEnv $
-        ("EXE",if null exe then "" else "." ++ exe) :
-        ("MAKE",normalise exePath) :
-        ("CURDIR",normalise cur) :
-        env

@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables #-}
+
+module Development.Ninja.All(runNinja) where
+
+import Development.Ninja.Type
+import Development.Ninja.Parse
+import Development.Shake hiding (Rule)
+import Development.Shake.Command
+import Development.Shake.FilePath
+import Development.Shake.Timing
+import qualified Data.ByteString.Char8 as BS
+
+import System.Directory
+import qualified Data.HashMap.Strict as Map
+import Control.Monad
+import Data.List
+import Data.Char
+
+
+runNinja :: FilePath -> [String] -> IO (Rules ())
+runNinja file args = do
+    addTiming "Ninja parse"
+    ninja@Ninja{..} <- parse file
+    return $ do
+        phonys <- return $ Map.fromList phonys
+        singles <- return $ Map.fromList singles
+        multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- multiples, x <- xs]
+        rules <- return $ Map.fromList rules
+        pools <- fmap Map.fromList $ forM pools $ \(name,depth) ->
+            fmap ((,) name) $ newResource (BS.unpack name) depth
+
+        want $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $ if null args then defaults else map BS.pack args
+
+        (\x -> fmap (map BS.unpack . fst) $ Map.lookup (BS.pack x) multiples) ?>> \out -> let out2 = map BS.pack out in
+            build defines phonys rules pools out2 $ snd $ multiples Map.! head out2
+
+        (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in
+            build defines phonys rules pools [out2] $ singles Map.! out2
+
+
+resolvePhony :: Map.HashMap Str [Str] -> Str -> [Str]
+resolvePhony mp = f $ Left 100
+    where
+        f (Left 0) x = f (Right []) x
+        f (Right xs) x | x `elem` xs = error $ "Recursive phony involving " ++ BS.unpack x
+        f a x = case Map.lookup x mp of
+            Nothing -> [x]
+            Just xs -> concatMap (f $ either (Left . subtract 1) (Right . (x:)) a) xs
+
+
+build :: Env -> Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action ()
+build env phonys rules pools out Build{..} = do
+    need $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit ++ depsOrderOnly
+    case Map.lookup ruleName rules of
+        Nothing -> error $ "Ninja rule named " ++ BS.unpack ruleName ++ " is missing, required to build " ++ BS.unpack (BS.unwords out)
+        Just Rule{..} -> do
+            env <- return $
+                addBinds ruleBind $ addBinds buildBind $
+                addEnv (BS.pack "in_newline") (BS.unlines depsNormal) $
+                addEnv (BS.pack "in") (BS.unwords depsNormal) $
+                addEnv (BS.pack "out") (BS.unwords out) env
+
+            applyRspfile env $ do
+                let commandline = BS.unpack $ askVar env $ BS.pack "command"
+                let depfile = BS.unpack $ askVar env $ BS.pack "depfile"
+                let deps = BS.unpack $ askVar env $ BS.pack "deps"
+                let description = BS.unpack $ askVar env $ BS.pack "description"
+                let pool = askVar env $ BS.pack "pool"
+
+                let withPool act = case Map.lookup pool pools of
+                        _ | BS.null pool -> act
+                        Nothing -> error $ "Ninja pool named " ++ BS.unpack pool ++ " not found, required to build " ++ BS.unpack (BS.unwords out)
+                        Just r -> withResource r 1 act
+
+                when (description /= "") $ putNormal description
+                if deps == "msvc" then do
+                    Stdout stdout <- withPool $ command [Shell, EchoStdout True] commandline []
+                    need $ map normalise $ parseShowIncludes stdout
+                 else
+                    withPool $ command_ [Shell] commandline []
+                when (depfile /= "") $ do
+                    when (deps /= "gcc") $ need [depfile]
+                    depsrc <- liftIO $ readFile depfile
+                    need $ map normalise $ concatMap snd $ parseMakefile depsrc
+                    when (deps == "gcc") $ liftIO $ removeFile depfile
+
+
+applyRspfile :: Env -> Action a -> Action a
+applyRspfile env act
+    | rspfile == "" = act
+    | otherwise = do
+        liftIO $ BS.writeFile rspfile rspfile_content
+        res <- act
+        liftIO $ removeFile rspfile
+        return res
+    where
+        rspfile = BS.unpack $ askVar env $ BS.pack "rspfile"
+        rspfile_content = askVar env $ BS.pack "rspfile_content"
+
+
+parseShowIncludes :: String -> [FilePath]
+parseShowIncludes out = [y | x <- lines out, Just x <- [stripPrefix "Note: including file:" x]
+                           , let y = dropWhile isSpace x, not $ isSystemInclude y]
+
+
+-- Dodgy, but ported over from the original Ninja
+isSystemInclude :: String -> Bool
+isSystemInclude x = "program files" `isInfixOf` lx || "microsoft visual studio" `isInfixOf` lx
+    where lx = map toLower x
+
+
+parseMakefile :: String -> [(FilePath, [FilePath])]
+parseMakefile = concatMap f . join . lines
+    where
+        join (x1:x2:xs) | "\\" `isSuffixOf` x1 = join $ (init x1 ++ x2) : xs
+        join (x:xs) = x : join xs
+        join [] = []
+
+        f x = [(a, words $ drop 1 b) | a <- words a]
+            where (a,b) = break (== ':') $ takeWhile (/= '#') x

@@ -0,0 +1,163 @@+{-# LANGUAGE PatternGuards, RecordWildCards #-}
+
+-- | Parsing is a slow point, the below is optimised
+module Development.Ninja.Parse(parse) where
+
+import qualified Data.ByteString.Char8 as BS
+import Development.Ninja.Type
+import Control.Arrow
+import Control.Monad
+import Data.Char
+import Data.Maybe
+
+
+endsDollar :: Str -> Bool
+endsDollar = BS.isSuffixOf (BS.pack "$")
+
+dropSpace :: Str -> Str
+dropSpace = BS.dropWhile isSpace
+
+startsSpace :: Str -> Bool
+startsSpace = BS.isPrefixOf (BS.pack " ")
+
+linesCR :: Str -> [Str]
+linesCR x | BS.null x = []
+          | otherwise = case BS.elemIndex '\n' x of
+                Nothing -> [x]
+                Just i | i >= 1 && BS.index x (i-1) == '\r' -> BS.take (i-1) x : linesCR (BS.drop (i+1) x)
+                       | otherwise -> BS.take i x : linesCR (BS.drop (i+1) x)
+
+
+word1 :: Str -> (Str, Str)
+word1 x = (a, dropSpace b)
+    where (a,b) = BS.break isSpace x
+
+isVar :: Char -> Bool
+isVar x = isAlphaNum x || x == '_'
+
+parse :: FilePath -> IO Ninja
+parse file = parseFile file newNinja
+
+
+parseFile :: FilePath -> Ninja -> IO Ninja
+parseFile file ninja = do
+    src <- if file == "-" then BS.getContents else BS.readFile file
+    foldM applyStmt ninja $ splitStmts src
+
+
+data Stmt = Stmt Str [Str] deriving Show
+
+
+splitStmts :: Str -> [Stmt]
+splitStmts = stmt . continuation . linesCR
+    where
+        continuation (x:xs) | endsDollar x = BS.concat (BS.init x : map (dropSpace . BS.init) a ++ map dropSpace (take 1 b)) : continuation (drop 1 b)
+            where (a,b) = span endsDollar xs
+        continuation (x:xs) = x : continuation xs
+        continuation [] = []
+
+        stmt [] = []
+        stmt (x:xs) = Stmt x (map dropSpace a) : stmt b
+            where (a,b) = span startsSpace xs
+
+
+applyStmt :: Ninja -> Stmt -> IO Ninja
+applyStmt ninja@Ninja{..} (Stmt x xs)
+    | key == BS.pack "rule" =
+        return ninja{rules = (BS.takeWhile isVar rest, Rule $ parseBinds xs) : rules}
+    | key == BS.pack "default" =
+        return ninja{defaults = parseStrs defines rest ++ defaults}
+    | key == BS.pack "pool" =
+        return ninja{pools = (BS.takeWhile isVar rest, getDepth $ map (second $ askExpr defines) $ parseBinds xs) : pools}
+    | key == BS.pack "build",
+        (out,rest) <- splitColon rest,
+        outputs <- parseStrs defines out,
+        (rule,deps) <- word1 $ dropSpace rest,
+        (normal,implicit,orderOnly) <- splitDeps $ parseStrs defines deps,
+        let build = Build rule normal implicit orderOnly $ parseBinds xs
+        = return $
+            if rule == BS.pack "phony" then ninja{phonys = [(x, normal) | x <- outputs] ++ phonys}
+            else if length outputs == 1 then ninja{singles = (head outputs, build) : singles}
+            else ninja{multiples = (outputs, build) : multiples}
+    | key == BS.pack "include" = parseFile (BS.unpack rest) ninja
+    | key == BS.pack "subninja" = do
+        ninja <- parseFile (BS.unpack rest) ninja
+        -- restore to the original environment after, which is what Ninja actually does
+        return ninja{defines = defines}
+    | Just (a,b) <- parseBind x = return ninja{defines = addBind a b defines}
+    | BS.null $ dropSpace x = return ninja
+    | BS.pack "#" `BS.isPrefixOf` dropSpace x = return ninja -- comments can only occur on their own line
+    | otherwise = error $ "Cannot parse line: " ++ BS.unpack x
+    where (key,rest) = word1 x
+
+
+getDepth :: [(Str, Str)] -> Int
+getDepth xs = case lookup (BS.pack "depth") xs of
+    Nothing -> 1
+    Just x | Just (i, n) <- BS.readInt x, BS.null n -> i
+           | otherwise -> error $ "Could not parse depth field in pool, got: " ++ BS.unpack x
+
+
+parseBind :: Str -> Maybe (Str, Expr)
+parseBind x
+    | (var,rest) <- BS.span isVar x
+    , Just ('=',rest) <- BS.uncons $ dropSpace rest
+    = Just (var, parseExpr $ dropSpace rest)
+    | otherwise = Nothing
+
+
+parseBinds :: [Str] -> [(Str, Expr)]
+parseBinds = map $ \x -> fromMaybe (error $ "Unknown Ninja binding: " ++ BS.unpack x) $ parseBind x
+
+
+parseExpr :: Str -> Expr
+parseExpr = exprs . f
+    where
+        exprs [x] = x
+        exprs xs = Exprs xs
+
+        f x = Lit a : g (BS.drop 1 b)
+            where (a,b) = BS.break (== '$') x
+
+        g x = case BS.uncons x of
+            Nothing -> []
+            Just (c,s)
+                | c == '$' -> Lit (BS.singleton '$') : f s
+                | c == ' ' -> Lit (BS.singleton ' ') : f s
+                | c == ':' -> Lit (BS.singleton ':') : f s
+                | c == '{' -> let (a,b) = BS.break (== '}') s in Var a : f (BS.drop 1 b)
+                | otherwise -> let (a,b) = BS.span isVar x in Var a : f b
+
+
+parseStrs :: Env -> Str -> [Str]
+parseStrs env = map (askExpr env) . parseExprs
+
+
+
+splitDeps :: [Str] -> ([Str], [Str], [Str])
+splitDeps (x:xs) | x == BS.pack "|" = ([],a++b,c)
+                 | x == BS.pack "||" = ([],b,a++c)
+                 | otherwise = (x:a,b,c)
+    where (a,b,c) = splitDeps xs
+splitDeps [] = ([], [], [])
+
+
+parseExprs :: Str -> [Expr]
+parseExprs = map parseExpr . f
+    where
+        f x | BS.null x = []
+            | otherwise = let (a,b) = splitUnescaped ' ' x in a : f b
+
+
+splitUnescaped :: Char -> Str -> (Str, Str)
+splitUnescaped c x = case filter valid $ BS.elemIndices c x of
+    [] -> (x, BS.empty)
+    i:_ -> (BS.take i x, BS.drop (i+1) x)
+    where
+        -- technically there could be $$:, so an escaped $ followed by a literal :
+        -- that seems very unlikely...
+        valid i = i == 0 || BS.index x (i-1) /= '$'
+
+-- Find a non-escape : 
+splitColon :: Str -> (Str, Str)
+splitColon = splitUnescaped ':'

@@ -0,0 +1,76 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++-- | The IO in this module is only to evaluate an envrionment variable,+--   the 'Env' itself it passed around purely.+module Development.Ninja.Type(+    Str, FileStr,+    Expr(..), Env, newEnv, askVar, askExpr, addEnv, addBind, addBinds,+    Ninja(..), newNinja, Build(..), Rule(..),+    ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as Map+import Data.Maybe+++type Str = BS.ByteString+type FileStr = Str+++---------------------------------------------------------------------+-- ENVIRONMENT++newtype Env = Env (Map.HashMap Str Str) deriving Show++data Expr = Exprs [Expr] | Lit Str | Var Str deriving Show++newEnv :: Env+newEnv = Env Map.empty++askExpr :: Env -> Expr -> Str+askExpr e = f+    where f (Exprs xs) = BS.concat $ map f xs+          f (Lit x) = x+          f (Var x) = askVar e x++askVar :: Env -> Str -> Str+askVar (Env e) x = fromMaybe BS.empty $ Map.lookup x e++addEnv :: Str -> Str -> Env -> Env+addEnv k v (Env e) = Env $ Map.insert k v e++addBind :: Str -> Expr -> Env -> Env+addBind k v env = addEnv k (askExpr env v) env++addBinds :: [(Str, Expr)] -> Env -> Env+addBinds kvs e = foldl (\e (k,v) -> addBind k v e) e kvs+++---------------------------------------------------------------------+-- STRUCTURE++data Ninja = Ninja+    {defines :: !Env+    ,rules :: [(Str,Rule)]+    ,singles :: [(FileStr,Build)]+    ,multiples :: [([FileStr], Build)]+    ,phonys :: ([(Str, [FileStr])])+    ,defaults :: [FileStr]+    ,pools :: [(Str, Int)]+    }+    deriving Show++newNinja :: Ninja+newNinja = Ninja newEnv [] [] [] [] [] []++data Build = Build+    {ruleName :: Str+    ,depsNormal :: [FileStr]+    ,depsImplicit :: [FileStr]+    ,depsOrderOnly :: [FileStr]+    ,buildBind :: [(Str,Expr)]+    } deriving Show++data Rule = Rule+    {ruleBind :: [(Str,Expr)]+    } deriving Show

@@ -10,7 +10,7 @@ --main = 'shakeArgs' 'shakeOptions' $ do --    'want' [\"result.tar\"] --    \"*.tar\" '*>' \\out -> do---        contents <- 'readFileLines' $ 'Development.Shake.FilePath.replaceExtension' out \"txt\"+--        contents \<- 'readFileLines' $ out 'Development.Shake.FilePath.-<.>' \"txt\" --        'need' contents --        'system'' \"tar\" $ [\"-cf\",out] ++ contents -- @@@ -69,6 +69,7 @@     Rule(..), Rules, defaultRule, rule, action, withoutActions,     Action, apply, apply1, traced,     liftIO, actionOnException, actionFinally,+    ShakeException(..),     -- * Configuration     ShakeOptions(..), Assume(..),     -- ** Command line@@ -93,7 +94,7 @@     -- * Special rules     alwaysRerun,     -- * Finite resources-    Resource, newResource, newResourceIO, withResource,+    Resource, newResource, newResourceIO, withResource, withResources,     -- * Cached file contents     newCache, newCacheIO     ) where@@ -105,6 +106,7 @@ import Development.Shake.Types import Development.Shake.Core import Development.Shake.Derived+import Development.Shake.Errors import Development.Shake.Progress import Development.Shake.Args import Development.Shake.Shake

@@ -6,8 +6,10 @@ import Development.Shake.Types import Development.Shake.Core import Development.Shake.File+import Development.Shake.FilePath import Development.Shake.Progress import Development.Shake.Shake+import Development.Shake.Timing  import Control.Arrow import Control.Concurrent@@ -53,7 +55,7 @@ -- * @main _make/henry.txt@ will not build @neil.txt@ or @emily.txt@, but will instead build @henry.txt@. shakeArgs :: ShakeOptions -> Rules () -> IO () shakeArgs opts rules = shakeArgsWith opts [] f-    where f _ files = return $ Just $ if null files then rules else want files >> withoutActions rules+    where f _ files = return $ Just $ if null files then rules else want (map normalise files) >> withoutActions rules   -- | A version of 'shakeArgs' with more flexible handling of command line arguments.@@ -99,6 +101,7 @@ --   Now you can pass @--distcc@ to use the @distcc@ compiler. shakeArgsWith :: ShakeOptions -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO () shakeArgsWith baseOpts userOptions rules = do+    addTiming "shakeArgsWith"     args <- getArgs     let (flags,files,errs) = getOpt Permute opts args         (flagsError,flag1) = partitionEithers flags@@ -129,7 +132,9 @@         curdir <- getCurrentDirectory         let redir = case changeDirectory of                 Nothing -> id-                Just d -> bracket_ (setCurrentDirectory d) (setCurrentDirectory curdir)+                -- get the "html" directory so it caches with the current directory+                -- required only for debug code+                Just d -> bracket_ (getDataFileName "html" >> setCurrentDirectory d) (setCurrentDirectory curdir)         (ran,res) <- redir $ do             when printDirectory $ putStrLn $ "shake: In directory `" ++ curdir ++ "'"             rules <- rules user files@@ -230,6 +235,7 @@     ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."     ,no  $ Option "o" ["old-file","assume-old"] (ReqArg (\x -> Right ([AssumeOld x],id)) "FILE") "Consider FILE to be very old and don't remake it."     ,yes $ Option ""  ["old-all"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Don't remake any files."+    ,yes $ Option ""  ["assume-skip"] (noArg $ \s -> s{shakeAssume=Just AssumeSkip}) "Don't remake any files this run."     ,yes $ Option "r" ["report"] (OptArg (\x -> Right ([], \s -> s{shakeReport=Just $ fromMaybe "report.html" x})) "FILE") "Write out profiling information [to report.html]."     ,yes $ Option ""  ["no-report"] (noArg $ \s -> s{shakeReport=Nothing}) "Turn off --report."     ,yes $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."@@ -237,10 +243,11 @@     ,no  $ Option ""  ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."     ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."     ,yes $ Option ""  ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."-    ,yes $ Option "p" ["progress"] (noArg $ \s -> s{shakeProgress=progressSimple}) "Show progress messages."+    ,yes $ Option "p" ["progress"] (optIntArg "progress" "N" (\i s -> s{shakeProgress=progressDisplay (fromMaybe 5 i) progressTitlebar})) "Show progress messages [every N seconds, default 5]."     ,yes $ Option " " ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."     ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."     ,no  $ Option ""  ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."+    ,yes $ Option ""  ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."     ,yes $ Option "t" ["touch"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Assume targets are clean."     ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print tracing information."     ,no  $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit."@@ -261,6 +268,9 @@         intArg flag a f = flip ReqArg a $ \x -> case reads x of             [(i,"")] | i >= 1 -> Right ([],f i)             _ -> Left $ "the `--" ++ flag ++ "' option requires a positive integral argument"+        optIntArg flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of+            [(i,"")] | i >= 1 -> Right ([],f $ Just i)+            _ -> Left $ "the `--" ++ flag ++ "' option only allows a positive integral argument"         pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of             (a,'=':b) -> Right ([],f (a,b))             _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"

@@ -186,15 +186,15 @@  -- | Collect the @stdout@ of the process. --   If you are collecting the @stdout@, it will not be echoed to the terminal, unless you include 'EchoStdout'.-newtype Stdout = Stdout String+newtype Stdout = Stdout {fromStdout :: String}  -- | Collect the @stderr@ of the process. --   If you are collecting the @stderr@, it will not be echoed to the terminal, unless you include 'EchoStderr'.-newtype Stderr = Stderr String+newtype Stderr = Stderr {fromStderr :: String}  -- | Collect the 'ExitCode' of the process. --   If you do not collect the exit code, any 'ExitFailure' will cause an exception.-newtype Exit = Exit ExitCode+newtype Exit = Exit {fromExit :: ExitCode}  -- | A class for specifying what results you want to collect from a process. --   Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those.@@ -205,6 +205,9 @@  instance CmdResult Exit where     cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> Exit x)++instance CmdResult ExitCode where+    cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> x)  instance CmdResult Stdout where     cmdResult = ([ResultStdout ""], \[ResultStdout x] -> Stdout x)

@@ -14,7 +14,7 @@     Rule(..), Rules, defaultRule, rule, action, withoutActions,     Action, actionOnException, actionFinally, apply, apply1, traced,     getVerbosity, putLoud, putNormal, putQuiet, quietly,-    Resource, newResource, newResourceIO, withResource,+    Resource, newResource, newResourceIO, withResource, withResources,     -- Internal stuff     rulesIO, runAfter     ) where@@ -44,6 +44,7 @@ import Development.Shake.Report import Development.Shake.Types import Development.Shake.Errors+import Development.Shake.Timing   ---------------------------------------------------------------------@@ -252,13 +253,14 @@     let diagnostic = if shakeVerbosity >= Diagnostic then outputLocked Diagnostic . ("% "++) else const $ return ()     let output v = outputLocked v . abbreviate shakeAbbreviations -    except <- newVar (Nothing :: Maybe SomeException)+    except <- newIORef (Nothing :: Maybe (String, SomeException))     let staunch act | not shakeStaunch = act >> return ()                     | otherwise = do             res <- try act             case res of                 Left err -> do-                    modifyVar_ except $ \v -> return $ Just $ fromMaybe err v+                    let named = maybe "unknown rule" shakeExceptionTarget . cast+                    atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())                     let msg = show err ++ "Continuing due to staunch mode, this error will be repeated later"                     when (shakeVerbosity >= Quiet) $ output Quiet msg                 Right _ -> return ()@@ -273,28 +275,46 @@                 "Wanted: " ++ dir ++ "\n" ++                 "Got:    " ++ now -    let ruleinfo = createRuleinfo shakeAssume rs+    let ruleinfo = createRuleinfo rs     running <- newIORef True     after <- newIORef []-    flip finally (writeIORef running False) $ do-        withDatabase opts diagnostic $ \database -> do-            forkIO $ shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}-            runPool (shakeDeterministic || shakeThreads == 1) shakeThreads $ \pool -> do-                let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 []-                mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs)-            when shakeLint $ do-                checkValid database (runStored ruleinfo)-                when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"-            when (isJust shakeReport) $ do-                let file = fromJust shakeReport-                json <- showJSON database-                when (shakeVerbosity >= Normal) $-                    output Normal $ "Writing HTML report to " ++ file-                buildReport json file-        maybe (return ()) throwIO =<< readVar except-        sequence_ . reverse =<< readIORef after+    flip finally (writeIORef running False >> if shakeTimings then printTimings else resetTimings) $+        withCapabilities shakeThreads $ do+            withDatabase opts diagnostic $ \database -> do+                forkIO $ shakeProgress $ do+                    running <- readIORef running+                    failure <- fmap (fmap fst) $ readIORef except+                    stats <- progress database+                    return stats{isRunning=running, isFailure=failure}+                addTiming "Running rules"+                runPool (shakeDeterministic || shakeThreads == 1) shakeThreads $ \pool -> do+                    let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 []+                    mapM_ (addPool pool . staunch . runAction s0) (actions rs)+                when shakeLint $ do+                    addTiming "Lint checking"+                    checkValid database (runStored ruleinfo)+                    when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"+                when (isJust shakeReport) $ do+                    addTiming "Profile report"+                    let file = fromJust shakeReport+                    json <- showJSON database+                    when (shakeVerbosity >= Normal) $+                        output Normal $ "Writing HTML report to " ++ file+                    buildReport json file+            maybe (return ()) (throwIO . snd) =<< readIORef except+            sequence_ . reverse =<< readIORef after  +withCapabilities :: Int -> IO a -> IO a+#if __GLASGOW_HASKELL__ >= 706+withCapabilities new act = do+    old <- getNumCapabilities+    if old == new then act else+        bracket_ (setNumCapabilities new) (setNumCapabilities old) act+#else+withCapabilities new act = act+#endif+ lineBuffering :: IO a -> IO a lineBuffering = f stdout . f stderr     where@@ -318,10 +338,11 @@  wrapStack :: IO [String] -> IO a -> IO a wrapStack stk act = E.catch act $ \(SomeException e) -> case cast e of-    Just s@ShakeException{} -> throw s+    Just s@ShakeException{} -> throwIO s     Nothing -> do         stk <- stk-        throw $ ShakeException stk $ SomeException e+        if null stk then throwIO e+         else throwIO $ ShakeException (last stk) stk $ SomeException e   registerWitnesses :: SRules -> IO ()@@ -331,8 +352,8 @@         registerWitness $ ruleValue r  -createRuleinfo :: Maybe Assume -> SRules -> Map.HashMap TypeRep RuleInfo-createRuleinfo assume SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv+createRuleinfo :: SRules -> Map.HashMap TypeRep RuleInfo+createRuleinfo SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv     where         stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey             where f :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value))@@ -488,3 +509,15 @@         (runAction s act)     Action $ State.put s     return res+++-- | Run an action which uses part of several finite resources. Acquires the resources in a stable+--   order, to prevent deadlock. If all rules requiring more than one resource acquire those+--   resources with a single call to 'withResources', resources will not deadlock.+withResources :: [(Resource, Int)] -> Action a -> Action a+withResources res act+    | (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i+    | otherwise = f $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) res+    where+        f [] = act+        f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs

@@ -19,6 +19,7 @@ import Development.Shake.Locks import Development.Shake.Storage import Development.Shake.Types+import Development.Shake.Special import Development.Shake.Intern as Intern  import Control.Exception@@ -251,7 +252,10 @@                 Nothing -> err $ "interned value missing from database, " ++ show i                 Just (k, Missing) -> run stack i k Nothing                 Just (k, Loaded r) -> do-                    b <- if assume == Just AssumeDirty then return False else fmap (== Just (result r)) $ stored k+                    b <- case assume of+                        Just AssumeDirty -> return False+                        Just AssumeSkip -> return True+                        _ -> fmap (== Just (result r)) $ stored k                     diagnostic $ "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@@ -417,17 +421,11 @@         (key, Ready Result{..}) -> do             good <- fmap (== Just result) $ stored key             diagnostic $ "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 result)]+            return [show key ++ " is no longer " ++ show result | not good && not (specialAlwaysRebuilds result)]         _ -> return []     if null bad         then diagnostic "Validity/lint check passed"         else error $ unlines $ "Error: Dependencies have changed since being built:" : bad--    where-        -- special case for these things, since the purpose is to break the invariant-        -- FIXME: this is getting more and more hacky-        special k r = sk == "AlwaysRerunQ" || "OracleQ " `isPrefixOf` sk || sr == "FileA (FileTime 2147483647)"-            where sk = show k; sr = show r   ---------------------------------------------------------------------

@@ -11,7 +11,7 @@ import System.Process import System.Directory import System.Exit-import qualified Data.ByteString.Char8 as BS+import System.IO  import Development.Shake.Core import Development.Shake.File@@ -97,6 +97,9 @@ writeFileChanged name x = liftIO $ do     b <- doesFileExist name     if not b then writeFile name x else do-        orig <- BS.readFile name-        let new = BS.pack x-        when (orig /= new) $ BS.writeFile name new+        -- Cannot use ByteString here, since it has different line handling+        -- semantics on Windows+        b <- withFile name ReadMode $ \h -> do+            src <- hGetContents h+            return $! src /= x+        when b $ writeFile name x

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards #-}  -- | Errors seen by the user module Development.Shake.Errors(@@ -47,7 +47,7 @@   errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> a-errorNoRuleToBuildType tk k tv = structured (isOracle tk)+errorNoRuleToBuildType tk k tv = structured (specialIsOracleKey tk)     "Build system error - no _rule_ matches the _key_ type"     [("_Key_ type", Just $ show tk)     ,("_Key_ value", k)@@ -55,7 +55,7 @@     "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)+errorRuleTypeMismatch tk k tvReal tvWant = structured (specialIsOracleKey tk)     "Build system error - _rule_ used at the wrong _result_ type"     [("_Key_ type", Just $ show tk)     ,("_Key_ value", k)@@ -64,7 +64,7 @@     "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_+errorIncompatibleRules tk tv1 tv2 = if specialIsOracleKey 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)@@ -73,7 +73,7 @@  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) []+    | specialIsOracleKey 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)@@ -98,24 +98,25 @@     "Only one call to addOracle is allowed per question type"  -isOracle :: TypeRep -> Bool-isOracle t = con `elem` ["OracleQ","OracleA"]+-- Should be in Special, but then we get an import cycle+specialIsOracleKey :: TypeRep -> Bool+specialIsOracleKey t = con == "OracleQ"     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.+-- | Error representing all expected exceptions thrown by Shake.+--   Problems when executing rules will be raising 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+        {shakeExceptionTarget :: String -- ^ The target that was being built when the exception occured.+        ,shakeExceptionStack :: [String]  -- ^ The stack of targets, where the 'shakeExceptionTarget' is last.+        ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised.+        }     deriving Typeable  instance Exception ShakeException  instance Show ShakeException where-    show (ShakeException stack inner) = unlines $+    show ShakeException{..} = unlines $         "Error when running Shake build system:" :-        map ("* " ++) stack ++-        [show inner]+        map ("* " ++) shakeExceptionStack +++        [show shakeExceptionInner]

@@ -16,11 +16,13 @@ import Development.Shake.Core import Development.Shake.Types import Development.Shake.Classes-import Development.Shake.FilePath import Development.Shake.FilePattern import Development.Shake.FileTime import Development.Shake.Locks +import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong++ infix 1 *>, ?>, **>  @@ -131,6 +133,9 @@  -- | Declare a phony action, this is an action that does not produce a file, and will be rerun --   in every execution that requires it. You can demand 'phony' rules using 'want' \/ 'need'.+--+--   Phony actions are intended to define command-line abbreviations. You should not 'need' phony actions+--   as dependencies of rules, as that will cause excessive rebuilding. phony :: String -> Action () -> Rules () phony name act = rule $ \(FileQ x_) -> let x = unpack x_ in     if name /= x then Nothing else Just $ do

@@ -11,6 +11,7 @@ module Development.Shake.FilePath(     module System.FilePath.Posix,     dropDirectory1, takeDirectory1, normalise,+    (-<.>),     toNative, (</>), combine,     exe     ) where@@ -19,7 +20,10 @@ import qualified System.FilePath as Native import Data.List +infixr 5  </>+infixr 7  -<.> + -- | Drop the first directory from a 'FilePath'. Should only be used on --   relative paths. --@@ -66,6 +70,9 @@ (</>) :: FilePath -> FilePath -> FilePath (</>) = combine +-- | Remove the current extension and add another, an alias for 'replaceExtension'.+(-<.>) :: FilePath -> String -> FilePath+(-<.>) = replaceExtension  -- | Combine two file paths. Any leading @.\/@ or @..\/@ components in the right file --   are eliminated.

@@ -29,7 +29,7 @@ type WIN32_FILE_ATTRIBUTE_DATA = Ptr () type LPCSTR = Ptr CChar -foreign import stdcall "Windows.h GetFileAttributesExA" c_getFileAttributesEx :: LPCSTR -> Int32 -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import stdcall unsafe "Windows.h GetFileAttributesExA" c_getFileAttributesEx :: LPCSTR -> Int32 -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool  size_WIN32_FILE_ATTRIBUTE_DATA = 36 @@ -80,7 +80,7 @@         res <- c_getFileAttributesEx file 0 info         if not res then return Nothing else do             -- Technically a Word32, but we can treak it as an Int32 for peek-            dword <- peekByteOff info index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+            dword <- peekByteOff info index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: IO Int32             return $ Just $ fileTime dword  #else

@@ -36,7 +36,7 @@ -- -- @ -- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do---     let hs = 'Development.Shake.FilePath.replaceExtension' o \"hs\"+--     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\" --     'Development.Shake.need' ... -- all files the .hs import --     'Development.Shake.system'' \"ghc\" [\"-c\",hs] -- @

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-}  module Development.Shake.Locks(     Lock, newLock, withLock,@@ -8,6 +9,8 @@  import Control.Concurrent import Control.Monad+import Data.Function+import System.IO.Unsafe   ---------------------------------------------------------------------@@ -67,6 +70,14 @@ --------------------------------------------------------------------- -- RESOURCE +{-# NOINLINE resourceIds #-}+resourceIds :: Var Int+resourceIds = unsafePerformIO $ newVar 0++resourceId :: IO Int+resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)++ -- | A type representing a finite resource, which multiple build actions should respect. --   Created with 'Development.Shake.newResource' and used with 'Development.Shake.withResource' --   when defining rules.@@ -87,8 +98,9 @@ --   is better than 'MVar' as it will not block any other threads from executing. Be careful that the --   actions run within 'Development.Shake.withResource' do not themselves require further quantities of this resource, or --   you may get a \"thread blocked indefinitely in an MVar operation\" exception. Typically only---   system commands (such as 'Development.Shake.system'') will be run inside 'Development.Shake.withResource',---   not commands such as 'Development.Shake.need'.+--   system commands (such as 'Development.Shake.system'') should be run inside 'Development.Shake.withResource',+--   not commands such as 'Development.Shake.need'. If an action requires multiple resources, use+--   'Development.Shake.withResources' to avoid deadlock. -- --   As another example, calls to compilers are usually CPU bound but calls to linkers are usually --   disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit@@ -103,27 +115,31 @@ -- \"*.o\" 'Development.Shake.*>' \\out -> --     'Development.Shake.system'' \"cl\" [\"-o\",out,...] -- @-data Resource = Resource String Int (Var (Int,[(Int,IO ())]))-instance Show Resource where show (Resource name _ _) = "Resource " ++ name+data Resource = Resource {resourceKey :: Int, resourceName :: String, resourceMax :: Int, resourceVar :: Var (Int,[(Int,IO ())])}+instance Show Resource where show Resource{..} = "Resource " ++ resourceName +instance Eq Resource where (==) = (==) `on` resourceKey+instance Ord Resource where compare = compare `on` resourceKey + -- | A version of 'newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'. --   Most people should use 'Development.Shake.newResource' instead. newResourceIO :: String -> Int -> IO Resource newResourceIO name mx = do     when (mx < 0) $         error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx+    key <- resourceId     var <- newVar (mx, [])-    return $ Resource name mx var+    return $ Resource key name mx var   -- | Try to acquire a resource. Returns Nothing to indicate you have acquired with no blocking, or Just act to --   say after act completes (which will block) then you will have the resource. acquireResource :: Resource -> Int -> IO (Maybe (IO ()))-acquireResource r@(Resource name mx var) want+acquireResource r@Resource{..} want     | want < 0 = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show want-    | want > mx = error $ "You cannot acquire more than " ++ show mx ++ " of " ++ show r ++ ", requested " ++ show want-    | otherwise = modifyVar var $ \(available,waiting) ->+    | want > resourceMax = error $ "You cannot acquire more than " ++ show resourceMax ++ " of " ++ show r ++ ", requested " ++ show want+    | otherwise = modifyVar resourceVar $ \(available,waiting) ->         if want <= available then             return ((available - want, waiting), Nothing)         else do@@ -133,7 +149,7 @@  -- | You should only ever releaseResource that you obtained with acquireResource. releaseResource :: Resource -> Int -> IO ()-releaseResource (Resource name mx var) i = modifyVar_ var $ \(available,waiting) -> f (available+i) waiting+releaseResource Resource{..} i = modifyVar_ resourceVar $ \(available,waiting) -> f (available+i) waiting     where         f i ((wi,wa):ws) | wi <= i = wa >> f (i-wi) ws                          | otherwise = do (i,ws) <- f i ws; return (i,(wi,wa):ws)

@@ -33,6 +33,7 @@ --   status messages, which is implemented using this data type. data Progress = Progress     {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.+    ,isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' if a rule fails.     ,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.@@ -45,9 +46,10 @@     deriving (Eq,Ord,Show,Data,Typeable)  instance Monoid Progress where-    mempty = Progress True 0 0 0 0 0 0 0 (0,0)+    mempty = Progress True Nothing 0 0 0 0 0 0 0 (0,0)     mappend a b = Progress         {isRunning = isRunning a && isRunning b+        ,isFailure = isFailure a `mappend` isFailure b         ,countSkipped = countSkipped a + countSkipped b         ,countBuilt = countBuilt a + countBuilt b         ,countUnknown = countUnknown a + countUnknown b@@ -112,7 +114,7 @@                 disp "Finished"              else do                 (t, msg) <- return $ tick p t-                disp msg+                disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)                 loop $! t  

@@ -3,6 +3,7 @@ module Development.Shake.Shake(shake) where  import Development.Shake.Types+import Development.Shake.Timing import Development.Shake.Core  import Development.Shake.Directory@@ -17,6 +18,7 @@ --   To use command line flags to modify 'ShakeOptions' see 'Development.Shake.shakeArgs'. shake :: ShakeOptions -> Rules () -> IO () shake opts r = do+    addTiming "Function shake"     run opts $ do         r         defaultRuleFile

@@ -0,0 +1,21 @@++-- | This module contains rule types that have special behaviour in some way.+--   Everything in this module is a hack.+module Development.Shake.Special(+    specialAlwaysRebuilds,+    specialIsFileKey+    ) where++import Development.Shake.Value+import Data.List+import Data.Typeable+++specialAlwaysRebuilds :: Value -> Bool+specialAlwaysRebuilds v = sv == "AlwaysRerunA" || "OracleA " `isPrefixOf` sv || sv == "FileA (FileTime 2147483647)"+    where sv = show v+++specialIsFileKey :: TypeRep -> Bool+specialIsFileKey t = con == "FileQ"+    where con = show $ fst $ splitTyConApp t

@@ -12,6 +12,7 @@ import Development.Shake.Binary import Development.Shake.Locks import Development.Shake.Types+import Development.Shake.Timing  import Control.Arrow import Control.Exception as E@@ -61,6 +62,7 @@         E.catch (removeFile dbfile) (\(e :: SomeException) -> return ())         renameFile bupfile dbfile +    addTiming "Database read"     withBinaryFile dbfile ReadWriteMode $ \h -> do         n <- hFileSize h         diagnostic $ "Reading file of size " ++ show n@@ -120,6 +122,7 @@                                 diagnostic $ "Drop complete"                             return $ continue h mp                          else do+                            addTiming "Database compression"                             unexpected "Compressing database\n"                             diagnostic "Compressing database"                             hClose h -- two hClose are fine@@ -158,7 +161,9 @@         continue h mp = do             when (Map.null mp) $                 reset h mp -- might as well, no data to lose, and need to ensure a good witness table-            flushThread outputErr shakeFlush h $ \out ->+                           -- also lets us recover in the case of corruption+            flushThread outputErr shakeFlush h $ \out -> do+                addTiming "With database"                 act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v)  

@@ -0,0 +1,58 @@++module Development.Shake.Timing(resetTimings, addTiming, printTimings) where++import Control.Arrow+import Data.IORef+import Data.Time+import System.IO.Unsafe+import Numeric+++{-# NOINLINE timings #-}+timings :: IORef [(UTCTime, String)] -- number of times called, newest first+timings = unsafePerformIO $ newIORef []+++resetTimings :: IO ()+resetTimings = do+    now <- getCurrentTime+    writeIORef timings [(now, "Start")]+++-- | Print all withTiming information and clear the information.+printTimings :: IO ()+printTimings = do+    now <- getCurrentTime+    old <- atomicModifyIORef timings $ \ts -> ([(now, "Start")], ts)+    putStr $ unlines $ showTimings now $ reverse old+++addTiming :: String -> IO ()+addTiming msg = do+    now <- getCurrentTime+    atomicModifyIORef timings $ \ts -> ((now,msg):ts, ())+++showTimings :: UTCTime -> [(UTCTime, String)] -> [String]+showTimings _ [] = []+showTimings stop times = showGap $+    [(a ++ "  ", showDP 3 b ++ "s  " ++ showPerc b ++ "  " ++ progress b) | (a,b) <- xs] +++    [("Total", showDP 3 sm ++ "s  " ++ showPerc sm ++ "  " ++ replicate 25 ' ')]+    where+        a // b = if b == 0 then 0 else a / b+        showPerc x = let s = show $ floor $ x * 100 // sm in replicate (3 - length s) ' ' ++ s ++ "%"+        progress x = let i = floor $ x * 25 // mx in replicate i '=' ++ replicate (25-i) ' '+        mx = maximum $ map snd xs+        sm = sum $ map snd xs+        xs = [ (name, fromRational $ toRational $ stop `diffUTCTime` start)+             | ((start, name), stop) <- zip times $ map fst (drop 1 times) ++ [stop]]+++showGap :: [(String,String)] -> [String]+showGap xs = [a ++ replicate (n - length a - length b) ' ' ++ b | (a,b) <- xs]+    where n = maximum [length a + length b | (a,b) <- xs]+++showDP :: Int -> Double -> String+showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'+    where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""

@@ -27,10 +27,14 @@         --   for rebuilding if untracked dependencies have changed. This assumption is safe, but may cause         --   more rebuilding than necessary.     | AssumeClean-        -- ^ /This assumption is unsafe, and may lead to incorrect build results/.-        --   Assume that all rules reached are clean and do not require rebuilding, provided the rule+        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run, and in future runs/.+        --   Assume and record that all rules reached are clean and do not require rebuilding, provided the rule         --   has a 'Development.Shake.storedValue' and has been built before. Useful if you have modified a file in some         --   inconsequential way, such as only the comments or whitespace, and wish to avoid a rebuild.+    | AssumeSkip+        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run/.+        --   Assume that all rules reached are clean in this run. Only useful for benchmarking, to remove any overhead+        --   from running 'Development.Shake.storedValue' operations.     deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum)  @@ -39,7 +43,7 @@ -- --   @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just \"report.html\"} @ -----   The 'Data' instance for this type reports the 'shakeProgress' field as having the abstract type 'Function',+--   The 'Data' instance for this type reports the 'shakeProgress' and 'shakeOutput' fields as having the abstract type 'Function', --   because 'Data' cannot be defined for functions. data ShakeOptions = ShakeOptions     {shakeFiles :: FilePath@@ -86,6 +90,8 @@         --   on the current stored progress. Examples include database version number changes, database compaction or corrupt files.     ,shakeLineBuffering :: Bool         -- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake.+    ,shakeTimings :: Bool+        -- ^ Default to 'False'. Print timing information for each stage at the end.     ,shakeProgress :: IO Progress -> IO ()         -- ^ 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@@ -99,21 +105,22 @@  -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False False (Just 10) Nothing [] False True (const $ return ())+shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False False (Just 10) Nothing [] False True False+    (const $ return ())     (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS  fieldsShakeOptions =     ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"     ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"-    ,"shakeLineBuffering","shakeProgress","shakeOutput"]+    ,"shakeLineBuffering", "shakeTimings", "shakeProgress", "shakeOutput"] 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 x12 x13 x14 x15 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 (fromFunction x14) (fromFunction x15)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 (fromFunction x15) (fromFunction x16)  instance Data ShakeOptions where-    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15) =-        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` x12 `k` x13 `k` Function x14 `k` Function x15-    gunfold k z c = k $ k $ k $ k $ 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 x13 x14 x15 x16) =+        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` x12 `k` x13 `k` x14 `k` Function x15 `k` Function x16+    gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide     toConstr ShakeOptions{} = conShakeOptions     dataTypeOf _ = tyShakeOptions 

@@ -40,30 +40,30 @@             cmd "ghc" flags args      obj "/*.exe" *> \out -> do-        src <- readFileLines $ replaceExtension out "deps"+        src <- readFileLines $ out -<.> "deps"         let os = map (obj . moduleToFile "o") $ "Main":src         need os         ghc $ ["-o",out] ++ os      obj "/*.deps" *> \out -> do-        dep <- readFileLines $ replaceExtension out "dep"+        dep <- readFileLines $ out -<.> "dep"         let xs = map (obj . moduleToFile "deps") dep         need xs         ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs         writeFileLines out ds      obj "/*.dep" *> \out -> do-        src <- readFile' $ fixPaths $ unobj $ replaceExtension out "hs"+        src <- readFile' $ fixPaths $ unobj $ out -<.> "hs"         let xs = hsImports src         xs <- filterM (doesFileExist . fixPaths . moduleToFile "hs") xs         writeFileLines out xs      obj "/*.hi" *> \out -> do-        need [replaceExtension out "o"]+        need [out -<.> "o"]      obj "/*.o" *> \out -> do-        dep <- readFileLines $ replaceExtension out "dep"-        let hs = fixPaths $ unobj $ replaceExtension out "hs"+        dep <- readFileLines $ out -<.> "dep"+        let hs = fixPaths $ unobj $ out -<.> "hs"         need $ hs : map (obj . moduleToFile "hi") dep         ghc ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] 

@@ -20,7 +20,7 @@ test build obj = do     writeFile (obj "trace.txt") ""     writeFile (obj "vowels.txt") "abc123a"-    build ["vowels.out1","vowels.out2","-j3"]+    build ["vowels.out1","vowels.out2","-j3","--sleep"]     assertContents (obj "trace.txt") "1"     assertContents (obj "vowels.out1") "3"     assertContents (obj "vowels.out2") "3"

@@ -78,7 +78,7 @@      obj "Success.txt" *> \out -> do         need [obj "Main.hs"]-        system' "runhaskell" ["-hide-package=hashmap","-i" ++ obj "",obj "Main.hs"]+        system' "runhaskell" ["-ignore-package=hashmap","-i" ++ obj "",obj "Main.hs"]         writeFile' out ""  

@@ -18,8 +18,7 @@     want $ map obj ["a.out","b.out","c.out"]     obj "*.out" *> \out -> do         liftIO $ atomicModifyIORef rebuilt $ \a -> (a+1,())-        let src = replaceExtension out "in"-        copyFile' src out+        copyFile' (out -<.> "in") out   test build obj = do

@@ -23,12 +23,17 @@         () <- askOracle ()         writeFile' out "" +    obj "pause.*" *> \out -> do+        liftIO $ sleep 0.1+        need [obj "cdir" <.> takeExtension out]+        writeFile' out ""+     obj "cdir.*" *> \out -> do         pwd <- liftIO getCurrentDirectory         let dir2 = obj $ "dir" ++ takeExtension out         liftIO $ createDirectoryIfMissing True dir2         liftIO $ setCurrentDirectory dir2-        liftIO $ sleep 0.1+        liftIO $ sleep 0.2         liftIO $ setCurrentDirectory pwd         writeFile' out "" @@ -58,6 +63,7 @@      crash ["changedir"] ["current directory has changed"]     build ["cdir.1","cdir.2","-j1"]-    crash ["--clean","cdir.1","cdir.2","-j2"] ["current directory has changed"]+    build ["--clean","cdir.1","pause.2","-j1"]+    crash ["--clean","cdir.1","pause.2","-j2"] ["current directory has changed"]     crash ["existance"] ["changed since being built"]     crash ["createtwice"] ["changed since being built"]

@@ -3,7 +3,7 @@  import Development.Shake(action, liftIO) import Development.Shake.FilePath-import qualified Development.Make.Main as Makefile+import qualified Start as Makefile import System.Environment import System.Directory import Examples.Util@@ -14,7 +14,9 @@  main = shaken test $ \args obj ->     action $ liftIO $ do-        withArgs [fromMaybe x $ stripPrefix "@" x | x <- args] Makefile.main+        unless (["@@"] `isPrefixOf` args) $+            error "The 'makefile' example should only be used in test mode, to test using a makefile use the 'make' example."+        withArgs [fromMaybe x $ stripPrefix "@" x | x <- drop 1 args] Makefile.main   test build obj = do@@ -26,6 +28,6 @@                     copyFile (from </> x) (obj to </> x)      copyTo "Examples/MakeTutor" "MakeTutor"-    build ["--directory=" ++ obj "MakeTutor","--no-report"]-    build ["--directory=" ++ obj "MakeTutor","--no-report"]-    build ["--directory=" ++ obj "MakeTutor","@clean","--no-report"]+    build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]+    build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]+    build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]

@@ -14,6 +14,8 @@     flip (shaken test) extra $ \args obj -> do         want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"]         res <- newResource "test" cap+        res2 <- newResource "test" cap+        unless (res < res2 || res2 < res) $ error "Resources should have a good ordering"         obj "*.txt" *> \out ->             withResource res 1 $ do                 old <- liftIO $ atomicModifyIORef ref $ \i -> (i+1,i)

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2011-2012.+Copyright Neil Mitchell 2011-2013. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,4 +1,4 @@  module Main(main) where -import Development.Make.Main(main)+import Start

@@ -3,9 +3,20 @@ module Paths_shake where  import Data.Version+import System.IO.Unsafe+import System.Directory+import Control.Exception ++-- We want getDataFileName to be relative to the current directory even if+-- we issue a change directory command. Therefore, first call caches, future ones read.+curdir :: String+curdir = unsafePerformIO getCurrentDirectory+ getDataFileName :: FilePath -> IO FilePath-getDataFileName x = return $ "./" ++ x+getDataFileName x = do+    evaluate curdir+    return $ curdir ++ "/" ++ x  version :: Version version = Version {versionBranch = [0,0], versionTags = []}

@@ -0,0 +1,42 @@++module Start(main) where++import Development.Make.All+import Development.Ninja.All+import System.Environment+import Development.Shake+import Development.Shake.FilePath+import Development.Shake.Timing+import qualified System.Directory as IO+import System.Console.GetOpt+++main :: IO ()+main = do+    resetTimings+    args <- getArgs+    withArgs ("--no-time":args) $+        shakeArgsWith shakeOptions flags $ \opts targets -> do+            makefile <- case reverse [x | UseMakefile x <- opts] of+                x:_ -> return x+                _ -> findMakefile+            if takeExtension makefile == ".ninja" then+                fmap Just $ runNinja makefile targets+             else+                fmap Just $ runMakefile makefile targets+++data Flag = UseMakefile FilePath++flags = [Option "f" ["file","makefile"] (ReqArg (Right . UseMakefile) "FILE") "Read FILE as a makefile."]+++findMakefile :: IO FilePath+findMakefile = do+    b <- IO.doesFileExist "makefile"+    if b then return "makefile" else do+        b <- IO.doesFileExist "Makefile"+        if b then return "Makefile" else do+            b <- IO.doesFileExist "build.ninja"+            if b then return "build.ninja" else+                error "Could not find `makefile', `Makefile' or `build.ninja'"

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  module Main(main) where @@ -7,8 +8,12 @@ import Data.Maybe import System.Environment import Development.Shake.Pool-+import Development.Shake.Timing+import Development.Shake.FileTime+import qualified Data.ByteString.Char8 as BS import Examples.Util(sleepFileTime)+import Control.Concurrent+ import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self import qualified Examples.C.Main as C@@ -32,10 +37,10 @@ import qualified Examples.Test.Random as Random import qualified Examples.Test.Resources as Resources -import qualified Development.Make.Main as Make+import qualified Start as Start  -fakes = ["clean" * clean, "test" * test, "make" * makefile]+fakes = ["clean" * clean, "test" * test, "make" * makefile, "filetime" * filetime]     where (*) = (,)  mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main@@ -51,7 +56,13 @@  main :: IO () main = do+    resetTimings     xs <- getArgs+#if __GLASGOW_HASKELL__ >= 706+    exePath <- getExecutablePath+#else+    exePath <- getProgName+#endif     case flip lookup (fakes ++ mains) =<< listToMaybe xs of         Nothing -> putStrLn $ unlines             ["Welcome to the Shake demo"@@ -61,7 +72,7 @@             ,""             ,"As an example, try:"             ,""-            ,"  main self --threads2 --loud"+            ,unwords ["  ", exePath, "self",  "--jobs=2", "--trace"]             ,""             ,"Which will build Shake, using Shake, on 2 threads."]         Just main -> main sleepFileTime@@ -70,7 +81,29 @@ makefile :: IO () -> IO () makefile _ = do     args <- getArgs-    withArgs (drop 1 args) Make.main+    withArgs (drop 1 args) Start.main+++filetime :: IO () -> IO ()+filetime _ = do+    args <- getArgs+    addTiming "Reading files"+    files <- fmap concat $ forM (drop 1 args) $ \file ->+        fmap (BS.lines . BS.filter (/= '\r')) $ BS.readFile file+    let n = length files+    evaluate n+    addTiming "Modtime"+    let (a,bcd) = splitAt (n `div` 4) files+    let (b,cd) = splitAt (n `div` 4) bcd+    let (c,d) = splitAt (n `div` 4) cd+    vars <- forM [a,b,c,d] $ \xs -> do+        mvar <- newEmptyMVar+        forkIO $ do+            mapM_ getModTimeMaybe xs+            putMVar mvar ()+        return $ takeMVar mvar+    sequence_ vars+    printTimings   clean :: IO () -> IO ()

@@ -1,7 +1,7 @@ cabal-version:      >= 1.8 build-type:         Simple name:               shake-version:            0.10.3+version:            0.10.4 license:            BSD3 license-file:       LICENSE category:           Development@@ -121,7 +121,9 @@         Development.Shake.Report         Development.Shake.Rerun         Development.Shake.Shake+        Development.Shake.Special         Development.Shake.Storage+        Development.Shake.Timing         Development.Shake.Types         Development.Shake.Value         Paths_shake@@ -129,6 +131,7 @@  executable shake     main-is: Main.hs+    ghc-options: -threaded     build-depends:         base == 4.*,         old-time,@@ -151,11 +154,15 @@             build-depends: unix >= 2.5.1      other-modules:+        Development.Make.All         Development.Make.Env-        Development.Make.Main         Development.Make.Parse         Development.Make.Rules         Development.Make.Type+        Development.Ninja.All+        Development.Ninja.Parse+        Development.Ninja.Type+        Start   executable shake-test@@ -164,6 +171,7 @@         buildable: True     else         buildable: False+    ghc-options: -threaded     build-depends:         base == 4.*,         old-time,@@ -186,11 +194,14 @@             build-depends: unix >= 2.5.1      other-modules:+        Development.Make.All         Development.Make.Env-        Development.Make.Main         Development.Make.Parse         Development.Make.Rules         Development.Make.Type+        Development.Ninja.All+        Development.Ninja.Parse+        Development.Ninja.Type         Examples.Util         Examples.C.Main         Examples.Self.Main@@ -214,3 +225,4 @@         Examples.Test.Progress         Examples.Test.Random         Examples.Test.Resources+        Start