shake 0.10.10 → 0.11
raw patch · 40 files changed
+1067/−516 lines, 40 files
Files
- CHANGES.txt +15/−0
- Development/Make/Rules.hs +2/−2
- Development/Ninja/All.hs +18/−13
- Development/Ninja/Lexer.hs +219/−0
- Development/Ninja/Parse.hs +40/−129
- Development/Ninja/Type.hs +1/−1
- Development/Shake.hs +13/−12
- Development/Shake/Args.hs +12/−11
- Development/Shake/Command.hs +62/−12
- Development/Shake/Core.hs +205/−52
- Development/Shake/Database.hs +60/−17
- Development/Shake/FileTime.hs +1/−1
- Development/Shake/Progress.hs +41/−44
- Development/Shake/Resource.hs +2/−1
- Development/Shake/Rule.hs +13/−0
- Development/Shake/Rules/Directory.hs +8/−16
- Development/Shake/Rules/File.hs +29/−106
- Development/Shake/Rules/Files.hs +4/−2
- Development/Shake/Rules/Oracle.hs +1/−1
- Development/Shake/Rules/OrderOnly.hs +2/−2
- Development/Shake/Rules/Rerun.hs +1/−1
- Development/Shake/Storage.hs +2/−1
- Development/Shake/Sys.hs +1/−1
- Development/Shake/Types.hs +35/−3
- Development/Shake/Util.hs +27/−1
- Development/Shake/Value.hs +5/−5
- Examples/Self/Main.hs +3/−6
- Examples/Test/Basic.hs +19/−0
- Examples/Test/Cache.hs +2/−2
- Examples/Test/Command.hs +3/−2
- Examples/Test/Docs.hs +17/−6
- Examples/Test/Errors.hs +13/−0
- Examples/Test/Lint.hs +35/−0
- Examples/Util.hs +4/−1
- General/Base.hs +41/−60
- General/Binary.hs +38/−1
- General/String.hs +65/−0
- LICENSE +1/−1
- Test.hs +1/−1
- shake.cabal +6/−2
CHANGES.txt view
@@ -1,5 +1,20 @@ Changelog for Shake +0.11+ Add alternatives to allow overlapping rules+ Make storedValue take a ShakeOptions structure+ Generalise the newCache function+ Improve the performance of the Ninja parser+ Make the database more compact+ #84, ensure you normalise removeFile patterns first+ #82, make -j0 guess at the number of processors+ #81, add --lint-tracker to use tracker.exe+ Add trackRead, trackWrite+ Add trackUse, trackChange, trackAllow+ #85, move rule creation functions into Development.Shake.Rule+ Mark Development.Shake.Sys as DEPRECATED with a pragma+ Change shakeLint to be of type Maybe Lint, instead of Bool+ #50, add shakeArgsAccumulate 0.10.10 Improve Ninja --lint checking 0.10.9
Development/Make/Rules.hs view
@@ -11,7 +11,7 @@ import System.Directory import Development.Shake.Core-import General.Base+import General.String import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.FileTime@@ -33,7 +33,7 @@ deriving (Typeable,Eq,Hashable,Binary,Show,NFData) instance Rule File_Q File_A where- storedValue (File_Q x) = fmap (fmap (File_A . Just)) $ getModTimeMaybe x+ storedValue _ (File_Q x) = fmap (fmap (File_A . Just)) $ getModTimeMaybe x defaultRuleFile_ :: Rules ()
Development/Ninja/All.hs view
@@ -5,12 +5,13 @@ import Development.Ninja.Env import Development.Ninja.Type import Development.Ninja.Parse -import Development.Shake hiding (Rule, addEnv) +import Development.Shake hiding (addEnv) import Development.Shake.ByteString import Development.Shake.Errors import Development.Shake.Rules.File import Development.Shake.Rules.OrderOnly import General.Timing +import qualified Data.ByteString as BS8 import qualified Data.ByteString.Char8 as BS import System.Directory @@ -19,7 +20,6 @@ import Control.Arrow import Control.Monad import Data.Maybe -import Data.List import Data.Char @@ -36,7 +36,7 @@ pools <- fmap Map.fromList $ forM pools $ \(name,depth) -> fmap ((,) name) $ newResource (BS.unpack name) depth - want $ map (BS.unpack . normalise) $ concatMap (resolvePhony phonys) $ + action $ needBS $ map normalise $ 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 @@ -93,8 +93,8 @@ when (description /= "") $ putNormal description if deps == "msvc" then do - Stdout stdout <- withPool $ command [Shell, EchoStdout True] commandline [] - needDeps build $ map (normalise . BS.pack) $ parseShowIncludes stdout + Stdout stdout <- withPool $ command [Shell] commandline [] + needDeps build $ map normalise $ parseShowIncludes $ BS.pack stdout else withPool $ command_ [Shell] commandline [] when (depfile /= "") $ do @@ -107,7 +107,7 @@ needDeps :: Ninja -> Build -> [Str] -> Action () needDeps Ninja{..} = \build xs -> do -- eta reduced so 'builds' is shared opts <- getShakeOptions - if not $ shakeLint opts then needBS xs else do + if isNothing $ shakeLint opts then needBS xs else do neededBS xs -- now try and statically validate needed will never fail -- first find which dependencies are generated files @@ -157,12 +157,17 @@ return res -parseShowIncludes :: String -> [FilePath] -parseShowIncludes out = [y | x <- lines out, Just x <- [stripPrefix "Note: including file:" x] - , let y = dropWhile isSpace x, not $ isSystemInclude y] - +parseShowIncludes :: Str -> [FileStr] +parseShowIncludes out = [y | x <- BS.lines out, bsNote `BS.isPrefixOf` x + , let y = BS.dropWhile isSpace $ BS.drop (BS.length bsNote) 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 +isSystemInclude :: FileStr -> Bool +isSystemInclude x = bsProgFiles `BS.isInfixOf` tx || bsVisStudio `BS.isInfixOf` tx + where tx = BS8.map (\c -> if c >= 97 then c - 32 else c) x + -- optimised toUpper that only cares about letters and spaces + +bsNote = BS.pack "Note: including file:" +bsProgFiles = BS.pack "PROGRAM FILES" +bsVisStudio = BS.pack "MICROSOFT VISUAL STUDIO"
+ Development/Ninja/Lexer.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE PatternGuards, CPP #-}+{-# OPTIONS_GHC -O2 #-}+-- {-# OPTIONS_GHC -ddump-simpl #-}++-- | Lexing is a slow point, the code below is optimised+module Development.Ninja.Lexer(Lexeme(..), lexer, lexerFile) where++import Control.Arrow+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Unsafe as BS+import Development.Ninja.Type+import qualified Data.ByteString.Internal as Internal+import Foreign+import GHC.Exts++---------------------------------------------------------------------+-- LIBRARY BITS++newtype Str0 = Str0 Str -- null terminated++type S = Ptr Word8++chr :: S -> Char+chr x = Internal.w2c $ Internal.inlinePerformIO $ peek x++inc :: S -> S+inc x = x `plusPtr` 1++{-# INLINE dropWhile0 #-}+dropWhile0 :: (Char -> Bool) -> Str0 -> Str0+dropWhile0 f x = snd $ span0 f x++{-# INLINE span0 #-}+span0 :: (Char -> Bool) -> Str0 -> (Str, Str0)+span0 f x = break0 (not . f) x++{-# INLINE break0 #-}+break0 :: (Char -> Bool) -> Str0 -> (Str, Str0)+break0 f (Str0 bs) = (BS.unsafeTake i bs, Str0 $ BS.unsafeDrop i bs)+ where+ i = Internal.inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do+ let start = castPtr ptr :: S+ let end = go start+ return $! Ptr end `minusPtr` start++ go s@(Ptr a) | c == '\0' || f c = a+ | otherwise = go $ inc s+ where c = chr s++{-# INLINE break00 #-}+-- The predicate must return true for '\0'+break00 :: (Char -> Bool) -> Str0 -> (Str, Str0)+break00 f (Str0 bs) = (BS.unsafeTake i bs, Str0 $ BS.unsafeDrop i bs)+ where+ i = Internal.inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do+ let start = castPtr ptr :: S+ let end = go start+ return $! Ptr end `minusPtr` start++ go s@(Ptr a) | f c = a+ | otherwise = go $ inc s+ where c = chr s++head0 :: Str0 -> Char+head0 (Str0 x) = Internal.w2c $ BS.unsafeHead x++tail0 :: Str0 -> Str0+tail0 (Str0 x) = Str0 $ BS.unsafeTail x++list0 :: Str0 -> (Char, Str0)+list0 x = (head0 x, tail0 x)++take0 :: Int -> Str0 -> Str+take0 i (Str0 x) = BS.takeWhile (/= '\0') $ BS.take i x+++---------------------------------------------------------------------+-- ACTUAL LEXER++-- Lex each line separately, rather than each lexeme+data Lexeme+ = LexBind Str Expr -- [indent]foo = bar+ | LexBuild [Expr] Str [Expr] -- build foo: bar | baz || qux (| and || are represented as Expr)+ | LexInclude Str -- include file+ | LexSubninja Str -- include file+ | LexRule Str -- rule name+ | LexPool Str -- pool name+ | LexDefault [Expr] -- default foo bar+ | LexDefine Str Expr -- foo = bar+ deriving Show++isVar, isVarDot :: Char -> Bool+isVar x = x == '-' || x == '_' || (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') || (x >= '0' && x <= '9')+isVarDot x = x == '.' || isVar x++endsDollar :: Str -> Bool+endsDollar x = BS.isSuffixOf (BS.singleton '$') x++dropN :: Str0 -> Str0+dropN x = if head0 x == '\n' then tail0 x else x++dropSpace :: Str0 -> Str0+dropSpace x = dropWhile0 (== ' ') x+++lexerFile :: Maybe FilePath -> IO [Lexeme]+lexerFile file = fmap lexer $ maybe BS.getContents BS.readFile file++lexer :: Str -> [Lexeme]+lexer x = lexerLoop $ Str0 $ x `BS.append` BS.pack "\n\n\0"++lexerLoop :: Str0 -> [Lexeme]+lexerLoop c_x | (c,x) <- list0 c_x = case c of+ '\r' -> lexerLoop x+ '\n' -> lexerLoop x+ ' ' -> lexBind $ dropSpace x+ '#' -> lexerLoop $ dropWhile0 (/= '\n') x+ 'b' | Just x <- strip "uild " x -> lexBuild $ dropSpace x+ 'r' | Just x <- strip "ule " x -> lexRule $ dropSpace x+ 'd' | Just x <- strip "efault " x -> lexDefault $ dropSpace x+ 'p' | Just x <- strip "ool " x -> lexPool $ dropSpace x+ 'i' | Just x <- strip "nclude " x -> lexInclude $ dropSpace x+ 's' | Just x <- strip "ubninja " x -> lexSubninja $ dropSpace x+ '\0' -> []+ _ -> lexDefine c_x+ where+ strip str (Str0 x) = if b `BS.isPrefixOf` x then Just $ Str0 $ BS.drop (BS.length b) x else Nothing+ where b = BS.pack str++lexBind c_x | (c,x) <- list0 c_x = case c of+ '\r' -> lexerLoop x+ '\n' -> lexerLoop x+ '#' -> lexerLoop $ dropWhile0 (/= '\n') x+ '\0' -> []+ _ -> lexxBind LexBind c_x++lexBuild x+ | (outputs,x) <- lexxExprs True x+ , (rule,x) <- span0 isVar $ dropSpace x+ , (deps,x) <- lexxExprs False $ dropSpace x+ = LexBuild outputs rule deps : lexerLoop x++lexDefault x+ | (files,x) <- lexxExprs False x+ = LexDefault files : lexerLoop x++lexRule x = lexxName LexRule x+lexPool x = lexxName LexPool x+lexInclude x = lexxFile LexInclude x+lexSubninja x = lexxFile LexSubninja x+lexDefine x = lexxBind LexDefine x++lexxBind ctor x+ | (var,x) <- span0 isVarDot x+ , ('=',x) <- list0 $ dropSpace x+ , (exp,x) <- lexxExpr False False $ dropSpace x+ = ctor var exp : lexerLoop x+lexxBind _ x = error $ show ("parse failed when parsing binding", take0 100 x)++lexxFile ctor x+ | (file,rest) <- splitLineCont x+ = ctor file : lexerLoop rest++lexxName ctor x+ | (name,rest) <- splitLineCont x+ = ctor name : lexerLoop rest+++lexxExprs :: Bool -> Str0 -> ([Expr], Str0)+lexxExprs stopColon x = case lexxExpr stopColon True x of+ (a,c_x) | c <- head0 c_x, x <- tail0 c_x -> case c of+ ' ' -> first (a:) $ lexxExprs stopColon $ dropSpace x+ ':' | stopColon -> ([a], x)+ _ | stopColon -> error "expected a colon"+ '\r' -> a $: dropN x+ '\n' -> a $: x+ '\0' -> a $: c_x+ where+ Exprs [] $: x = ([], x)+ a $: x = ([a], x)+++{-# NOINLINE lexxExpr #-}+lexxExpr :: Bool -> Bool -> Str0 -> (Expr, Str0) -- snd will start with one of " :\n\r" or be empty+lexxExpr stopColon stopSpace = first exprs . f+ where+ exprs [x] = x+ exprs xs = Exprs xs++ special = case (stopColon, stopSpace) of+ (True , True ) -> \x -> x <= ':' && (x == ':' || x == ' ' || x == '$' || x == '\r' || x == '\n' || x == '\0')+ (True , False) -> \x -> x <= ':' && (x == ':' || x == '$' || x == '\r' || x == '\n' || x == '\0')+ (False, True ) -> \x -> x <= '$' && ( x == ' ' || x == '$' || x == '\r' || x == '\n' || x == '\0')+ (False, False) -> \x -> x <= '$' && ( x == '$' || x == '\r' || x == '\n' || x == '\0')+ f x = case break00 special x of (a,x) -> if BS.null a then g x else Lit a $: g x++ x $: (xs,y) = (x:xs,y)++ g x | head0 x /= '$' = ([], x)+ g x | c_x <- tail0 x, (c,x) <- list0 c_x = case c of+ '$' -> Lit (BS.singleton '$') $: f x+ ' ' -> Lit (BS.singleton ' ') $: f x+ ':' -> Lit (BS.singleton ':') $: f x+ '\n' -> f $ dropSpace x+ '\r' -> f $ dropSpace $ dropN x+ '{' | (name,x) <- span0 isVarDot x, not $ BS.null name, ('}',x) <- list0 x -> Var name $: f x+ _ | (name,x) <- span0 isVar c_x, not $ BS.null name -> Var name $: f x+ _ -> error $ "Unexpect $ followed by unexpected stuff"+++splitLineCont :: Str0 -> (Str, Str0)+splitLineCont x = first BS.concat $ f x+ where+ f x = if not $ endsDollar a then ([a], b) else let (c,d) = f $ dropSpace b in (BS.init a : c, d)+ where (a,b) = splitLineCR x++splitLineCR :: Str0 -> (Str, Str0)+splitLineCR x = if BS.singleton '\r' `BS.isSuffixOf` a then (BS.init a, dropN b) else (a, dropN b)+ where (a,b) = break0 (== '\n') x
Development/Ninja/Parse.hs view
@@ -1,139 +1,61 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-} +{-# LANGUAGE 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.Shake.ByteString import Development.Ninja.Env import Development.Ninja.Type +import Development.Ninja.Lexer import Control.Monad -import Data.Char -import Data.Maybe -endsDollar :: Str -> Bool -endsDollar = BS.isSuffixOf (BS.singleton '$') - -dropSpace :: Str -> Str -dropSpace = BS.dropWhile isSpace - -startsSpace :: Str -> Bool -startsSpace = BS.isPrefixOf (BS.singleton ' ') - - - -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 = do env <- newEnv; parseFile file env newNinja 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 env) ninja $ splitStmts src - - -data Stmt = Stmt Str [Str] deriving Show - + lexes <- lexerFile $ if file == "-" then Nothing else Just file + foldM (applyStmt env) ninja $ withBinds lexes -splitStmts :: Str -> [Stmt] -splitStmts = stmt . continuation . linesCR +withBinds :: [Lexeme] -> [(Lexeme, [(Str,Expr)])] +withBinds [] = [] +withBinds (x:xs) = (x,a) : withBinds b 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 + (a,b) = f xs + f (LexBind a b : rest) = let (as,bs) = f rest in ((a,b):as, bs) + f xs = ([], 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" = 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 +applyStmt :: Env Str Str -> Ninja -> (Lexeme, [(Str,Expr)]) -> IO Ninja +applyStmt env ninja@Ninja{..} (key, binds) = case key of + LexBuild outputs rule deps -> do + outputs <- mapM (askExpr env) outputs + deps <- mapM (askExpr env) deps + let (normal,implicit,orderOnly) = splitDeps deps + let build = Build rule env normal implicit orderOnly binds 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) env ninja - | key == BS.pack "subninja" = do + LexRule name -> + return ninja{rules = (name, Rule binds) : rules} + LexDefault xs -> do + xs <- mapM (askExpr env) xs + return ninja{defaults = xs ++ defaults} + LexPool name -> do + depth <- getDepth env binds + return ninja{pools = (name, depth) : pools} + LexInclude file -> + parseFile (BS.unpack file) env ninja + LexSubninja file -> do e <- scopeEnv env - parseFile (BS.unpack rest) e ninja - | Just (a,b) <- parseBind x = do + parseFile (BS.unpack file) e ninja + LexDefine a b -> 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 :: 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) -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 = case BS.elemIndex '$' x of - Nothing -> [Lit x] - Just i -> Lit (BS.take i x) : g (BS.drop (i+1) 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 -> Str -> IO [Str] -parseStrs env = mapM (askExpr env) . parseExprs - + LexBind a b -> + error $ "Unexpected binding defining " ++ BS.unpack a splitDeps :: [Str] -> ([Str], [Str], [Str]) @@ -144,22 +66,11 @@ 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 ':' +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
Development/Ninja/Type.hs view
@@ -20,7 +20,7 @@ --------------------------------------------------------------------- -- EXPRESSIONS AND BINDINGS -data Expr = Exprs [Expr] | Lit Str | Var Str deriving Show+data Expr = Exprs [Expr] | Lit Str | Var Str deriving (Show,Eq) askExpr :: Env Str Str -> Expr -> IO Str askExpr e = f
Development/Shake.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | This module is used for defining Shake build systems. As a simple example of a Shake build system, -- let us build the file @result.tar@ from the files listed by @result.txt@:@@ -92,15 +91,12 @@ -- * Core shake, shakeOptions,-#if __GLASGOW_HASKELL__ >= 704- ShakeValue,-#endif- Rule(..), Rules, defaultRule, rule, action, withoutActions,- Action, apply, apply1, traced,+ Rules, action, withoutActions, alternatives,+ Action, traced, liftIO, actionOnException, actionFinally, ShakeException(..), -- * Configuration- ShakeOptions(..), Assume(..), getShakeOptions,+ ShakeOptions(..), Assume(..), Lint(..), getShakeOptions, -- ** Command line shakeArgs, shakeArgsWith, shakeOptDescrs, -- ** Progress reporting@@ -113,13 +109,16 @@ CmdResult, CmdOption(..), addPath, addEnv, -- * Utility functions- module Development.Shake.Derived,+ copyFile',+ readFile', readFileLines,+ writeFile', writeFileLines, writeFileChanged, removeFiles, removeFilesAfter, -- * File rules need, want, (*>), (**>), (?>), phony, (~>), module Development.Shake.Rules.Files,- orderOnly, needed,+ orderOnly, FilePattern, (?==),+ needed, trackRead, trackWrite, trackAllow, -- * Directory rules doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs, -- * Environment rules@@ -132,8 +131,10 @@ Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO, unsafeExtraThread,- -- * Cached file contents- newCache, newCacheIO+ -- * Cache+ newCache, newCacheIO,+ -- * Deprecated+ system', systemCwd, systemOutput ) where -- I would love to use module export in the above export list, but alas Haddock@@ -141,7 +142,7 @@ import Control.Monad.IO.Class import Development.Shake.Types-import Development.Shake.Core+import Development.Shake.Core hiding (trackAllow) import Development.Shake.Derived import Development.Shake.Errors import Development.Shake.Progress
Development/Shake/Args.hs view
@@ -233,13 +233,14 @@ ,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 "" ["flush"] (intArg 1 "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."- ,yes $ Option "j" ["jobs"] (intArg "jobs" "N" $ \i s -> s{shakeThreads=i}) "Allow N jobs/threads at once."+ ,yes $ Option "j" ["jobs"] (intArg 0 "jobs" "N" $ \i s -> s{shakeThreads=i}) "Allow N jobs/threads at once." ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."- ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=True}) "Perform limited validation after the run."- ,yes $ Option "" ["no-lint"] (noArg $ \s -> s{shakeLint=False}) "Turn off --lint."+ ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."+ ,yes $ Option "t" ["lint-tracker"] (noArg $ \s -> s{shakeLint=Just LintTracker}) "Use tracker.exe to do validation."+ ,yes $ Option "" ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint." ,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."@@ -252,7 +253,7 @@ ,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"] (optIntArg "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "Show progress messages [every N seconds, default 5]."+ ,yes $ Option "p" ["progress"] (optIntArg 1 "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "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."@@ -274,12 +275,12 @@ noArg f = NoArg $ Right ([], f) reqArg a f = ReqArg (\x -> Right ([], f x)) a- 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"+ intArg mn flag a f = flip ReqArg a $ \x -> case reads x of+ [(i,"")] | i >= mn -> Right ([],f i)+ _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"+ optIntArg mn flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of+ [(i,"")] | i >= mn -> Right ([],f $ Just i)+ _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above" 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"
Development/Shake/Command.hs view
@@ -18,7 +18,9 @@ import Data.Char import Data.Either import Data.List+import Data.Maybe import Foreign.C.Error+import System.Directory import System.Environment import System.Exit import System.IO@@ -27,6 +29,7 @@ import Development.Shake.Core import Development.Shake.FilePath import Development.Shake.Types+import Development.Shake.Rules.File import General.Base import GHC.IO.Exception (IOErrorType(..), IOException(..))@@ -93,19 +96,66 @@ commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]-commandExplicit funcName opts results exe args = skipper $ verboser $ tracer $ commandExplicitIO funcName opts results exe args+commandExplicit funcName copts results exe args = do+ opts <- getShakeOptions+ verb <- getVerbosity++ let skipper act = if null results && not (shakeRunCommands opts) then return [] else act++ let verboser act = do+ putLoud $ saneCommandForUser exe args+ (if verb >= Loud then quietly else id) act++ let tracer = case reverse [x | Traced x <- copts] of+ "":_ -> liftIO+ msg:_ -> traced msg+ [] -> traced (takeFileName exe)++ let tracker act = case shakeLint opts of+ Just LintTracker -> do+ dir <- liftIO $ getTemporaryDirectory+ (file, handle) <- liftIO $ openTempFile dir "shake.lint"+ liftIO $ hClose handle+ dir <- return $ file <.> "dir"+ liftIO $ createDirectory dir+ let cleanup = removeDirectoryRecursive dir >> removeFile file+ flip actionFinally cleanup $ do+ res <- act "tracker" $ "/if":dir:"/c":exe:args+ (read,write) <- liftIO $ trackerFiles dir+ trackRead read+ trackWrite write+ return res+ _ -> act exe args++ skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName copts results exe args+++-- | Given a directory (as passed to tracker /if) report on which files were used for reading/writing+trackerFiles :: FilePath -> IO ([FilePath], [FilePath])+trackerFiles dir = do+ curdir <- getCurrentDirectory+ let pre = map toUpper curdir ++ "\\"+ files <- getDirectoryContents dir+ let f typ = do+ files <- forM [x | x <- files, takeExtension x == ".tlog", takeExtension (dropExtension $ dropExtension x) == '.':typ] $ \file -> do+ xs <- readFileUCS2 $ dir </> file+ return $ filter (not . isPrefixOf "." . takeFileName) . mapMaybe (stripPrefix pre) $ lines xs+ fmap nub $ mapMaybeM correctCase $ nub $ concat files+ liftM2 (,) (f "read") (f "write")+++correctCase :: FilePath -> IO (Maybe FilePath)+correctCase x = f "" x where- skipper act = do- o <- getShakeOptions- if null results && not (shakeRunCommands o) then return [] else act- verboser act = do- v <- getVerbosity- putLoud $ saneCommandForUser exe args- (if v >= Loud then quietly else id) act- tracer = case reverse [x | Traced x <- opts] of- "":_ -> liftIO- msg:_ -> traced msg- [] -> traced (takeFileName exe)+ f pre "" = return $ Just pre+ f pre x = do+ let (a,b) = (takeDirectory1 x, dropDirectory1 x)+ dir <- getDirectoryContents pre+ case find ((==) a . map toUpper) dir of+ Nothing -> return Nothing -- if it can't be found it probably doesn't exist, so assume a file that wasn't really read+ Just v -> f (pre +/+ v) b++ a +/+ b = if null a then b else a ++ "/" ++ b commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result]
Development/Shake/Core.hs view
@@ -11,10 +11,12 @@ #if __GLASGOW_HASKELL__ >= 704 ShakeValue, #endif- Rule(..), Rules, defaultRule, rule, action, withoutActions,+ Rule(..), Rules, defaultRule, rule, action, withoutActions, alternatives, Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions,+ trackUse, trackChange, trackAllow, getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly, Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,+ newCache, newCacheIO, unsafeExtraThread, -- Internal stuff rulesIO, runAfter@@ -47,6 +49,7 @@ import Development.Shake.Errors import General.Timing import General.Base+import General.String ---------------------------------------------------------------------@@ -80,39 +83,7 @@ -- As an example for filenames/timestamps, if the file exists you should return 'Just' -- the timestamp, but otherwise return 'Nothing'. For rules whose values are not -- stored externally, 'storedValue' should return 'Nothing'.- storedValue :: key -> IO (Maybe value)--{-- -- | Return 'True' if the value should not be changed by the build system. Defaults to returning- -- 'False'. Only used when running with 'shakeLint'.- invariant :: key -> Bool- invariant _ = False-- -- | Given an action, return what has changed, along with what you think should- -- have stayed the same. Only used when running with 'shakeLint'.- observed :: IO a -> IO (Observed key, a)- observed = fmap ((,) mempty)----- | Determine what was observed to change. For each field @Nothing@ means you don't know anything, while--- @Just []@ means you know that nothing was changed/used.-data Observed a = Observed- {changed :: Maybe [a] -- ^ A list of keys which had their value altered.- ,used :: Maybe [a] -- ^ A list of keys whose value was used.- }- deriving (Show,Eq,Ord)--instance Functor Observed where- fmap f (Observed a b) = Observed (g a) (g b)- where g = fmap (map f)--instance Monoid (Observed a) where- mempty = Observed Nothing Nothing- mappend (Observed x1 y1) (Observed x2 y2) = Observed (f x1 x2) (f y1 y2)- where- f Nothing Nothing = Nothing- f a b = Just $ fromMaybe [] a ++ fromMaybe [] b--}+ storedValue :: ShakeOptions -> key -> IO (Maybe value) data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value))@@ -124,8 +95,9 @@ ruleValue = err "ruleValue" --- | Define a set of rules. Rules can be created with calls to 'rule', 'defaultRule' or 'action'. Rules are combined--- with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation.+-- | Define a set of rules. Rules can be created with calls to functions such as '*>' or 'action'. Rules are combined+-- with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation. To define your own+-- custom types of rule, see "Development.Shake.Rule". newtype Rules a = Rules (WriterT SRules IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars) deriving (Monad, Functor, Applicative) @@ -178,7 +150,119 @@ rulePriority i r = newRules mempty{rules = Map.singleton k (k, v, [(i,ARule r)])} where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r +-- | Change the matching behaviour of rules so rules do not have to be disjoint, but are instead matched+-- in order. Only recommended for small blocks containing a handful of rules.+--+-- @+-- alternatives $ do+-- \"hello.txt\" *> \\out -> writeFile' out \"special\"+-- \"*.txt\" *> \\out -> writeFile' out \"normal\"+-- @+alternatives :: Rules () -> Rules ()+alternatives = modifyRules $ \r -> r{rules = Map.map f $ rules r}+ where+ f (k, v, []) = (k, v, [])+ f (k, v, xs) = let (is,rs) = unzip xs in (k, v, [(maximum is, foldl1' g rs)]) + g (ARule a) (ARule b) = ARule $ \x -> a x `mplus` b2 x+ where b2 = fmap (fmap (fromJust . cast)) . b . fromJust . cast+++-- | Track that a key has been used by the action preceeding it.+trackUse ::+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue key+#else+ (Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)+#endif+ => key -> Action ()+-- One of the following must be true:+-- 1) you are the one building this key (e.g. key == topStack)+-- 2) you have already been used by apply, and are on the dependency list+-- 3) someone explicitly gave you permission with trackAllow+-- 4) at the end of the rule, a) you are now on the dependency list, and b) this key itself has no dependencies (is source file)+trackUse key = do+ let k = newKey key+ s <- Action State.get+ deps <- liftIO $ concatMapM (listDepends $ database s) (depends s)+ let top = topStack $ stack s+ if top == Just k then+ return () -- condition 1+ else if k `elem` deps then+ return () -- condition 2+ else if any ($ k) $ trackAllows s then+ return () -- condition 3+ else+ Action $ State.modify $ \s -> s{trackUsed = k : trackUsed s} -- condition 4+++trackCheckUsed :: Action ()+trackCheckUsed = do+ s <- Action State.get+ deps <- liftIO $ concatMapM (listDepends $ database s) (depends s)++ -- check 3a+ bad <- return $ trackUsed s \\ deps+ unless (null bad) $ do+ let n = length bad+ errorStructured+ ("Link checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")+ [("Used", Just $ show x) | x <- bad]+ ""++ -- check 3b+ bad <- liftIO $ flip filterM (trackUsed s) $ \k -> fmap (not . null) $ lookupDependencies (database s) k+ unless (null bad) $ do+ let n = length bad+ errorStructured+ ("Link checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")+ [("Used", Just $ show x) | x <- bad]+ ""+++-- | Track that a key has been changed by the action preceeding it.+trackChange ::+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue key+#else+ (Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)+#endif+ => key -> Action ()+-- One of the following must be true:+-- 1) you are the one building this key (e.g. key == topStack)+-- 2) someone explicitly gave you permission with trackAllow+-- 3) this file is never known to the build system, at the end it is not in the database+trackChange key = do+ let k = newKey key+ s <- Action State.get+ let top = topStack $ stack s+ if top == Just k then+ return () -- condition 1+ else if any ($ k) $ trackAllows s then+ return () -- condition 2+ else+ -- condition 3+ liftIO $ atomicModifyIORef (trackAbsent s) $ \ks -> ((fromMaybe k top, k):ks, ())+++-- | Allow any matching key to violate the tracking rules.+trackAllow ::+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue key+#else+ (Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)+#endif+ => (key -> Bool) -> Action ()+trackAllow test = Action $ State.modify $ \s -> s{trackAllows = f : trackAllows s}+ where+ -- We don't want the forall in the Haddock docs+ arrow1Type :: forall a b . Typeable a => (a -> b) -> TypeRep+ arrow1Type _ = typeOf (err "trackAllow" :: a)++ ty = arrow1Type test+ f k = typeKey k == ty && test (fromKey k)++ -- | Run an action, usually used for specifying top-level requirements. -- -- @@@ -224,6 +308,7 @@ ,diagnostic :: String -> IO () ,lint :: String -> IO () ,after :: IORef [IO ()]+ ,trackAbsent :: IORef [(Key, Key)] -- in rule fst, snd must be absent -- stack variables ,stack :: Stack -- local variables@@ -232,6 +317,8 @@ ,discount :: !Duration ,traces :: [Trace] -- in reverse ,blockapply :: Maybe String -- reason to block apply, or Nothing to allow+ ,trackAllows :: [Key -> Bool]+ ,trackUsed :: [Key] } -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.@@ -283,7 +370,7 @@ when (shakeVerbosity >= Quiet) $ output Quiet msg Right _ -> return () - lint <- if not shakeLint then return $ const $ return () else do+ lint <- if isNothing shakeLint then return $ const $ return () else do dir <- getCurrentDirectory return $ \msg -> do now <- getCurrentDirectory@@ -296,10 +383,12 @@ progressThread <- newIORef Nothing after <- newIORef []+ absent <- newIORef [] let cleanup = do flip whenJust killThread =<< readIORef progressThread when shakeTimings printTimings resetTimings -- so we don't leak memory+ shakeThreads <- if shakeThreads == 0 then getProcessorCount else return shakeThreads flip finally cleanup $ withCapabilities shakeThreads $ do withDatabase opts diagnostic $ \database -> do@@ -308,15 +397,16 @@ stats <- progress database return stats{isFailure=failure} writeIORef progressThread $ Just tid- let ruleinfo = createRuleinfo rs+ let ruleinfo = createRuleinfo opts rs addTiming "Running rules" runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let s0 = SAction database pool start ruleinfo output opts diagnostic lint after emptyStack shakeVerbosity [] 0 [] Nothing+ let s0 = SAction database pool start ruleinfo output opts diagnostic lint after absent emptyStack shakeVerbosity [] 0 [] Nothing [] [] mapM_ (addPool pool . staunch . runAction s0) (actions rs) - when shakeLint $ do+ when (isJust shakeLint) $ do addTiming "Lint checking"- checkValid database (runStored ruleinfo)+ absent <- readIORef absent+ checkValid database (runStored ruleinfo) absent when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded" when (isJust shakeReport) $ do addTiming "Profile report"@@ -376,12 +466,12 @@ registerWitness $ ruleValue r -createRuleinfo :: SRules -> Map.HashMap TypeRep RuleInfo-createRuleinfo SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv+createRuleinfo :: ShakeOptions -> SRules -> Map.HashMap TypeRep RuleInfo+createRuleinfo opt 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))- f _ = storedValue+ f _ = storedValue opt execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of [r]:_ -> r@@ -416,7 +506,7 @@ -- This function requires that appropriate rules have been added with 'rule' or 'defaultRule'. -- All @key@ values passed to 'apply' become dependencies of the 'Action'. apply :: Rule key value => [key] -> Action [value]-apply = f+apply = f -- Don't short-circuit as we still want error messages where -- We don't want the forall in the Haddock docs f :: forall key value . Rule key value => [key] -> Action [value]@@ -433,16 +523,20 @@ applyKeyValue :: [Key] -> Action [Value]+applyKeyValue [] = return [] applyKeyValue ks = do s <- Action State.get let exec stack k = try $ wrapStack (showStack (database s) stack) $ do evaluate $ rnf k- let s2 = s{verbosity=shakeVerbosity $ opts s, depends=[], stack=stack, discount=0, traces=[]}- let top = topStack stack+ let s2 = s{verbosity=shakeVerbosity $ opts s, depends=[], stack=stack, discount=0, traces=[], trackAllows=[], trackUsed=[]}+ let top = showTopStack stack lint s $ "before building " ++ top (dur,(res,s2)) <- duration $ runAction s2 $ do putWhen Chatty $ "# " ++ show k- runExecute (ruleinfo s) k+ res <- runExecute (ruleinfo s) k+ when (shakeLint (opts s) == Just LintTracker)+ trackCheckUsed+ return res lint s $ "after building " ++ top let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2) evaluate $ rnf ans@@ -473,10 +567,10 @@ traced msg act = do s <- Action State.get start <- liftIO $ timestamp s- putNormal $ "# " ++ msg ++ " " ++ topStack (stack s)+ putNormal $ "# " ++ msg ++ " " ++ showTopStack (stack s) res <- liftIO act stop <- liftIO $ timestamp s- Action $ State.modify $ \s -> s{traces = (pack msg,start,stop):traces s}+ Action $ State.modify $ \s -> s{traces = Trace (pack msg) start stop : traces s} return res @@ -600,7 +694,7 @@ -- | Run an action which uses part of a finite resource. For more details see 'Resource'.--- You cannot call 'apply' / 'need' while the resource is acquired.+-- You cannot depend on a rule (e.g. 'need') while a resource is held. withResource :: Resource -> Int -> Action a -> Action a withResource r i act = do s <- Action State.get@@ -631,9 +725,68 @@ f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs +-- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.+-- Most people should use 'newCache' instead.+newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)+newCacheIO act = do+ var {- :: Var (Map k (Barrier (Either SomeException ([Depends],v)))) -} <- newVar Map.empty+ return $ \key -> do+ join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of+ Just bar -> return $ (,) mp $ do+ res <- liftIO $ waitBarrierMaybe bar+ res <- case res of+ Nothing -> do pool <- Action $ gets pool; liftIO $ blockPool pool $ fmap ((,) False) $ waitBarrier bar+ Just res -> return res+ case res of+ Left err -> liftIO $ throwIO err+ Right (deps,v) -> do+ Action $ modify $ \s -> s{depends = deps ++ depends s}+ return v+ Nothing -> do+ bar <- newBarrier+ return $ (,) (Map.insert key bar mp) $ do+ s <- Action State.get+ let pre = depends s+ res <- liftIO $ try $ runAction s $ act key+ case res of+ Left err -> liftIO $ do+ signalBarrier bar $ Left (err :: SomeException)+ throwIO err+ Right (v,s) -> do+ Action $ State.put s+ let post = depends s+ let deps = take (length post - length pre) post+ liftIO $ signalBarrier bar (Right (deps, v))+ return v+++-- | Given an action on a key, produce a cached version that will execute the action at most once per key.+-- Using the cached result will still result include any dependencies that the action requires.+-- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.+--+-- This function is useful when creating files that store intermediate values,+-- to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.+-- As an example:+--+-- @+-- digits \<- 'newCache' $ \\file -> do+-- src \<- readFile\' file+-- return $ length $ filter isDigit src+-- \"*.digits\" '*>' \\x -> do+-- v1 \<- digits ('dropExtension' x)+-- v2 \<- digits ('dropExtension' x)+-- 'Development.Shake.writeFile'' x $ show (v1,v2)+-- @+--+-- To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most+-- once per execution.+newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)+newCache = rulesIO . newCacheIO++ -- | Run an action without counting to the thread limit, typically used for actions that execute -- on remote machines using barely any local CPU resources. Unsafe as it allows the 'shakeThreads' limit to be exceeded.--- You cannot call 'apply' / 'Development.Shake.need' while the extra thread is executing.+-- You cannot depend on a rule (e.g. 'need') while the extra thread is executing. unsafeExtraThread :: Action a -> Action a unsafeExtraThread act = do s <- Action State.get
Development/Shake/Database.hs view
@@ -3,11 +3,12 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Development.Shake.Database(- Time, offsetTime, Duration, duration, Trace,+ Time, offsetTime, Duration, duration, Trace(..), Database, withDatabase,+ listDepends, lookupDependencies, Ops(..), build, Depends, progress,- Stack, emptyStack, showStack, topStack,+ Stack, emptyStack, topStack, showStack, showTopStack, showJSON, checkValid, ) where @@ -20,6 +21,7 @@ import Development.Shake.Types import Development.Shake.Special import General.Base+import General.String import General.Intern as Intern import Control.Exception@@ -55,9 +57,12 @@ addStack :: Id -> Key -> Stack -> Stack addStack x key (Stack _ xs set) = Stack (Just key) (x:xs) (Set.insert x set) -topStack :: Stack -> String-topStack (Stack key _ _) = maybe "<unknown>" show key+showTopStack :: Stack -> String+showTopStack = maybe "<unknown>" show . topStack +topStack :: Stack -> Maybe Key+topStack (Stack key _ _) = key+ checkStack :: [Id] -> Stack -> Maybe Id checkStack new (Stack _ old set) | bad:_ <- filter (`Set.member` set) new = Just bad@@ -70,8 +75,12 @@ --------------------------------------------------------------------- -- CENTRAL TYPES -type Trace = (BS, Time, Time) -- (message, start, end)+data Trace = Trace BS Time Time -- (message, start, end)+ deriving Show +instance NFData Trace where+ rnf (Trace a b c) = rnf a `seq` rnf b `seq` rnf c+ -- | Invariant: The database does not have any cycles when a Key depends on itself data Database = Database {lock :: Lock@@ -157,6 +166,22 @@ newtype Depends = Depends {fromDepends :: [Id]} deriving (NFData) +listDepends :: Database -> Depends -> IO [Key]+listDepends Database{..} (Depends xs) =+ withLock lock $ do+ status <- readIORef status+ return $ map (fst . fromJust . flip Map.lookup status) xs++lookupDependencies :: Database -> Key -> IO [Key]+lookupDependencies Database{..} k = do+ withLock lock $ do+ intern <- readIORef intern+ status <- readIORef status+ let Just i = Intern.lookup k intern+ let Just (_, Ready r) = Map.lookup i status+ return $ map (fst . fromJust . flip Map.lookup status) $ concat $ depends r++ data Ops = Ops {stored :: Key -> IO (Maybe Value) -- ^ Given a Key and a Value from the database, check it still matches the value stored on disk@@ -304,19 +329,20 @@ --------------------------------------------------------------------- -- PROGRESS --- Does not need to set shakeRunning, done by something further up progress :: Database -> IO Progress progress Database{..} = do s <- readIORef status return $ foldl' f mempty $ map snd $ Map.elems s where+ g = fromRational . toRational+ f s (Ready Result{..}) = if step == built- then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + execution}- else s{countSkipped = countSkipped s + 1, timeSkipped = timeSkipped s + execution}- f s (Loaded Result{..}) = s{countUnknown = countUnknown s + 1, timeUnknown = timeUnknown s + execution}+ then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + g execution}+ else s{countSkipped = countSkipped s + 1, timeSkipped = timeSkipped s + g execution}+ f s (Loaded Result{..}) = s{countUnknown = countUnknown s + 1, timeUnknown = timeUnknown s + g execution} f s (Waiting _ r) = let (d,c) = timeTodo s- t | Just Result{..} <- r = let d2 = d + execution in d2 `seq` (d2,c)+ t | Just Result{..} <- r = let d2 = d + g execution in d2 `seq` (d2,c) | otherwise = let c2 = c + 1 in c2 `seq` (d,c2) in s{countTodo = countTodo s + 1, timeTodo = t} f s _ = s@@ -381,17 +407,19 @@ ,"changed:" ++ showStep changed ,"depends:" ++ show (mapMaybe (`Map.lookup` ids) (concat depends)) ,"execution:" ++ show execution] ++- ["traces:[" ++ intercalate "," (map showTrace traces) ++ "]" | traces /= []]+ ["traces:[" ++ intercalate "," (map showTrace traces) ++ "]" | not $ null traces] showStep i = show $ fromJust $ Map.lookup i steps- showTrace (a,b,c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show (unpack a) ++ "}"+ showTrace (Trace a b c) = "{start:" ++ show b ++ ",stop:" ++ show c ++ ",command:" ++ show (unpack a) ++ "}" in ["{" ++ intercalate ", " xs ++ "}"] return $ "[" ++ intercalate "\n," (concat [maybe (error "Internal error in showJSON") f $ Map.lookup i status | i <- order]) ++ "\n]" -checkValid :: Database -> (Key -> IO (Maybe Value)) -> IO ()-checkValid Database{..} stored = do+checkValid :: Database -> (Key -> IO (Maybe Value)) -> [(Key, Key)] -> IO ()+checkValid Database{..} stored missing = do status <- readIORef status+ intern <- readIORef intern diagnostic "Starting validity/lint checking"+ -- Do not use a forM here as you use too much stack space bad <- (\f -> foldM f [] (Map.toList status)) $ \seen (i,v) -> case v of (key, Ready Result{..}) -> do@@ -400,7 +428,7 @@ diagnostic $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if good then "passed" else "FAILED" return $ [(key, result, now) | not good && not (specialAlwaysRebuilds result)] ++ seen _ -> return seen- if null bad then diagnostic "Validity/lint check passed" else do+ unless (null bad) $ do let n = length bad errorStructured ("Lint checking error - " ++ (if n == 1 then "value has" else show n ++ " values have") ++ " changed since being depended upon")@@ -408,6 +436,17 @@ | (key, result, now) <- bad]) "" + bad <- return [(parent,key) | (parent, key) <- missing, isJust $ Intern.lookup key intern]+ unless (null bad) $ do+ let n = length bad+ errorStructured+ ("Link checking error - " ++ (if n == 1 then "value" else show n ++ " values") ++ " did not have " ++ (if n == 1 then "its" else "their") ++ " creation tracked")+ (intercalate [("",Just "")] [ [("Rule", Just $ show parent), ("Created", Just $ show key)] | (parent,key) <- bad])+ ""++ diagnostic "Validity/lint check passed"++ --------------------------------------------------------------------- -- STORAGE @@ -454,8 +493,12 @@ getWith _ = get instance BinaryWith Witness Result where- putWith ws (Result x1 x2 x3 x4 x5 x6) = putWith ws x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6- getWith ws = do x1 <- getWith ws; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; return $ Result x1 x2 x3 x4 x5 x6+ putWith ws (Result x1 x2 x3 x4 x5 x6) = putWith ws x1 >> put x2 >> put x3 >> put (BinList $ map BinList x4) >> put (BinFloat x5) >> put (BinList x6)+ getWith ws = do x1 <- getWith ws; x2 <- get; x3 <- get; BinList x4 <- get; BinFloat x5 <- get; BinList x6 <- get; return $ Result x1 x2 x3 (map fromBinList x4) x5 x6++instance Binary Trace where+ put (Trace a b c) = put a >> put (BinFloat b) >> put (BinFloat c)+ get = do a <- get; BinFloat b <- get; BinFloat c <- get; return $ Trace a b c instance BinaryWith Witness Status where putWith ctx Missing = putWord8 0
Development/Shake/FileTime.hs view
@@ -6,7 +6,7 @@ ) where import Development.Shake.Classes-import General.Base+import General.String import Data.Char import Data.Int import Data.Word
Development/Shake/Progress.hs view
@@ -7,7 +7,6 @@ progressDisplayTester -- INTERNAL FOR TESTING ONLY ) where -import Control.Arrow import Control.Applicative import Control.Concurrent import Control.Exception@@ -73,45 +72,46 @@ ------------------------------------------------------------------------ STREAM TYPES - for writing the progress functions+-- MEALY TYPE - for writing the progress functions+-- See <http://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html> --- | A stream of values-newtype Stream a b = Stream {runStream :: a -> (b, Stream a b)}+-- | A machine that takes inputs and produces outputs+newtype Mealy i a = Mealy {runMealy :: i -> (a, Mealy i a)} -instance Functor (Stream a) where- fmap f (Stream op) = Stream $ (f *** fmap f) . op+instance Functor (Mealy i) where+ fmap f (Mealy m) = Mealy $ \i -> case m i of+ (x, m) -> (f x, fmap f m) -instance Applicative (Stream a) where- pure x = Stream $ const (x, pure x)- Stream ff <*> Stream xx = Stream $ \a ->- let (f1,f2) = ff a- (x1,x2) = xx a- in (f1 x1, f2 <*> x2)+instance Applicative (Mealy i) where+ pure x = let r = Mealy (const (x, r)) in r+ Mealy mf <*> Mealy mx = Mealy $ \i -> case mf i of+ (f, mf) -> case mx i of+ (x, mx) -> (f x, mf <*> mx) -idStream :: Stream a a-idStream = Stream $ \a -> (a, idStream)+echoMealy :: Mealy i i+echoMealy = Mealy $ \i -> (i, echoMealy) -oldStream :: b -> Stream a b -> Stream a (b,b)-oldStream old (Stream f) = Stream $ \a ->- let (new, f2) = f a- in ((old,new), oldStream new f2)+scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a+scanMealy f z (Mealy m) = Mealy $ \i -> case m i of+ (x, m) -> let z2 = f z x in (z2, scanMealy f z2 m) -iff :: Stream a Bool -> Stream a b -> Stream a b -> Stream a b-iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f+---------------------------------------------------------------------+-- MEALY UTILITIES -foldStream :: (a -> b -> a) -> a -> Stream i b -> Stream i a-foldStream f z (Stream op) = Stream $ \a ->- let (o1,o2) = op a- z2 = f z o1- in (z2, foldStream f z2 o2)+oldMealy :: a -> Mealy i a -> Mealy i (a,a)+oldMealy old = scanMealy (\(_,old) new -> (old,new)) (old,old) -posStream :: Stream a Int-posStream = foldStream (+) 0 $ pure 1+latch :: Mealy i (Bool, a) -> Mealy i a+latch s = fromJust <$> scanMealy f Nothing s+ where f old (b,v) = Just $ if b then fromMaybe v old else v -fromInt :: Int -> Double-fromInt = fromInteger . toInteger+iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a+iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f +posMealy :: Mealy i Int+posMealy = scanMealy (+) 0 $ pure 1+ -- decay'd division, compute a/b, with a decay of f -- r' is the new result, r is the last result -- r ~= a / b@@ -119,22 +119,19 @@ -- ------------- -- b + f*(b'-b) -- when f == 1, r == r'-decay :: Double -> Stream i Double -> Stream i Double -> Stream i Double-decay f a b = foldStream step 0 $ (,) <$> oldStream 0 a <*> oldStream 0 b+decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double+decay f a b = scanMealy step 0 $ (,) <$> oldMealy 0 a <*> oldMealy 0 b where step r ((a,a'),(b,b')) =((r*b) + f*(a'-a)) / (b + f*(b'-b)) -latch :: Stream i (Bool, a) -> Stream i a-latch = f Nothing- where f old (Stream op) = Stream $ \x -> let ((b,v),s) = op x- v2 = if b then fromMaybe v old else v- in (v2, f (Just v2) s)+fromInt :: Int -> Double+fromInt = fromInteger . toInteger --------------------------------------------------------------------- -- MESSAGE GENERATOR -message :: Double -> Stream Progress Progress -> Stream Progress String+message :: Double -> Mealy Progress Progress -> Mealy Progress String message sample progress = (\time perc -> time ++ " (" ++ perc ++ "%)") <$> time <*> perc where -- Number of seconds work completed@@ -155,12 +152,12 @@ where f Progress{..} guess = fst timeTodo + (fromIntegral (snd timeTodo) * guess) -- Number of seconds we have been going- step = fmap ((*) sample . fromInt) posStream+ step = fmap ((*) sample . fromInt) posMealy work = decay 1.2 done step -- Work value to use, don't divide by 0 and don't update work if done doesn't change realWork = iff ((==) 0 <$> done) (pure 1) $- latch $ (,) <$> (uncurry (==) <$> oldStream 0 done) <*> work+ latch $ (,) <$> (uncurry (==) <$> oldMealy 0 done) <*> work -- Display information time = flip fmap ((/) <$> todo <*> realWork) $ \guess ->@@ -200,15 +197,15 @@ progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO () progressDisplayer sleep sample disp prog = do disp "Starting..." -- no useful info at this stage- catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample idStream) (const $ disp "Finished")+ catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample echoMealy) (const $ disp "Finished") where- loop :: Stream Progress String -> IO ()- loop stream = do+ loop :: Mealy Progress String -> IO ()+ loop mealy = do when sleep $ threadDelay $ ceiling $ sample * 1000000 p <- prog- (msg, stream) <- return $ runStream stream p+ (msg, mealy) <- return $ runMealy mealy p disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)- loop stream+ loop mealy {-# NOINLINE xterm #-}
Development/Shake/Resource.hs view
@@ -105,7 +105,7 @@ -- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'. -- Most people should use 'Development.Shake.newResource' instead. newThrottleIO :: String -> Int -> Double -> IO Resource-newThrottleIO name count period = do+newThrottleIO name count period_ = do when (count < 0) $ error $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count key <- resourceId@@ -115,6 +115,7 @@ let s = Throttle lock rep time return $ Resource key shw (acquire s) (release s) where+ period = fromRational $ toRational period_ shw = "Throttle " ++ name release :: Throttle -> Int -> IO ()
+ Development/Shake/Rule.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}++-- | This module is used for defining new types of rules for Shake build systems.+-- Most users will find the built-in set of rules sufficient.+module Development.Shake.Rule(+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue,+#endif+ Rule(..), defaultRule, rule, apply, apply1,+ trackUse, trackChange, trackAllow+ ) where++import Development.Shake.Core
Development/Shake/Rules/Directory.hs view
@@ -9,14 +9,11 @@ defaultRuleDirectory ) where -import Control.Exception import Control.Monad import Control.Monad.IO.Class-import System.IO.Error import Data.Binary import Data.List import qualified System.Directory as IO-import qualified System.Environment as IO import Development.Shake.Core import Development.Shake.Classes@@ -106,20 +103,16 @@ instance Rule DoesFileExistQ DoesFileExistA where- storedValue (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x- -- invariant _ = True+ storedValue _ (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x instance Rule DoesDirectoryExistQ DoesDirectoryExistA where- storedValue (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x- -- invariant _ = True+ storedValue _ (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x instance Rule GetEnvQ GetEnvA where- storedValue (GetEnvQ x) = fmap (Just . GetEnvA) $ getEnvIO x- -- invariant _ = True+ storedValue _ (GetEnvQ x) = fmap (Just . GetEnvA) $ getEnvMaybe x instance Rule GetDirectoryQ GetDirectoryA where- storedValue x = fmap Just $ getDir x- -- invariant _ = True+ storedValue _ x = fmap Just $ getDir x -- | This function is not actually exported, but Haddock is buggy. Please ignore.@@ -132,7 +125,7 @@ defaultRule $ \(x :: GetDirectoryQ) -> Just $ liftIO $ getDir x defaultRule $ \(GetEnvQ x) -> Just $- liftIO $ fmap GetEnvA $ getEnvIO x+ liftIO $ fmap GetEnvA $ getEnvMaybe x -- | Returns 'True' if the file exists. The existence of the file is tracked as a@@ -161,9 +154,6 @@ GetEnvA res <- apply1 $ GetEnvQ var return res -getEnvIO :: String -> IO (Maybe String)-getEnvIO x = Control.Exception.catch (fmap Just $ IO.getEnv x) $- \e -> if isDoesNotExistError e then return Nothing else ioError e -- | Get the contents of a directory. The result will be sorted, and will not contain -- the entries @.@ or @..@ (unlike the standard Haskell version). The resulting paths will be relative@@ -252,7 +242,9 @@ removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir -- optimisation removeFiles dir pat = f "" >> return () where- test = let ps = map (?==) pat in \x -> any ($ x) ps+ -- because it is generate and match anything like ../ will be ignored, since we never generate ..+ -- therefore we can safely know we never escape dir+ test = let ps = map (?==) $ map normalise pat in \x -> any ($ x) ps -- dir </> dir2 is the part to operate on, return True if you cleaned everything f :: FilePath -> IO Bool
Development/Shake/Rules/File.hs view
@@ -2,20 +2,19 @@ module Development.Shake.Rules.File( need, needBS, needed, neededBS, want,+ trackRead, trackWrite, trackAllow, defaultRuleFile,- (*>), (**>), (?>), phony, (~>),- newCache, newCacheIO+ (*>), (**>), (?>), phony, (~>) ) where -import Control.Exception import Control.Monad import Control.Monad.IO.Class-import qualified Data.HashMap.Strict as Map import System.Directory import qualified Data.ByteString.Char8 as BS -import Development.Shake.Core-import General.Base+import Development.Shake.Core hiding (trackAllow)+import qualified Development.Shake.Core as S+import General.String import Development.Shake.Classes import Development.Shake.FilePattern import Development.Shake.FileTime@@ -42,61 +41,7 @@ instance Show FileA where show (FileA x) = "FileTimeHash " ++ show x instance Rule FileQ FileA where- storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x--{-- observed act = do- src <- getCurrentDirectory- old <- listDir src- sleepFileTime- res <- act- new <- listDir src- let obs = compareItems old new- -- if we didn't find anything used, then most likely we aren't tracking access time close enough- obs2 = obs{used = if used obs == Just [] then Nothing else (used obs)}- return (obs2, res)---data Item = ItemDir [(String,Item)] -- sorted- | ItemFile (Maybe FileTime) (Maybe FileTime) -- mod time, access time- deriving Show--listDir :: FilePath -> IO Item-listDir root = do- xs <- getDirectoryContents root- xs <- return $ sort $ filter (not . all (== '.')) xs- fmap ItemDir $ forM xs $ \x -> fmap ((,) x) $ do- let s = root </> x- b <- doesFileExist s- if b then listFile s else listDir s--listFile :: FilePath -> IO Item-listFile x = do- let f x = Control.Exception.catch (fmap Just x) $ \(_ :: SomeException) -> return Nothing- mod <- f $ getModTime x- acc <- f $ getAccTime x- return $ ItemFile mod acc--compareItems :: Item -> Item -> Observed File-compareItems = f ""- where- f path (ItemFile mod1 acc1) (ItemFile mod2 acc2) =- Observed (Just [File path | mod1 /= mod2]) (Just [File path | acc1 /= acc2])- f path (ItemDir xs) (ItemDir ys) = mconcat $ map g $ zips xs ys- where g (name, Just x, Just y) = f (path </> name) x y- g (name, x, y) = Observed (Just $ concatMap (files path) $ catMaybes [x,y]) Nothing- f path _ _ = Observed (Just [File path]) Nothing-- files path (ItemDir xs) = concat [files (path </> a) b | (a,b) <- xs]- files path _ = [File path]-- zips :: Ord a => [(a,b)] -> [(a,b)] -> [(a, Maybe b, Maybe b)]- zips ((x1,x2):xs) ((y1,y2):ys)- | x1 == y1 = (x1,Just x2,Just y2):zips xs ys- | x1 < y1 = (x1,Just x2,Nothing):zips xs ((y1,y2):ys)- | otherwise = (y1,Nothing,Just y2):zips ((x1,x2):xs) ys- zips xs ys = [(a,Just b,Nothing) | (a,b) <- xs] ++ [(a,Nothing,Just b) | (a,b) <- ys]--}+ storedValue _ (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x -- | This function is not actually exported, but Haddock is buggy. Please ignore.@@ -130,13 +75,13 @@ needed :: [FilePath] -> Action () needed xs = do opts <- getShakeOptions- if not $ shakeLint opts then need xs else neededCheck $ map packU xs+ if isNothing $ shakeLint opts then need xs else neededCheck $ map packU xs neededBS :: [BS.ByteString] -> Action () neededBS xs = do opts <- getShakeOptions- if not $ shakeLint opts then needBS xs else neededCheck $ map packU_ xs+ if isNothing $ shakeLint opts then needBS xs else neededCheck $ map packU_ xs neededCheck :: [BSU] -> Action ()@@ -154,6 +99,27 @@ "" +-- | Track that a file was read by the action preceeding it. If 'shakeLint' is activated+-- then these files must be dependencies of this rule. Calls to 'trackRead' are+-- automatically inserted in 'LintTracker' mode.+trackRead :: [FilePath] -> Action ()+trackRead = mapM_ (trackUse . FileQ . packU)++-- | Track that a file was written by the action preceeding it. If 'shakeLint' is activated+-- then these files must either be the target of this rule, or never referred to by the build system.+-- Calls to 'trackWrite' are automatically inserted in 'LintTracker' mode.+trackWrite :: [FilePath] -> Action ()+trackWrite = mapM_ (trackChange . FileQ . packU)++-- | Allow accessing a file in this rule, ignoring any 'trackRead'\/'trackWrite' calls matching+-- the pattern.+trackAllow :: [FilePattern] -> Action ()+trackAllow ps = do+ opts <- getShakeOptions+ when (isJust $ shakeLint opts) $+ S.trackAllow $ \(FileQ x) -> any (?== unpackU x) ps++ -- | Require that the argument files are built by the rules, used to specify the target. -- -- @@@ -235,46 +201,3 @@ -- Note that matching is case-sensitive, even on Windows. (*>) :: FilePattern -> (FilePath -> Action ()) -> Rules () (*>) test = root (show test) (test ?==)----- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.--- Most people should use 'newCache' instead.-newCacheIO :: (FilePath -> IO a) -> IO (FilePath -> Action a)-newCacheIO act = do- var <- newVar Map.empty -- Var (Map FilePath (Barrier (Either SomeException a)))- let run = either (\e -> throwIO (e :: SomeException)) return- return $ \file -> do- need [file]- liftIO $ join $ modifyVar var $ \mp -> case Map.lookup file mp of- Just v -> return (mp, run =<< waitBarrier v)- Nothing -> do- v <- newBarrier- return $ (,) (Map.insert file v mp) $ do- res <- try $ act file- signalBarrier v res- run res----- | Given a way of loading information from a file, produce a cached version that will load each file at most once.--- Using the cached function will still result in a dependency on the original file.--- The argument function should not access any files other than the one passed as its argument.--- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.------ This function is useful when creating files that store intermediate values,--- to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.--- As an example:------ @--- digits \<- 'newCache' $ \\file -> do--- src \<- readFile file--- return $ length $ filter isDigit src--- \"*.digits\" '*>' \\x -> do--- v1 \<- digits ('dropExtension' x)--- v2 \<- digits ('dropExtension' x)--- 'Development.Shake.writeFile'' x $ show (v1,v2)--- @------ To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most--- once per execution.-newCache :: (FilePath -> IO a) -> Rules (FilePath -> Action a)-newCache = rulesIO . newCacheIO
Development/Shake/Rules/Files.hs view
@@ -9,8 +9,9 @@ import Data.Maybe import System.Directory -import Development.Shake.Core+import Development.Shake.Core hiding (trackAllow) import General.Base+import General.String import Development.Shake.Classes import Development.Shake.Rules.File import Development.Shake.FilePattern@@ -34,7 +35,7 @@ instance Rule FilesQ FilesA where- storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs+ storedValue _ (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs -- | Define a rule for building multiple files at the same time.@@ -65,6 +66,7 @@ rule $ \(FilesQ xs_) -> let xs = map unpackU xs_ in if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs+ trackAllow xs act xs liftIO $ getFileTimes "*>>" xs_
Development/Shake/Rules/Oracle.hs view
@@ -29,7 +29,7 @@ Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a #endif ) => Rule (OracleQ q) (OracleA a) where- storedValue _ = return Nothing+ storedValue _ _ = return Nothing -- | Add extra information which rules can depend on.
Development/Shake/Rules/OrderOnly.hs view
@@ -5,7 +5,7 @@ ) where import Development.Shake.Core-import General.Base+import General.String import Development.Shake.Classes import Development.Shake.Rules.File import qualified Data.ByteString.Char8 as BS@@ -23,7 +23,7 @@ instance Rule OrderOnlyQ OrderOnlyA where- storedValue (OrderOnlyQ _) = return $ Just $ OrderOnlyA ()+ storedValue _ (OrderOnlyQ _) = return $ Just $ OrderOnlyA () defaultRuleOrderOnly :: Rules ()
Development/Shake/Rules/Rerun.hs view
@@ -18,7 +18,7 @@ instance Eq AlwaysRerunA where a == b = False instance Rule AlwaysRerunQ AlwaysRerunA where- storedValue _ = return Nothing+ storedValue _ _ = return Nothing -- | Always rerun the associated action. Useful for defining rules that query
Development/Shake/Storage.hs view
@@ -43,7 +43,8 @@ -- THINGS I WANT TO DO ON THE NEXT CHANGE -- * Change FileTime to be a Word32, not an Int32, with maxBound for fileNone -- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8-databaseVersion x = "SHAKE-DATABASE-8-" ++ s ++ "\r\n"+-- * Duration and Time should be stored as number of 1/10000th seconds Int32+databaseVersion x = "SHAKE-DATABASE-9-" ++ s ++ "\r\n" where s = tail $ init $ show x -- call show, then take off the leading/trailing quotes -- ensures we do not get \r or \n in the user portion
Development/Shake/Sys.hs view
@@ -19,7 +19,7 @@ -- -- Note that we enclose @output@ as a list so that if the output name contains spaces they are -- appropriately escaped.-module Development.Shake.Sys(+module Development.Shake.Sys {-# DEPRECATED "Use 'command' or 'cmd' instead" #-} ( sys, sysCwd, sysOutput, args ) where
Development/Shake/Types.hs view
@@ -2,7 +2,7 @@ -- | Types exposed to the user module Development.Shake.Types(- Progress(..), Verbosity(..), Assume(..),+ Progress(..), Verbosity(..), Assume(..), Lint(..), ShakeOptions(..), shakeOptions ) where @@ -36,6 +36,37 @@ deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum) +-- | Which lint checks to perform, used by 'shakeLint'.+data Lint+ = LintBasic+ -- ^ The most basic form of linting. Checks that the current directory does not change and that results do not change after they+ -- are first written. Any calls to 'needed' will assert that they do not cause a rule to be rebuilt.+ | LintTracker+ -- ^ Track which files are accessed by command line programs run by 'command' or 'cmd', using @tracker.exe@ as supplied+ -- with the Microsoft .NET 4.5 SDK (Windows only). Also performs all checks from 'LintBasic'. Note that some programs are not+ -- tracked properly, particularly cygwin programs (it seems).+ deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum)+++{-+-- | How should you determine if a file has changed, used by 'shakeChange'.+data Change+ = ChangeModtime+ -- ^ Compare equality of modification timestamps, a file has changed if its last modified time changes.+ -- A @touch@ will force a rebuild. This mode is fast and usually sufficiently accurate, so is the default.+ | ChangeDigest+ -- ^ Compare equality of file contents digests, a file has changed if its digest changes.+ -- A @touch@ will not force a rebuild. Use this mode if modification times on your file system are unreliable.+ | ChangeModtimeAndDigest+ -- ^ A file is rebuilt if both its modification time and digest have changed. For efficiency reasons, the modification+ -- time is checked first, and if that has changed, the digest is checked which may mark+ | ChangeModtimeOrDigest+ -- ^ A file is rebuilt if either its modification time or its digest has changed. A @touch@ will force a rebuild,+ -- but even if a files modification time is reset afterwards, changes will also cause a rebuild.+ deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum)+-}++ -- | Options to control the execution of Shake, usually specified by overriding fields in -- 'shakeOptions': --@@ -65,7 +96,7 @@ ,shakeReport :: Maybe FilePath -- ^ Defaults to 'Nothing'. Write an HTML profiling report to a file, showing which -- rules rebuilt, why, and how much time they took. Useful for improving the speed of your build systems.- ,shakeLint :: Bool+ ,shakeLint :: Maybe Lint -- ^ Defaults to 'False'. Perform basic sanity checks during building, checking the current directory -- is not modified and that output files are not modified by multiple rules. -- These sanity checks do not check for missing or redundant dependencies.@@ -103,7 +134,7 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False (Just 10) Nothing [] False True False True+shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing Nothing (Just 10) Nothing [] False True False True (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS @@ -134,6 +165,7 @@ | Just x <- cast x = show (x :: Bool) | Just x <- cast x = show (x :: Maybe FilePath) | Just x <- cast x = show (x :: Maybe Assume)+ | Just x <- cast x = show (x :: Maybe Lint) | Just x <- cast x = show (x :: Maybe Double) | Just x <- cast x = show (x :: [(String,String)]) | Just x <- cast x = show (x :: Function (IO Progress -> IO ()))
Development/Shake/Util.hs view
@@ -1,7 +1,8 @@ -- | A module for useful utility functions for Shake build systems. module Development.Shake.Util(- parseMakefile, needMakefileDependencies, neededMakefileDependencies+ parseMakefile, needMakefileDependencies, neededMakefileDependencies,+ shakeArgsAccumulate ) where import Development.Shake@@ -9,6 +10,8 @@ import qualified Data.ByteString.Char8 as BS import qualified Development.Shake.ByteString as BS import Control.Arrow+import Data.List+import System.Console.GetOpt -- | Given the text of a Makefile, extract the list of targets and dependencies. Assumes a@@ -32,3 +35,26 @@ -- > neededMakefileDependencies file = needed . concatMap snd . parseMakefile =<< liftIO (readFile file) neededMakefileDependencies :: FilePath -> Action () neededMakefileDependencies file = neededBS . concatMap snd . BS.parseMakefile =<< liftIO (BS.readFile file)+++-- | Like `shakeArgsWith`, but instead of accumulating a list of flags, apply functions to a default value.+-- Usually used to populate a record structure. As an example of a build system that can use either @gcc@ or @distcc@ for compiling:+--+-- @+--import System.Console.GetOpt+--+--data Flags = Flags {distCC :: Bool} deriving Eq+--flags = [Option \"\" [\"distcc\"] (NoArg $ Right $ \\x -> x{distCC=True}) \"Run distributed.\"]+--+--main = 'shakeArgsAccumulate' 'shakeOptions' flags (Flags False) $ \\flags targets -> return $ Just $ do+-- if null targets then 'want' [\"result.exe\"] else 'want' targets+-- let compiler = if distCC flags then \"distcc\" else \"gcc\"+-- \"*.o\" '*>' \\out -> do+-- 'need' ...+-- 'cmd' compiler ...+-- ...+-- @+--+-- Now you can pass @--distcc@ to use the @distcc@ compiler.+shakeArgsAccumulate :: ShakeOptions -> [OptDescr (Either String (a -> a))] -> a -> (a -> [String] -> IO (Maybe (Rules ()))) -> IO ()+shakeArgsAccumulate opts flags def f = shakeArgsWith opts flags $ \flags targets -> f (foldl' (flip ($)) def flags) targets
Development/Shake/Value.hs view
@@ -20,6 +20,7 @@ import Data.List import Data.Maybe import qualified Data.HashMap.Strict as Map+import qualified Data.ByteString.Char8 as BS import System.IO.Unsafe @@ -62,9 +63,8 @@ hashWithSalt salt (Value a) = hashWithSalt salt (typeOf a) `xor` hashWithSalt salt a instance Eq Value where- Value a == Value b = case cast b of- Just bb -> a == bb- Nothing -> False+ Value a == Value b = maybe False (a ==) $ cast b+ Value a /= Value b = maybe False (a /=) $ cast b ---------------------------------------------------------------------@@ -105,9 +105,9 @@ instance Binary Witness where- put (Witness ts _ _) = put ts+ put (Witness ts _ _) = put $ BS.unlines $ map BS.pack ts get = do- ts <- get+ ts <- fmap (map BS.unpack . BS.lines) get let ws = toStableList $ unsafePerformIO $ readIORefAfter ts witness let (is,ks,vs) = unzip3 [(i,k,v) | (i,t) <- zip [0..] ts, (k,v):_ <- [filter ((==) t . show . fst) ws]] return $ Witness ts (Map.fromList $ zip is vs) (Map.fromList $ zip ks is)
Examples/Self/Main.hs view
@@ -57,13 +57,10 @@ xs <- filterM (doesFileExist . fixPaths . moduleToFile "hs") xs writeFileLines out xs - obj "/*.hi" *> \out -> do- need [out -<.> "o"]-- obj "/*.o" *> \out -> do- dep <- readFileLines $ out -<.> "dep"+ [obj "/*.o",obj "/*.hi"] *>> \[out,_] -> do+ deps <- readFileLines $ out -<.> "deps" let hs = fixPaths $ unobj $ out -<.> "hs"- need $ hs : map (obj . moduleToFile "hi") dep+ need $ hs : map (obj . moduleToFile "hi") deps ghc ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] obj ".pkgs" *> \out -> do
Examples/Test/Basic.hs view
@@ -2,6 +2,7 @@ module Examples.Test.Basic(main) where import Development.Shake+import Development.Shake.FilePath import Examples.Util import System.Directory as IO import Data.List@@ -47,6 +48,14 @@ need ["dummy"] liftIO $ appendFile out "1" + r <- newResource ".log file" 1+ obj "*.par" *> \out -> do+ let trace x = withResource r 1 $ liftIO $ appendFile (takeDirectory out </> ".log") x+ trace "["+ liftIO $ sleep 0.1+ trace "]"+ writeFile' out out+ test build obj = do writeFile (obj "A.txt") "AAA" writeFile (obj "B.txt") "BBB"@@ -79,6 +88,7 @@ assert b "Directory should exist, cleaner should not have removed it" build ["!cleaner"]+ sleep 1 -- sometimes takes a while for the file system to notice b <- IO.doesDirectoryExist (obj "") assert (not b) "Directory should not exist, cleaner should have removed it" @@ -103,3 +113,12 @@ assertContents (obj "dummer.txt") "1" build ["dummer.txt"] assertContents (obj "dummer.txt") "11"++ build ["1.par","2.par","-j1"]+ assertContents (obj ".log") "[][]"+ writeFile (obj ".log") ""+ build ["3.par","4.par","-j2"]+ assertContents (obj ".log") "[[]]"+ writeFile (obj ".log") ""+ build ["5.par","6.par","-j0"] -- all machines have at least 2 processors nowadays+ assertContents (obj ".log") "[[]]"
Examples/Test/Cache.hs view
@@ -10,8 +10,8 @@ main = shaken test $ \args obj -> do want $ map obj args vowels <- newCache $ \file -> do- src <- readFile file- appendFile (obj "trace.txt") "1"+ src <- readFile' file+ liftIO $ appendFile (obj "trace.txt") "1" return $ length $ filter isDigit src obj "*.out*" *> \x -> writeFile' x . show =<< vowels (dropExtension x <.> "txt")
Examples/Test/Command.hs view
@@ -27,8 +27,9 @@ (Exit exit, Stdout stdout, Stderr stderr) <- cmd "ghc --random" return $ show (exit, stdout, stderr) -- must force all three parts + obj "pwd space.hs" *> \out -> writeFileLines out ["import System.Directory","main = putStrLn =<< getCurrentDirectory"] "pwd" !> do- writeFileLines (obj "pwd space.hs") ["import System.Directory","main = putStrLn =<< getCurrentDirectory"]+ need [obj "pwd space.hs"] Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"] return out @@ -52,7 +53,7 @@ build ["pwd"] assertContentsInfix (obj "pwd") "command" - build ["env"]+ build ["env","--no-lint"] -- since it blows away the $PATH, which is necessary for lint-tracker assertContentsInfix (obj "env") "HELLO SHAKE" build ["triple"]
Examples/Test/Docs.hs view
@@ -21,9 +21,12 @@ want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args + let needSource = need =<< getDirectoryFiles "." ["Development/Shake.hs","Development/Shake//*.hs","General//*.hs"]+ index *> \_ -> do- xs <- getDirectoryFiles "Development" ["//*.hs"]- need $ map ("Development" </>) xs+ needSource+ need ["shake.cabal"]+ trackAllow ["dist//*"] res <- liftIO $ findExecutable "cabal" if isJust res then cmd "cabal haddock" else do Exit exit <- cmd "runhaskell Setup.hs haddock"@@ -45,6 +48,7 @@ (imports,rest) = partition ("import " `isPrefixOf`) code writeFileLines out $ ["{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}"+ ,"{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}" ,"module " ++ takeBaseName out ++ "() where" ,"import Control.Concurrent" ,"import Control.Monad"@@ -54,6 +58,7 @@ ,"import Data.Monoid" ,"import Development.Shake" ,"import Development.Shake.Classes"+ ,"import Development.Shake.Rule" ,"import Development.Shake.Util" ,"import System.Console.GetOpt" ,"import System.Exit"@@ -81,16 +86,22 @@ ] ++ rest - obj "Main.hs" *> \out -> do+ obj "Files.lst" *> \out -> do need [index,obj "Paths_shake.hs"] files <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] files <- return $ filter (not . isSuffixOf "-Classes.html") files- let mods = map ((++) "Part_" . reps '-' '_' . takeBaseName) files- need [obj m <.> "hs" | m <- mods]+ writeFileLines out $ map ((++) "Part_" . reps '-' '_' . takeBaseName) files++ let needModules = do mods <- readFileLines $ obj "Files.lst"; need [obj m <.> "hs" | m <- mods]; return mods++ obj "Main.hs" *> \out -> do+ mods <- needModules writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"] obj "Success.txt" *> \out -> do- need [obj "Main.hs"]+ needModules+ need [obj "Main.hs", obj "Paths_shake.hs"]+ needSource () <- cmd "runhaskell -ignore-package=hashmap" ["-i" ++ obj "", obj "Main.hs"] writeFile' out ""
Examples/Test/Errors.hs view
@@ -48,7 +48,13 @@ withResource res 1 $ need ["resource-dep"] + obj "overlap.txt" *> \out -> writeFile' out "overlap.txt"+ obj "overlap.*" *> \out -> writeFile' out "overlap.*"+ alternatives $ do+ obj "alternative.txt" *> \out -> writeFile' out "alternative.txt"+ obj "alternative.*" *> \out -> writeFile' out "alternative.*" + test build obj = do let crash args parts = assertException parts (build $ "--quiet" : args) @@ -78,3 +84,10 @@ assertContents (obj "exception2") "0" crash ["resource"] ["cannot currently call apply","withResource","resource_name"]++ build ["overlap.foo"]+ assertContents (obj "overlap.foo") "overlap.*"+ crash ["overlap.txt"] ["key matches multiple rules","overlap.txt"]+ build ["alternative.foo","alternative.txt"]+ assertContents (obj "alternative.foo") "alternative.*"+ assertContents (obj "alternative.txt") "alternative.txt"
Examples/Test/Lint.hs view
@@ -6,6 +6,8 @@ import Examples.Util import Control.Exception hiding (assert) import System.Directory as IO+import Control.Monad+import Data.Maybe main = shaken test $ \args obj -> do@@ -66,6 +68,29 @@ needed [obj "gen2"] writeFile' out "" + obj "tracker-write1" *> \out -> do+ () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]+ need [out <.> "txt"]+ writeFile' out ""++ obj "tracker-write2" *> \out -> do+ () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]+ writeFile' out ""++ obj "tracker-source2" *> \out -> copyFile' (obj "tracker-source1") out+ obj "tracker-read1" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]+ writeFile' out ""+ obj "tracker-read2" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]+ need [obj "tracker-source1"]+ writeFile' out ""+ obj "tracker-read3" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source2") ++ " > nul"]+ need [obj "tracker-source2"]+ writeFile' out ""++ test build obj = do dir <- getCurrentDirectory let crash args parts = do@@ -82,3 +107,13 @@ crash ["--clean","listing","existance"] ["changed since being depended upon"] crash ["needed1"] ["'needed' file required rebuilding"] build ["needed2"]++ tracker <- findExecutable "tracker.exe"+ when (isJust tracker) $ do+ writeFile (obj "tracker-source1") ""+ writeFile (obj "tracker-source2") ""+ crash ["tracker-write1"] ["not have its creation tracked","lint/tracker-write1","lint/tracker-write1.txt"]+ build ["tracker-write2"]+ crash ["tracker-read1"] ["used but not depended upon","lint/tracker-source1"]+ build ["tracker-read2"]+ crash ["tracker-read3"] ["depended upon after being used","lint/tracker-source2"]
Examples/Util.hs view
@@ -2,6 +2,7 @@ module Examples.Util(sleep, module Examples.Util) where import Development.Shake+import Development.Shake.Rule() -- ensure the module gets imported, and thus tested import General.Base import Development.Shake.FilePath @@ -9,6 +10,7 @@ import Control.Monad import Data.Char import Data.List+import Data.Maybe import System.Directory as IO import System.Environment import System.Random@@ -55,10 +57,11 @@ args -> do let (_,files,_) = getOpt Permute [] args+ tracker <- findExecutable "tracker.exe" withArgs (args \\ files) $ shakeWithClean (removeDirectoryRecursive out) - (shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html", shakeLint=True})+ (shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html", shakeLint=Just $ if isJust tracker then LintTracker else LintBasic}) (rules files (out++))
General/Base.hs view
@@ -1,16 +1,15 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module General.Base( Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar,- Barrier, newBarrier, signalBarrier, waitBarrier,+ Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, Duration, duration, Time, offsetTime, sleep,- isWindows,+ isWindows, getProcessorCount,+ readFileUCS2, getEnvMaybe, modifyIORef'', writeIORef'',- whenJust, loop, whileM, partitionM, concatMapM,+ whenJust, loop, whileM, partitionM, concatMapM, mapMaybeM, fastNub, showQuote,- BS, pack, unpack, pack_, unpack_,- BSU, packU, unpackU, packU_, unpackU_, requireU ) where import Control.Concurrent@@ -18,11 +17,14 @@ import Control.Monad import Data.Char import Data.IORef+import Data.List+import Data.Maybe import Data.Time-import qualified Data.ByteString as BS (any)-import qualified Data.ByteString.Char8 as BS hiding (any)-import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.HashSet as Set+import System.Environment+import System.IO+import System.IO.Error+import System.IO.Unsafe import Development.Shake.Classes @@ -87,11 +89,17 @@ waitBarrier :: Barrier a -> IO a waitBarrier (Barrier x) = readMVar x +waitBarrierMaybe :: Barrier a -> IO (Maybe a)+waitBarrierMaybe (Barrier x) = do+ res <- tryTakeMVar x+ whenJust res $ putMVar x+ return res + --------------------------------------------------------------------- -- Data.Time -type Time = Double -- how far you are through this run, in seconds+type Time = Float -- how far you are through this run, in seconds -- | Call once at the start, then call repeatedly to get Time values out offsetTime :: IO (IO Time)@@ -102,7 +110,7 @@ return $ fromRational $ toRational $ end `diffUTCTime` start -type Duration = Double -- duration in seconds+type Duration = Float -- duration in seconds duration :: IO a -> IO (Duration, a) duration act = do@@ -174,6 +182,8 @@ (a,b) <- partitionM f xs return $ if t then (x:a,b) else (a,x:b) +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f xs = liftM catMaybes $ mapM f xs ---------------------------------------------------------------------@@ -186,56 +196,27 @@ isWindows = False #endif -------------------------------------------------------------------------- Data.ByteString--- Mostly because ByteString does not have an NFData instance in older GHC---- | ASCII ByteString-newtype BS = BS BS.ByteString- deriving (Hashable, Binary, Eq)--instance Show BS where- show (BS x) = show x--instance NFData BS where- -- some versions of ByteString do not have NFData instances, but seq is equivalent- -- for a strict bytestring. Therefore, we write our own instance.- rnf (BS x) = x `seq` ()----- | UTF8 ByteString-newtype BSU = BSU BS.ByteString- deriving (Hashable, Binary, Eq)--instance NFData BSU where- rnf (BSU x) = x `seq` ()-+-- Could be written better in C, but sticking to Haskell for laziness+getProcessorCount :: IO Int+-- unsafePefromIO so we cache the result and only compute it once+getProcessorCount = let res = unsafePerformIO act in return res+ where+ act = handle (\(_ :: SomeException) -> return 1) $ do+ env <- getEnvMaybe "NUMBER_OF_PROCESSORS"+ case env of+ Just s | [(i,"")] <- reads s -> return i+ _ -> do+ src <- readFile "/proc/cpuinfo"+ return $ length [() | x <- lines src, "processor" `isPrefixOf` x] -pack :: String -> BS-pack = pack_ . BS.pack--unpack :: BS -> String-unpack = BS.unpack . unpack_--pack_ :: BS.ByteString -> BS-pack_ = BS--unpack_ :: BS -> BS.ByteString-unpack_ (BS x) = x--packU :: String -> BSU-packU = packU_ . UTF8.fromString--unpackU :: BSU -> String-unpackU = UTF8.toString . unpackU_--unpackU_ :: BSU -> BS.ByteString-unpackU_ (BSU x) = x+---------------------------------------------------------------------+-- System.IO -packU_ :: BS.ByteString -> BSU-packU_ = BSU+readFileUCS2 :: FilePath -> IO String+readFileUCS2 name = openFile name ReadMode >>= \h -> do+ hSetEncoding h utf16+ hGetContents h -requireU :: BSU -> Bool-requireU = BS.any (>= 0x80) . unpackU_+getEnvMaybe :: String -> IO (Maybe String)+getEnvMaybe x = catchJust (\x -> if isDoesNotExistError x then Just x else Nothing) (fmap Just $ getEnv x) (const $ return Nothing)
General/Binary.hs view
@@ -1,12 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module General.Binary(- BinaryWith(..), module Data.Binary+ BinaryWith(..), module Data.Binary,+ BinList(..), BinFloat(..) ) where import Control.Monad import Data.Binary+import Data.List+import Foreign+import System.IO.Unsafe as U + class BinaryWith ctx a where putWith :: ctx -> a -> Put getWith :: ctx -> Get a@@ -23,3 +28,35 @@ putWith ctx Nothing = putWord8 0 putWith ctx (Just x) = putWord8 1 >> putWith ctx x getWith ctx = do i <- getWord8; if i == 0 then return Nothing else fmap Just $ getWith ctx+++newtype BinList a = BinList {fromBinList :: [a]}++instance Show a => Show (BinList a) where show = show . fromBinList++instance Binary a => Binary (BinList a) where+ put (BinList xs) = case splitAt 254 xs of+ (a, []) -> putWord8 (genericLength xs) >> mapM_ put xs+ (a, b) -> putWord8 255 >> mapM_ put xs >> put (BinList b)+ get = do+ x <- getWord8+ case x of+ 255 -> do xs <- replicateM 254 get; BinList ys <- get; return $ BinList $ xs ++ ys+ n -> fmap BinList $ replicateM (fromInteger $ toInteger n) get+++newtype BinFloat = BinFloat {fromBinFloat :: Float}++instance Show BinFloat where show = show . fromBinFloat++instance Binary BinFloat where+ put (BinFloat x) = put (convert x :: Word32)+ get = fmap (BinFloat . convert) (get :: Get Word32)+++-- Originally from data-binary-ieee754 package++convert :: (Storable a, Storable b) => a -> b+convert x = U.unsafePerformIO $ alloca $ \buf -> do+ poke (castPtr buf) x+ peek buf
+ General/String.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module General.String(+ BS, pack, unpack, pack_, unpack_,+ BSU, packU, unpackU, packU_, unpackU_, requireU+ ) where++import qualified Data.ByteString as BS (any)+import qualified Data.ByteString.Char8 as BS hiding (any)+import qualified Data.ByteString.UTF8 as UTF8+import Development.Shake.Classes+++---------------------------------------------------------------------+-- Data.ByteString+-- Mostly because ByteString does not have an NFData instance in older GHC++-- | ASCII ByteString+newtype BS = BS BS.ByteString+ deriving (Hashable, Binary, Eq)++instance Show BS where+ show (BS x) = show x++instance NFData BS where+ -- some versions of ByteString do not have NFData instances, but seq is equivalent+ -- for a strict bytestring. Therefore, we write our own instance.+ rnf (BS x) = x `seq` ()+++-- | UTF8 ByteString+newtype BSU = BSU BS.ByteString+ deriving (Hashable, Binary, Eq)++instance NFData BSU where+ rnf (BSU x) = x `seq` ()++++pack :: String -> BS+pack = pack_ . BS.pack++unpack :: BS -> String+unpack = BS.unpack . unpack_++pack_ :: BS.ByteString -> BS+pack_ = BS++unpack_ :: BS -> BS.ByteString+unpack_ (BS x) = x++packU :: String -> BSU+packU = packU_ . UTF8.fromString++unpackU :: BSU -> String+unpackU = UTF8.toString . unpackU_++unpackU_ :: BSU -> BS.ByteString+unpackU_ (BSU x) = x++packU_ :: BS.ByteString -> BSU+packU_ = BSU++requireU :: BSU -> Bool+requireU = BS.any (>= 0x80) . unpackU_
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2011-2013.+Copyright Neil Mitchell 2011-2014. All rights reserved. Redistribution and use in source and binary forms, with or without
Test.hs view
@@ -10,7 +10,7 @@ import Development.Shake.Pool import General.Timing import Development.Shake.FileTime-import General.Base+import General.String import qualified Data.ByteString.Char8 as BS import Examples.Util(sleepFileTime, sleepFileTimeCalibrate) import Control.Concurrent
shake.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.10.10+version: 0.11 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2011-2013+copyright: Neil Mitchell 2011-2014 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a@@ -30,6 +30,7 @@ support for generated files, and dependencies on system information (e.g. compiler version). homepage: https://github.com/ndmitchell/shake+tested-with: GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 extra-source-files: Examples/C/constants.c Examples/C/constants.h@@ -90,6 +91,7 @@ Development.Shake.Classes Development.Shake.Command Development.Shake.FilePath+ Development.Shake.Rule Development.Shake.Sys Development.Shake.Util @@ -120,6 +122,7 @@ General.Base General.Binary General.Intern+ General.String General.Timing Paths_shake @@ -158,6 +161,7 @@ Development.Make.Type Development.Ninja.All Development.Ninja.Env+ Development.Ninja.Lexer Development.Ninja.Parse Development.Ninja.Type Start