shake 0.10.5 → 0.10.6

raw patch · 34 files changed

+354/−158 lines, 34 files

Files

• Development/Ninja/All.hs +29/−23
• Development/Ninja/Env.hs +36/−0
• Development/Ninja/Parse.hs +36/−30
• Development/Ninja/Type.hs +14/−22
• Development/Shake.hs +7/−2
• Development/Shake/Args.hs +11/−5
• Development/Shake/Command.hs +2/−4
• Development/Shake/Core.hs +3/−3
• Development/Shake/Derived.hs +8/−2
• Development/Shake/Directory.hs +6/−0
• Development/Shake/File.hs +3/−3
• Development/Shake/Files.hs +1/−1
• Development/Shake/Locks.hs +4/−4
• Development/Shake/Oracle.hs +2/−2
• Development/Shake/Rerun.hs +1/−1
• Development/Shake/Sys.hs +1/−1
• Examples/C/Main.hs +0/−1
• Examples/Ninja/Main.hs +41/−0
• Examples/Ninja/test1.ninja +5/−0
• Examples/Ninja/test2.ninja +8/−0
• Examples/Ninja/test3-inc.ninja +3/−0
• Examples/Ninja/test3-sub.ninja +6/−0
• Examples/Ninja/test3-unix.ninja +3/−0
• Examples/Ninja/test3-win.ninja +3/−0
• Examples/Ninja/test3.ninja +21/−0
• Examples/Self/Main.hs +0/−1
• Examples/Tar/Main.hs +1/−1
• Examples/Test/Command.hs +0/−1
• Examples/Test/Docs.hs +9/−4
• Examples/Test/Errors.hs +1/−1
• Examples/Test/Random.hs +66/−44
• Examples/Util.hs +17/−0
• Test.hs +2/−1
• shake.cabal +4/−1

@@ -2,10 +2,10 @@ 
 module Development.Ninja.All(runNinja) where
 
+import Development.Ninja.Env
 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
@@ -29,13 +29,16 @@         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
+        want $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $
+            if not $ null args then map BS.pack args
+            else if not $ null defaults then defaults
+            else Map.keys singles ++ Map.keys multiples
 
         (\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
+            build 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
+            build phonys rules pools [out2] $ singles Map.! out2
 
 
 resolvePhony :: Map.HashMap Str [Str] -> Str -> [Str]
@@ -48,24 +51,27 @@             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
+build :: Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action ()
+build 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
+            env <- liftIO $ scopeEnv env
+            liftIO $ do
+                -- the order of adding new environment variables matters
+                addEnv env (BS.pack "out") (BS.unwords out)
+                addEnv env (BS.pack "in") (BS.unwords depsNormal)
+                addEnv env (BS.pack "in_newline") (BS.unlines depsNormal)
+                addBinds env buildBind
+                addBinds env ruleBind
 
             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"
+                commandline <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "command"
+                depfile <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "depfile"
+                deps <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "deps"
+                description <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "description"
+                pool <- liftIO $ askVar env $ BS.pack "pool"
 
                 let withPool act = case Map.lookup pool pools of
                         _ | BS.null pool -> act
@@ -85,17 +91,17 @@                     when (deps == "gcc") $ liftIO $ removeFile depfile
 
 
-applyRspfile :: Env -> Action a -> Action a
-applyRspfile env act
-    | rspfile == "" = act
-    | otherwise = do
+applyRspfile :: Env Str Str -> Action a -> Action a
+applyRspfile env act = do
+    rspfile <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "rspfile"
+    rspfile_content <- liftIO $ askVar env $ BS.pack "rspfile_content"
+    if rspfile == "" then
+        act
+     else 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]

@@ -0,0 +1,36 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++-- | A Ninja style environment, basically a linked-list of mutable hash tables.+module Development.Ninja.Env(+    Env, newEnv, scopeEnv, addEnv, askEnv+    ) where++import qualified Data.HashMap.Strict as Map+import Data.Hashable+import Data.IORef+++data Env k v = Env (IORef (Map.HashMap k v)) (Maybe (Env k v))++instance Show (Env k v) where show _ = "Env"+++newEnv :: IO (Env k v)+newEnv = do ref <- newIORef Map.empty; return $ Env ref Nothing+++scopeEnv :: Env k v -> IO (Env k v)+scopeEnv e = do ref <- newIORef Map.empty; return $ Env ref $ Just e+++addEnv :: (Eq k, Hashable k) => Env k v -> k -> v -> IO ()+addEnv (Env ref _) k v = modifyIORef ref $ Map.insert k v+++askEnv :: (Eq k, Hashable k) => Env k v -> k -> IO (Maybe v)+askEnv (Env ref e) k = do+    mp <- readIORef ref+    case Map.lookup k mp of+        Just v -> return $ Just v+        Nothing | Just e <- e -> askEnv e k+        _ -> return Nothing

@@ -4,8 +4,8 @@ module Development.Ninja.Parse(parse) where
 
 import qualified Data.ByteString.Char8 as BS
+import Development.Ninja.Env
 import Development.Ninja.Type
-import Control.Arrow
 import Control.Monad
 import Data.Char
 import Data.Maybe
@@ -36,13 +36,13 @@ isVar x = isAlphaNum x || x == '_'
 
 parse :: FilePath -> IO Ninja
-parse file = parseFile file newNinja
+parse file = do env <- newEnv; parseFile file env newNinja
 
 
-parseFile :: FilePath -> Ninja -> IO Ninja
-parseFile file ninja = do
+parseFile :: FilePath -> Env Str Str -> Ninja -> IO Ninja
+parseFile file env ninja = do
     src <- if file == "-" then BS.getContents else BS.readFile file
-    foldM applyStmt ninja $ splitStmts src
+    foldM (applyStmt env) ninja $ splitStmts src
 
 
 data Stmt = Stmt Str [Str] deriving Show
@@ -61,41 +61,47 @@             where (a,b) = span startsSpace xs
 
 
-applyStmt :: Ninja -> Stmt -> IO Ninja
-applyStmt ninja@Ninja{..} (Stmt x xs)
+applyStmt :: Env Str Str -> Ninja -> Stmt -> IO Ninja
+applyStmt env 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 $
+    | key == BS.pack "default" = do
+        xs <- parseStrs env rest
+        return ninja{defaults = xs ++ defaults}
+    | key == BS.pack "pool" = do
+        depth <- getDepth env $ parseBinds xs
+        return ninja{pools = (BS.takeWhile isVar rest, depth) : pools}
+    | key == BS.pack "build" = do
+        (out,rest) <- return $ splitColon rest
+        outputs <- parseStrs env out
+        (rule,deps) <- return $ word1 $ dropSpace rest
+        (normal,implicit,orderOnly) <- fmap splitDeps $ parseStrs env deps
+        let build = Build rule env 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 "include" = parseFile (BS.unpack rest) env 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}
+        e <- scopeEnv env
+        parseFile (BS.unpack rest) e ninja
+    | Just (a,b) <- parseBind x = do
+        addBind env a b
+        return ninja
     | 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
+getDepth :: Env Str Str -> [(Str, Expr)] -> IO Int
+getDepth env xs = case lookup (BS.pack "depth") xs of
+    Nothing -> return 1
+    Just x -> do
+        x <- askExpr env x
+        case BS.readInt x of
+            Just (i, n) | BS.null n -> return i
+            _ -> error $ "Could not parse depth field in pool, got: " ++ BS.unpack x
 
 
 parseBind :: Str -> Maybe (Str, Expr)
@@ -129,8 +135,8 @@                 | otherwise -> let (a,b) = BS.span isVar x in Var a : f b
 
 
-parseStrs :: Env -> Str -> [Str]
-parseStrs env = map (askExpr env) . parseExprs
+parseStrs :: Env Str Str -> Str -> IO [Str]
+parseStrs env = mapM (askExpr env) . parseExprs
 
 
 

@@ -8,8 +8,8 @@     Ninja(..), newNinja, Build(..), Rule(..),     ) where +import Development.Ninja.Env import qualified Data.ByteString.Char8 as BS-import qualified Data.HashMap.Strict as Map import Data.Maybe  @@ -18,40 +18,31 @@   ------------------------------------------------------------------------ ENVIRONMENT--newtype Env = Env (Map.HashMap Str Str) deriving Show+-- EXPRESSIONS AND BINDINGS  data Expr = Exprs [Expr] | Lit Str | Var Str deriving Show -newEnv :: Env-newEnv = Env Map.empty--askExpr :: Env -> Expr -> Str+askExpr :: Env Str Str -> Expr -> IO Str askExpr e = f-    where f (Exprs xs) = BS.concat $ map f xs-          f (Lit x) = x+    where f (Exprs xs) = fmap BS.concat $ mapM f xs+          f (Lit x) = return 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+askVar :: Env Str Str -> Str -> IO Str+askVar e x = fmap (fromMaybe BS.empty) $ askEnv e x -addBind :: Str -> Expr -> Env -> Env-addBind k v env = addEnv k (askExpr env v) env+addBind :: Env Str Str -> Str -> Expr -> IO ()+addBind e k v = addEnv e k =<< askExpr e v -addBinds :: [(Str, Expr)] -> Env -> Env-addBinds kvs e = foldl (\e (k,v) -> addBind k v e) e kvs+addBinds :: Env Str Str -> [(Str, Expr)] -> IO ()+addBinds e = mapM_ (uncurry $ addBind e)   --------------------------------------------------------------------- -- STRUCTURE  data Ninja = Ninja-    {defines :: !Env-    ,rules :: [(Str,Rule)]+    {rules :: [(Str,Rule)]     ,singles :: [(FileStr,Build)]     ,multiples :: [([FileStr], Build)]     ,phonys :: ([(Str, [FileStr])])@@ -61,10 +52,11 @@     deriving Show  newNinja :: Ninja-newNinja = Ninja newEnv [] [] [] [] [] []+newNinja = Ninja [] [] [] [] [] []  data Build = Build     {ruleName :: Str+    ,env :: Env Str Str     ,depsNormal :: [FileStr]     ,depsImplicit :: [FileStr]     ,depsOrderOnly :: [FileStr]

@@ -12,7 +12,7 @@ --    \"*.tar\" '*>' \\out -> do --        contents \<- 'readFileLines' $ out 'Development.Shake.FilePath.-<.>' \"txt\" --        'need' contents---        'system'' \"tar\" $ [\"-cf\",out] ++ contents+--        'cmd' \"tar -cf\" [out] contents -- @ -- --   We start by importing the modules defining both Shake and routines for manipulating 'FilePath' values.@@ -29,7 +29,7 @@ --   change, then @result.tar@ will be rebuilt. -- --   When writing a Shake build system, start by defining what you 'want', then write rules---   with '*>' to produce the results. Before calling 'system'' you should ensure that any files the command+--   with '*>' to produce the results. Before calling 'cmd' you should ensure that any files the command --   requires are demanded with calls to 'need'. We offer the following advice to Shake users: -- -- * If @ghc --make@ or @cabal@ is capable of building your project, use that instead. Custom build systems are@@ -78,6 +78,10 @@     Progress(..), progressSimple, progressDisplay, progressTitlebar,     -- ** Verbosity     Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, quietly,+    -- * Running commands+    command, command_, cmd,+    Stdout(..), Stderr(..), Exit(..),+    CmdResult, CmdOption(..),     -- * Utility functions     module Development.Shake.Derived,     removeFiles, removeFilesAfter,@@ -111,6 +115,7 @@ import Development.Shake.Args import Development.Shake.Shake +import Development.Shake.Command import Development.Shake.Directory import Development.Shake.File import Development.Shake.FilePattern

@@ -20,6 +20,7 @@ import Data.List import Data.Maybe import Data.Time+import Data.Version(showVersion) import System.Console.GetOpt import System.Directory import System.Environment@@ -94,7 +95,7 @@ --     let compiler = if DistCC \`elem\` flags then \"distcc\" else \"gcc\" --     \"*.o\" '*>' \\out -> do --         'need' ...---         'Development.Shake.system'' compiler ...+--         'cmd' compiler ... --     ... -- @ --@@ -125,7 +126,7 @@     if Help `elem` flagsExtra then do         showHelp      else if Version `elem` flagsExtra then-        putStrLn $ "Shake build system, version " ++ show version+        putStrLn $ "Shake build system, version " ++ showVersion version      else do         when (Sleep `elem` flagsExtra) $ threadDelay 1000000         start <- getCurrentTime@@ -149,9 +150,12 @@          else             let esc code = if Color `elem` flagsExtra then escape code else id             in case res of-                Left err -> do-                    putStrLn $ esc "31" $ show (err :: SomeException)-                    exitFailure+                Left err ->+                    if Exception `elem` flagsExtra then+                        throw err+                    else do+                        putStrLn $ esc "31" $ show (err :: SomeException)+                        exitFailure                 Right () -> do                     stop <- getCurrentTime                     let tot = diffUTCTime stop start@@ -204,6 +208,7 @@            | Help            | Sleep            | NoTime+           | Exception              deriving Eq  @@ -224,6 +229,7 @@     ,no  $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything."     ,yes $ Option ""  ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output."     ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."+    ,no  $ Option ""  ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."     ,yes $ Option ""  ["flush"] (intArg "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."     ,yes $ Option ""  ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."     ,no  $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."

@@ -1,9 +1,7 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} --- | /Future plans: I intend to merge this module into "Development.Shake" itself./------   This module provides more powerful and flexible versions of 'Development.Shake.system''.---   I recommend looking at 'command', followed by 'cmd'.+-- | /Deprecated:/ This module should no longer be imported as all the functions are available directly+--   from "Development.Shake". In future versions this module will be removed. module Development.Shake.Command(     command, command_, cmd,     Stdout(..), Stderr(..), Exit(..),

@@ -434,8 +434,8 @@   -- | Write an action to the trace list, along with the start/end time of running the IO action.---   The 'Develoment.Shake.system'' command automatically calls 'traced'. The trace list is used for profile reports---   (see 'shakeReport').+--   The 'Develoment.Shake.cmd' and 'Develoment.Shake.command' functions automatically call 'traced'.+--   The trace list is used for profile reports (see 'shakeReport'). traced :: String -> IO a -> Action a traced msg act = do     s <- Action State.get@@ -481,7 +481,7 @@   -- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'---   (including from 'Development.Shake.system'') will not be printed to the screen.+--   (including from 'Development.Shake.cmd' or 'Development.Shake.command') will not be printed to the screen. quietly :: Action a -> Action a quietly = withVerbosity Quiet 

@@ -35,7 +35,10 @@     checkExitCode cmd res  --- | Execute a system command with a specified current working directory (first argument).+-- | /Deprecated:/ Please use 'command' or 'cmd' instead, with 'Cwd'.+--   This function will be removed in a future version.+--+--   Execute a system command with a specified current working directory (first argument). --   This function will raise an error if the exit code is non-zero. --   Before running 'systemCwd' make sure you 'need' any required files. --@@ -55,7 +58,10 @@     checkExitCode cmd res  --- | Execute a system command, returning @(stdout,stderr)@.+-- | /Deprecated:/ Please use 'command' or 'cmd' instead, with 'Stdout' or 'Stderr'.+--   This function will be removed in a future version.+--+--   Execute a system command, returning @(stdout,stderr)@. --   This function will raise an error if the exit code is non-zero. --   Before running 'systemOutput' make sure you 'need' any required files. systemOutput :: FilePath -> [String] -> Action (String, String)

@@ -173,6 +173,12 @@ -- > getDirectoryFiles "Modules" ["*.hs","*.lhs"] -- >     -- All .hs or .lhs in the Modules directory -- >     -- If Modules/foo.hs and Modules/foo.lhs exist, it will return ["foo.hs","foo.lhs"]+--+--   If you require a qualified file name it is often easier to use @\"\"@ as 'FilePath' argument,+--   for example the following two expressions are equivalent:+--+-- > fmap (map ("Config" </>)) (getDirectoryFiles "Config" ["//*.xml"])+-- > getDirectoryFiles "" ["Config//*.xml"] getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath] getDirectoryFiles x f = getDirAction $ GetDirFiles x f 

@@ -99,13 +99,13 @@   -- | Require that the following files are built before continuing. Particularly---   necessary when calling 'Development.Shake.system''. As an example:+--   necessary when calling 'Development.Shake.cmd' or 'Development.Shake.command'. As an example: -- -- @ -- \"\/\/*.rot13\" '*>' \\out -> do --     let src = 'Development.Shake.FilePath.dropExtension' out --     'need' [src]---     'Development.Shake.system'' \"rot13\" [src,\"-o\",out]+--     'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out] -- @ need :: [FilePath] -> Action () need xs = (apply $ map (FileQ . pack) xs :: Action [FileA]) >> return ()@@ -167,7 +167,7 @@ -- \"*.asm.o\" '*>' \\out -> do --     let src = 'Development.Shake.FilePath.dropExtension' out --     'need' [src]---     'Development.Shake.system'' \"as\" [src,\"-o\",out]+--     'Development.Shake.cmd' \"as\" [src] \"-o\" [out] -- @ -- --   To define a build system for multiple compiled languages, we recommend using @.asm.o@,

@@ -38,7 +38,7 @@ -- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do --     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\" --     'Development.Shake.need' ... -- all files the .hs import---     'Development.Shake.system'' \"ghc\" [\"-c\",hs]+--     'Development.Shake.cmd' \"ghc -c\" [hs] -- @ -- --   However, in practice, it's usually easier to define rules with '*>' and make the @.hi@ depend

@@ -91,14 +91,14 @@ --    excel <- 'Development.Shake.newResource' \"Excel\" 1 --    \"*.xls\" 'Development.Shake.*>' \\out -> --        'Development.Shake.withResource' excel 1 $---            'Development.Shake.system'' \"excel\" [out,...]+--            'Development.Shake.cmd' \"excel\" out ... -- @ -- --   Now the two calls to @excel@ will not happen in parallel. Using 'Resource' --   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'') should be run inside 'Development.Shake.withResource',+--   system commands (such as 'Development.Shake.cmd') 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. --@@ -111,9 +111,9 @@ -- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]] -- \"*.exe\" 'Development.Shake.*>' \\out -> --     'Development.Shake.withResource' disk 1 $---         'Development.Shake.system'' \"ld\" [\"-o\",out,...]+--         'Development.Shake.cmd' \"ld -o\" [out] ... -- \"*.o\" 'Development.Shake.*>' \\out ->---     'Development.Shake.system'' \"cl\" [\"-o\",out,...]+--     'Development.Shake.cmd' \"cl -o\" [out] ... -- @ data Resource = Resource {resourceKey :: Int, resourceName :: String, resourceMax :: Int, resourceVar :: Var (Int,[(Int,IO ())])} instance Show Resource where show Resource{..} = "Resource " ++ resourceName

@@ -39,7 +39,7 @@ -- @ -- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) -- rules = do---     'addOracle' $ \\(GhcVersion _) -> fmap (last . words . fst) $ 'Development.Shake.systemOutput' \"ghc\" [\"--version\"]+--     'addOracle' $ \\(GhcVersion _) -> fmap (last . words . 'Development.Shake.fromStdout') $ 'Development.Shake.cmd' \"ghc --version\" --     ... rules ... -- @ --@@ -66,7 +66,7 @@ -- --rules = do --    getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do---        (out,_) <- 'Development.Shake.systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"]+--        Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\" --        return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x] --    -- --    getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do

@@ -27,7 +27,7 @@ -- @ -- \"ghcVersion.txt\" 'Development.Shake.*>' \\out -> do --     'alwaysRerun'---     (stdout,_) <- 'Development.Shake.systemOutput' \"ghc\" [\"--version\"]+--     Stdout stdout <- 'Development.Shake.cmd' \"ghc --version\" --     'Development.Shake.writeFileChanged' out stdout -- @ alwaysRerun :: Action ()

@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} --- | /Warning: I intend to remove this module. Please use "Development.Shake.Command" instead./+-- | /Warning: I intend to remove this module. Please use 'command' or 'cmd' instead./ -- --   This module provides versions of the 'Development.Shake.Derived.system'' family of functions --   which take a variable number of arguments.

@@ -3,7 +3,6 @@  import Development.Shake import Development.Shake.FilePath-import Development.Shake.Command import Examples.Util  main = shaken noTest $ \args obj -> do

@@ -0,0 +1,41 @@++module Examples.Ninja.Main(main) where++import Development.Shake+import Development.Shake.FilePath+import System.Directory(copyFile)+import Examples.Util+import Data.List+import qualified Start+import System.Environment+++main = shaken test $ \args obj -> do+    let args2 = ("-C" ++ obj "") : map tail (filter ("@" `isPrefixOf`) args)+    let real = "real" `elem` args+    action $+        if real then cmd "ninja" args2 else liftIO $ withArgs args2 Start.main+++test build obj = do+    let run xs = build $ map ('@':) $ words xs+    build ["clean"]+    run "-f../../Examples/Ninja/test1.ninja"+    assertExists $ obj "out1.txt"++    run "-f../../Examples/Ninja/test2.ninja"+    assertExists $ obj "out2.2"+    assertMissing $ obj "out2.1"+    build ["clean"]+    run "-f../../Examples/Ninja/test2.ninja out2.1"+    assertExists $ obj "out2.1"+    assertMissing $ obj "out2.2"++    copyFile "Examples/Ninja/test3-sub.ninja" $ obj "test3-sub.ninja"+    copyFile "Examples/Ninja/test3-inc.ninja" $ obj "test3-inc.ninja"+    copyFile ("Examples/Ninja/" ++ if null exe then "test3-unix.ninja" else "test3-win.ninja") $ obj "test3-platform.ninja"+    run "-f../../Examples/Ninja/test3.ninja"+    assertNonSpace (obj "out3.1") "g4+b1+++i1"+    assertNonSpace (obj "out3.2") "g4++++i1"+    assertNonSpace (obj "out3.3") "g4++++i1"+    assertNonSpace (obj "out3.4") "g4+++s1+s2"

@@ -0,0 +1,5 @@++rule run+    command = touch $out++build out1.txt: run

@@ -0,0 +1,8 @@+
+rule run
+    command = touch $out
+
+build out2.1: run
+build out2.2: run
+
+default out2.2

@@ -0,0 +1,3 @@+v5 = i1
+
+build out3.3: dump

@@ -0,0 +1,6 @@+v4 = s1
+v5 = s1
+
+build out3.4: dump
+
+v5 = s2

@@ -0,0 +1,3 @@+
+rule dump
+    command = echo "$v1+$v2+$v3+$v4+$v5" > $out

@@ -0,0 +1,3 @@+
+rule dump
+    command = cmd /c "echo $v1+$v2+$v3+$v4+$v5 > $out"

@@ -0,0 +1,21 @@+
+
+v1 = g1
+v5 = g1
+
+include test3-platform.ninja
+
+v1 = g2
+
+build out3.1: dump
+    v2 = b1
+
+v1 = g3
+
+subninja test3-sub.ninja
+
+include test3-inc.ninja
+
+build out3.2: dump
+
+v1 = g4

@@ -4,7 +4,6 @@  import Development.Shake import Development.Shake.Classes-import Development.Shake.Command import Development.Shake.FilePath import Examples.Util 

@@ -10,4 +10,4 @@     obj "result.tar" *> \out -> do         contents <- readFileLines "Examples/Tar/list.txt"         need contents-        system' "tar" $ ["-cf",out] ++ contents+        cmd "tar -cf" [out] contents

@@ -6,7 +6,6 @@ import Control.Monad import Data.List import Development.Shake-import Development.Shake.Command import Examples.Util  

@@ -21,7 +21,7 @@     index *> \_ -> do         xs <- getDirectoryFiles "Development" ["//*.hs"]         need $ map ("Development" </>) xs-        system' "cabal" ["haddock"]+        cmd "cabal haddock"      obj "Paths_shake.hs" *> \out -> do         copyFile' "Paths.hs" out@@ -78,7 +78,7 @@      obj "Success.txt" *> \out -> do         need [obj "Main.hs"]-        system' "runhaskell" ["-ignore-package=hashmap","-i" ++ obj "",obj "Main.hs"]+        () <- cmd "runhaskell -ignore-package=hashmap" ["-i" ++ obj "", obj "Main.hs"]         writeFile' out ""  @@ -113,8 +113,13 @@ dropComment ('-':'-':_) = [] dropComment xs = onTail dropComment xs -undefDots ('.':'.':'.':xs) = "undefined" ++ (if "..." `isSuffixOf` xs then "" else undefDots xs)-undefDots xs = onTail undefDots xs++undefDots o = f o+    where+        f ('.':'.':'.':xs) =+            (if "cmd" `elem` words o then "[\"\"]" else "undefined") +++            (if "..." `isSuffixOf` xs then "" else undefDots xs)+        f xs = onTail f xs  strip :: String -> String strip x

@@ -26,7 +26,7 @@         need [out]      obj "systemcmd" *> \_ ->-        system' "random_missing_command" []+        cmd "random_missing_command"      obj "stack1" *> \_ -> need [obj "stack2"]     obj "stack2" *> \_ -> need [obj "stack3"]

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-}  module Examples.Test.Random(main) where @@ -6,6 +7,10 @@ import Control.Exception import Control.Monad import Data.List+import Data.Maybe+import Data.Time+import System.Environment+import System.Exit import System.Random import qualified Data.ByteString.Char8 as BS @@ -32,7 +37,7 @@             i <- randomRIO (0, 25)             sleep $ fromInteger i / 100 -    forM_ (map read args) $ \x -> case x of+    forM_ (map read $ filter (isNothing . asDuration) args) $ \x -> case x of         Want xs -> want $ map (toFile . Output) xs         Logic out srcs -> toFile (Output out) *> \out -> do             res <- fmap (show . Multiple) $ forM srcs $ \src -> do@@ -43,50 +48,67 @@             writeFileChanged out res  -test build obj = forM_ [1..] $ \count -> do-    putStrLn $ "* PERFORMING RANDOM TEST " ++ show count-    build ["clean"]-    build [] -- to create the directory-    forM_ inputRange $ \i ->-        writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i-    logic <- randomLogic-    runLogic [] logic-    chng <- filterM (const randomIO) inputRange   -    forM_ chng $ \i ->-        writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i-    runLogic chng logic-    forM_ inputRange $ \i ->-        writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i-    logicBang <- addBang =<< addBang logic-    j <- randomRIO (1::Int,8)-    res <- try $ build $ ("-j" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]])-    case res of-        Left err-            | "BANG" `isInfixOf` show (err :: SomeException) -> return () -- error I expected-            | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err-        _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt-    runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]-    where-        runLogic :: [Int] -> [Logic] -> IO ()-        runLogic negated xs = do-            let poss = [i | Logic i _ <- xs]-            i <- randomRIO (0, 7)-            wants <- replicateM i $ do-                i <- randomRIO (0, 5)-                replicateM i $ randomElem poss-            sleepFileTime-            j <- randomRIO (1::Int,8)-            build $ ("-j" ++ show j) : map show (xs ++ map Want wants)+asDuration :: String -> Maybe Double+asDuration x+    | "s" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just i+    | "m" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just $ i * 60+    | otherwise = Nothing -            let value i = case [ys | Logic j ys <- xs, j == i] of-                    [ys] -> Multiple $ flip map ys $ map $ \i -> case i of-                        Input i -> Single $ if i `elem` negated then negate i else i-                        Output i -> value i-            forM_ (concat wants) $ \i -> do-                let wanted = value i-                got <- fmap read $ readFileStrict $ obj $ "output-" ++ show i ++ ".txt"-                when (wanted /= got) $-                    error $ "INCORRECT VALUE for " ++ show i++test build obj = do+    limit <- do+        args <- getArgs+        let bound = listToMaybe $ reverse $ mapMaybe asDuration args+        start <- getCurrentTime+        return $ when (isJust bound) $ do+            now <- getCurrentTime+            when (fromRational (toRational $ now `diffUTCTime` start) > fromJust bound) exitSuccess++    forM_ [1..] $ \count -> do+        limit+        putStrLn $ "* PERFORMING RANDOM TEST " ++ show count+        build ["clean"]+        build [] -- to create the directory+        forM_ inputRange $ \i ->+            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+        logic <- randomLogic+        runLogic [] logic+        chng <- filterM (const randomIO) inputRange   +        forM_ chng $ \i ->+            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i+        runLogic chng logic+        forM_ inputRange $ \i ->+            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+        logicBang <- addBang =<< addBang logic+        j <- randomRIO (1::Int,8)+        res <- try $ build $ "--exception" : ("-j" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]])+        case res of+            Left err+                | "BANG" `isInfixOf` show (err :: SomeException) -> return () -- error I expected+                | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err+            _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt+        runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]+        where+            runLogic :: [Int] -> [Logic] -> IO ()+            runLogic negated xs = do+                let poss = [i | Logic i _ <- xs]+                i <- randomRIO (0, 7)+                wants <- replicateM i $ do+                    i <- randomRIO (0, 5)+                    replicateM i $ randomElem poss+                sleepFileTime+                j <- randomRIO (1::Int,8)+                build $ ("-j" ++ show j) : map show (xs ++ map Want wants)++                let value i = case [ys | Logic j ys <- xs, j == i] of+                        [ys] -> Multiple $ flip map ys $ map $ \i -> case i of+                            Input i -> Single $ if i `elem` negated then negate i else i+                            Output i -> value i+                forM_ (concat wants) $ \i -> do+                    let wanted = value i+                    got <- fmap read $ readFileStrict $ obj $ "output-" ++ show i ++ ".txt"+                    when (wanted /= got) $+                        error $ "INCORRECT VALUE for " ++ show i   addBang :: [Logic] -> IO [Logic]

@@ -6,6 +6,7 @@  import Control.Concurrent import Control.Monad+import Data.Char import Data.List import System.Directory as IO import System.Environment@@ -85,10 +86,26 @@ a === b = assert (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b  +assertExists :: FilePath -> IO ()+assertExists file = do+    b <- IO.doesFileExist file+    assert b $ "File was expected to exist, but is missing: " ++ file++assertMissing :: FilePath -> IO ()+assertMissing file = do+    b <- IO.doesFileExist file+    assert (not b) $ "File was expected to be missing, but exists: " ++ file+ assertContents :: FilePath -> String -> IO () assertContents file want = do     got <- readFile file     assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got++assertNonSpace :: FilePath -> String -> IO ()+assertNonSpace file want = do+    got <- readFile file+    let f = filter (not . isSpace)+    assert (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got  assertContentsInfix :: FilePath -> String -> IO () assertContentsInfix file want = do

@@ -17,6 +17,7 @@ import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self import qualified Examples.C.Main as C+import qualified Examples.Ninja.Main as Ninja import qualified Examples.Test.Assume as Assume import qualified Examples.Test.Basic as Basic import qualified Examples.Test.Benchmark as Benchmark@@ -48,7 +49,7 @@         ,"docs" * Docs.main, "errors" * Errors.main         ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main         ,"journal" * Journal.main, "lint" * Lint.main, "makefile" * Makefile.main-        ,"pool" * Pool.main, "random" * Random.main+        ,"pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main         ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main         ,"oracle" * Oracle.main, "progress" * Progress.main]     where (*) = (,)

@@ -1,7 +1,7 @@ cabal-version:      >= 1.8 build-type:         Simple name:               shake-version:            0.10.5+version:            0.10.6 license:            BSD3 license-file:       LICENSE category:           Development@@ -48,6 +48,7 @@     Examples/MakeTutor/hellomake.c     Examples/MakeTutor/hellomake.h     Examples/Tar/list.txt+    Examples/Ninja/*.ninja     Paths.hs  data-files:@@ -160,6 +161,7 @@         Development.Make.Rules         Development.Make.Type         Development.Ninja.All+        Development.Ninja.Env         Development.Ninja.Parse         Development.Ninja.Type         Start@@ -204,6 +206,7 @@         Development.Ninja.Type         Examples.Util         Examples.C.Main+        Examples.Ninja.Main         Examples.Self.Main         Examples.Tar.Main         Examples.Test.Assume