shake 0.12 → 0.13
raw patch · 49 files changed
+723/−374 lines, 49 filesdep ~base
Dependency ranges changed: base
Files
- CHANGES.txt +14/−0
- Development/Make/Rules.hs +10/−7
- Development/Make/Type.hs +0/−1
- Development/Ninja/All.hs +2/−2
- Development/Ninja/Env.hs +1/−1
- Development/Ninja/Type.hs +0/−1
- Development/Shake.hs +5/−4
- Development/Shake/Args.hs +7/−3
- Development/Shake/Command.hs +23/−15
- Development/Shake/Core.hs +57/−37
- Development/Shake/Database.hs +45/−26
- Development/Shake/Derived.hs +4/−1
- Development/Shake/Errors.hs +1/−1
- Development/Shake/FileInfo.hs +138/−0
- Development/Shake/FilePath.hs +3/−0
- Development/Shake/FilePattern.hs +6/−1
- Development/Shake/FileTime.hs +0/−118
- Development/Shake/Pool.hs +2/−1
- Development/Shake/Report.hs +57/−11
- Development/Shake/Rule.hs +15/−2
- Development/Shake/Rules/Directory.hs +8/−6
- Development/Shake/Rules/File.hs +69/−23
- Development/Shake/Rules/Files.hs +54/−33
- Development/Shake/Rules/OrderOnly.hs +1/−1
- Development/Shake/Rules/Rerun.hs +1/−1
- Development/Shake/Special.hs +1/−1
- Development/Shake/Storage.hs +1/−2
- Development/Shake/Types.hs +34/−19
- Examples/Ninja/Main.hs +1/−1
- Examples/Self/Main.hs +1/−1
- Examples/Test/Command.hs +2/−2
- Examples/Test/Digest.hs +78/−0
- Examples/Test/Directory.hs +1/−2
- Examples/Test/Docs.hs +4/−4
- Examples/Test/Errors.hs +6/−3
- Examples/Test/Files.hs +5/−5
- Examples/Test/Makefile.hs +1/−1
- Examples/Test/Manual.hs +4/−5
- Examples/Test/Throttle.hs +1/−1
- Examples/Test/Unicode.hs +1/−1
- Examples/Util.hs +18/−8
- General/Base.hs +23/−4
- General/Binary.hs +2/−1
- General/Timing.hs +1/−7
- README.md +1/−0
- Test.hs +4/−3
- docs/Manual.md +4/−4
- html/shake-logic.js +3/−1
- shake.cabal +3/−2
CHANGES.txt view
@@ -1,5 +1,19 @@ Changelog for Shake +0.13+ #122, make --report=- write a report to stdout+ Improve the profile report summary+ #122, turn shakeReport into a list of files, instead of a Maybe+ #60, improve how command lines are printed out+ #113, print info about copyFile' and removeFilesAfter at -V+ Replace **> with |*> , ?>> with &?> and *>> with &*>+ IMPORTANT: Incompatible on disk format change+ #83, support digest rules for files+ #83, add shakeChange parameter and --digest* args+ #83, add equalValue function to Rule typeclass+ Deprecate defaultRule+ Make literal *> matches take precedence over wildcard matches+ #120, add a priority function 0.12 #62, move to a ReaderT/IORef for the Action monad Add DEPRECATED pragmas on system' calls
Development/Make/Rules.hs view
@@ -14,7 +14,7 @@ import General.String import Development.Shake.Classes import Development.Shake.FilePath-import Development.Shake.FileTime+import Development.Shake.FileInfo infix 1 ??> @@ -29,16 +29,19 @@ instance Show File_Q where show (File_Q x) = unpackU x -newtype File_A = File_A (Maybe FileTime)+newtype File_A = File_A (Maybe ModTime) 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 . fst)) $ getFileInfo x defaultRuleFile_ :: Rules ()-defaultRuleFile_ = defaultRule $ \(File_Q x) -> Just $- liftIO $ fmap (File_A . Just) $ getModTimeError "Error, file does not exist and no rule available:" x+defaultRuleFile_ = priority 0 $ rule $ \(File_Q x) -> Just $ liftIO $ do+ res <- getFileInfo x+ case res of+ Nothing -> error $ "Error, file does not exist and no rule available:\n " ++ unpackU x+ Just (mt,_) -> return $ File_A $ Just mt need_ :: [FilePath] -> Action ()@@ -54,6 +57,6 @@ if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x res <- act x- liftIO $ fmap File_A $ if res == Phony+ liftIO $ fmap (File_A . fmap fst) $ if res == Phony then return Nothing- else getModTimeMaybe x_+ else getFileInfo x_
Development/Make/Type.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-} module Development.Make.Type where
Development/Ninja/All.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} module Development.Ninja.All(runNinja) where @@ -63,7 +63,7 @@ else if not $ null defaults then defaults else Map.keys singles ++ Map.keys multiples - (\x -> fmap (map BS.unpack . fst) $ Map.lookup (BS.pack x) multiples) ?>> \out -> let out2 = map BS.pack out in + (\x -> fmap (map BS.unpack . fst) $ Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in build needDeps phonys rules pools out2 $ snd $ multiples Map.! head out2 (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in
Development/Ninja/Env.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, PatternGuards #-}+{-# LANGUAGE PatternGuards #-} -- | A Ninja style environment, basically a linked-list of mutable hash tables. module Development.Ninja.Env(
Development/Ninja/Type.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards, PatternGuards #-} -- | The IO in this module is only to evaluate an envrionment variable, -- the 'Env' itself it passed around purely.
Development/Shake.hs view
@@ -92,12 +92,12 @@ -- * Core shake, shakeOptions,- Rules, action, withoutActions, alternatives,+ Rules, action, withoutActions, alternatives, priority, Action, traced, liftIO, actionOnException, actionFinally, ShakeException(..), -- * Configuration- ShakeOptions(..), Assume(..), Lint(..), getShakeOptions,+ ShakeOptions(..), Assume(..), Lint(..), Change(..), getShakeOptions, -- ** Command line shakeArgs, shakeArgsWith, shakeOptDescrs, -- ** Progress reporting@@ -115,8 +115,8 @@ writeFile', writeFileLines, writeFileChanged, removeFiles, removeFilesAfter, -- * File rules- need, want, (*>), (**>), (?>), phony, (~>),- module Development.Shake.Rules.Files,+ need, want, (*>), (|*>), (?>), phony, (~>),+ (&*>), (&?>), orderOnly, FilePattern, (?==), needed, trackRead, trackWrite, trackAllow,@@ -135,6 +135,7 @@ -- * Cache newCache, newCacheIO, -- * Deprecated+ (**>), (*>>), (?>>), system', systemCwd, systemOutput ) where
Development/Shake/Args.hs view
@@ -232,6 +232,10 @@ ,no $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything." ,yes $ Option "" ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output." ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."+ ,yes $ Option "" ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes."+ ,yes $ Option "" ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change."+ ,yes $ Option "" ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."+ ,yes $ Option "" ["digest-or"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeOrDigest})) "Files change when modtime or digest change." ,no $ Option "" ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly." ,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."@@ -246,14 +250,14 @@ ,yes $ Option "" ["old-all"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Don't remake any files." ,yes $ Option "" ["assume-skip"] (noArg $ \s -> s{shakeAssume=Just AssumeSkip}) "Don't remake any files this run." ,yes $ Option "" ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."- ,yes $ Option "r" ["report"] (OptArg (\x -> Right ([], \s -> s{shakeReport=Just $ fromMaybe "report.html" x})) "FILE") "Write out profiling information [to report.html]."- ,yes $ Option "" ["no-report"] (noArg $ \s -> s{shakeReport=Nothing}) "Turn off --report."+ ,yes $ Option "r" ["report"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."+ ,yes $ Option "" ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report." ,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules." ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything." ,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 1 "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 secs, 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."
Development/Shake/Command.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} --- | /Deprecated:/ This module should no longer be imported as all the functions are available directly--- from "Development.Shake". In future versions this module will be removed.+-- | This module provides functions for calling command line programs, primarily+-- 'command' and 'cmd'. As a simple example:+--+-- @+-- 'command' [] \"gcc\" [\"-c\",myfile]+-- @+--+-- The functions from this module are now available directly from "Development.Shake".+-- You should only need to import this module if you are using the 'cmd' function in the 'IO' monad. module Development.Shake.Command( command, command_, cmd, Stdout(..), Stderr(..), Exit(..),@@ -103,7 +110,8 @@ let skipper act = if null results && not (shakeRunCommands opts) then return [] else act let verboser act = do- putLoud $ saneCommandForUser exe args+ let cwd = listToMaybe $ reverse [x | Cwd x <- copts]+ putLoud $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ saneCommandForUser exe args (if verb >= Loud then quietly else id) act let tracer = case reverse [x | Traced x <- copts] of@@ -167,10 +175,7 @@ (inh, outh, errh, pid) <- case ans of Right a -> return a Left err -> do- let msg = "Development.Shake." ++ funcName ++ ", system command failed\n" ++- "Command: " ++ saneCommandForUser exe args ++ "\n" ++- show (err :: SomeException)- error msg+ error $ msgPrefix ++ show (err :: SomeException) let close = maybe (return ()) hClose flip onException@@ -234,19 +239,22 @@ -- END COPIED when (ResultCode ExitSuccess `notElem` results && ex /= ExitSuccess) $ do- let msg = "Development.Shake." ++ funcName ++ ", system command failed\n" ++- "Command: " ++ saneCommandForUser exe args ++ "\n" ++- "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++- (if not stderrThrow then "Stderr not captured because ErrorsWithoutStderr was used"- else if null err then "Stderr was empty"- else "Stderr:\n" ++ unlines (dropWhile null $ lines err))- error msg+ error $ msgPrefix +++ "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" +++ (if not stderrThrow then "Stderr not captured because ErrorsWithoutStderr was used"+ else if null err then "Stderr was empty"+ else "Stderr:\n" ++ unlines (dropWhile null $ lines err)) return $ flip map results $ \x -> case x of ResultStdout _ -> ResultStdout out ResultStderr _ -> ResultStderr err ResultCode _ -> ResultCode ex where+ msgPrefix =+ "Development.Shake." ++ funcName ++ ", system command failed\n" +++ "Command: " ++ saneCommandForUser exe args ++ "\n" +++ (case cwd cp of Nothing -> ""; Just v -> "Current directory: " ++ v ++ "\n")+ input = last $ "" : [x | Stdin x <- opts] -- what should I do with these handles@@ -363,7 +371,7 @@ -- | A version of 'command' where you do not require any results, used to avoid errors about being unable -- to deduce 'CmdResult'. command_ :: [CmdOption] -> String -> [String] -> Action ()-command_ opts x xs = commandExplicit "command_" opts [] x xs >> return ()+command_ opts x xs = void $ commandExplicit "command_" opts [] x xs ---------------------------------------------------------------------
Development/Shake/Core.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-}-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-}+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704@@ -11,7 +11,7 @@ #if __GLASGOW_HASKELL__ >= 704 ShakeValue, #endif- Rule(..), Rules, defaultRule, rule, action, withoutActions, alternatives,+ Rule(..), Rules, rule, action, withoutActions, alternatives, priority, Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions, trackUse, trackChange, trackAllow, getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,@@ -24,6 +24,7 @@ import Control.Exception as E import Control.Applicative+import Control.Arrow import Control.Concurrent import Control.Monad import Control.Monad.IO.Class@@ -78,14 +79,18 @@ #endif ) => Rule key value where - -- | Retrieve the @value@ associated with a @key@, if available.+ -- | /[Required]/ Retrieve the @value@ associated with a @key@, if available. -- -- 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 :: ShakeOptions -> key -> IO (Maybe value) + -- | /[Optional]/ Equality check, with a notion of how expensive the check was.+ equalValue :: ShakeOptions -> key -> value -> value -> EqualCost+ equalValue _ _ v1 v2 = if v1 == v2 then EqualCheap else NotEqual + data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value)) ruleKey :: Rule key value => (key -> Maybe (m value)) -> key@@ -116,7 +121,7 @@ data SRules m = SRules {actions :: [m ()]- ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule m)]) -- higher fst is higher priority+ ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Double,ARule m)]) -- higher fst is higher priority } instance Monoid (SRules m) where@@ -131,33 +136,38 @@ mappend = liftA2 mappend --- | Like 'rule', but lower priority, if no 'rule' exists then 'defaultRule' is checked.--- All default rules must be disjoint.-defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-defaultRule = rulePriority 0----- | Add a rule to build a key, returning an appropriate 'Action'. All rules must be disjoint.--- To define lower priority rules use 'defaultRule'.+-- | Add a rule to build a key, returning an appropriate 'Action'. All rules at a given priority+-- must be disjoint. Rules have priority 1 by default, but can be modified with 'priority'. rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-rule = rulePriority 1+rule r = newRules mempty{rules = Map.singleton k (k, v, [(1,ARule r)])}+ where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r --- | Add a rule at a given priority, higher numbers correspond to higher-priority rules.--- The function 'defaultRule' is priority 0 and 'rule' is priority 1. All rules of the same--- priority must be disjoint.-rulePriority :: Rule key value => Int -> (key -> Maybe (Action value)) -> Rules ()-rulePriority i r = newRules mempty{rules = Map.singleton k (k, v, [(i,ARule r)])}- where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r+-- | Change the priority of a given set of rules, where higher priorities take precedence.+-- All matching rules at a given priority must be disjoint, or an error is raised.+-- All builtin Shake rules have priority between 0 and 1.+-- Excessive use of 'priority' is discouraged. As an example:+--+-- @+-- 'priority' 4 $ \"hello.*\" *> \\out -> 'writeFile'' out \"hello.*\"+-- 'priority' 8 $ \"*.txt\" *> \\out -> 'writeFile'' out \"*.txt\"+-- @+--+-- In this example @hello.txt@ will match the second rule, instead of raising an error about ambiguity.+priority :: Double -> Rules () -> Rules ()+priority i = modifyRules $ \s -> s{rules = Map.map (\(a,b,cs) -> (a,b,map (first $ const i) cs)) $ rules s} + -- | 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' $ do+-- \"hello.*\" *> \\out -> 'writeFile'' out \"hello.*\"+-- \"*.txt\" *> \\out -> 'writeFile'' out \"*.txt\" -- @+--+-- In this example @hello.txt@ will match the first rule, instead of raising an error about ambiguity. alternatives :: Rules () -> Rules () alternatives = modifyRules $ \r -> r{rules = Map.map f $ rules r} where@@ -184,7 +194,7 @@ -- For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action', -- see 'Development.Shake.want'. action :: Action a -> Rules ()-action a = newRules mempty{actions=[a >> return ()]}+action a = newRules mempty{actions=[void a]} -- | Remove all actions specified in a set of rules, usually used for implementing@@ -202,17 +212,22 @@ data RuleInfo m = RuleInfo {stored :: Key -> IO (Maybe Value)+ ,equal :: Key -> Value -> Value -> EqualCost ,execute :: Key -> m Value ,resultType :: TypeRep } createRuleinfo :: ShakeOptions -> SRules Action -> Map.HashMap TypeRep (RuleInfo Action)-createRuleinfo opt SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (execute rs) tv+createRuleinfo opt SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (equal rs) (execute rs) tv where stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey where f :: Rule key value => (key -> Maybe (m value)) -> (key -> IO (Maybe value)) f _ = storedValue opt + equal ((_,ARule r):_) = \k v1 v2 -> f r (fromKey k) (fromValue v1) (fromValue v2)+ where f :: Rule key value => (key -> Maybe (m value)) -> key -> value -> value -> EqualCost+ f _ = equalValue opt+ execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of [r]:_ -> r rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)@@ -226,6 +241,11 @@ Nothing -> return Nothing Just RuleInfo{..} -> stored k +runEqual :: Map.HashMap TypeRep (RuleInfo m) -> Key -> Value -> Value -> EqualCost+runEqual mp k v1 v2 = case Map.lookup (typeKey k) mp of+ Nothing -> NotEqual+ Just RuleInfo{..} -> equal k v1 v2+ runExecute :: Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing -- Not sure if this is even possible, but best be safe@@ -300,7 +320,7 @@ let output v = outputLocked v . abbreviate shakeAbbreviations except <- newIORef (Nothing :: Maybe (String, SomeException))- let staunch act | not shakeStaunch = act >> return ()+ let staunch act | not shakeStaunch = void act | otherwise = do res <- try act case res of@@ -348,15 +368,15 @@ when (isJust shakeLint) $ do addTiming "Lint checking" absent <- readIORef absent- checkValid database (runStored ruleinfo) absent+ checkValid database (runStored ruleinfo) (runEqual ruleinfo) absent when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"- when (isJust shakeReport) $ do+ when (shakeReport /= []) $ do addTiming "Profile report"- let file = fromJust shakeReport- json <- showJSON database- when (shakeVerbosity >= Normal) $- output Normal $ "Writing HTML report to " ++ file- buildReport json file+ report <- toReport database+ forM_ shakeReport $ \file -> do+ when (shakeVerbosity >= Normal) $+ output Normal $ "Writing report to " ++ file+ buildReport report file maybe (return ()) (throwIO . snd) =<< readIORef except sequence_ . reverse =<< readIORef after @@ -370,7 +390,7 @@ abbreviate abbrev = f where -- order so longer appreviations are preferred- ordAbbrev = reverse $ sortBy (compare `on` length . fst) abbrev+ ordAbbrev = sortBy (flip (compare `on` length . fst)) abbrev f [] = [] f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest@@ -397,7 +417,7 @@ -- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.--- This function requires that appropriate rules have been added with 'rule' or 'defaultRule'.+-- This function requires that appropriate rules have been added with 'rule'. -- All @key@ values passed to 'apply' become dependencies of the 'Action'. apply :: Rule key value => [key] -> Action [value] apply = f -- Don't short-circuit [] as we still want error messages@@ -437,7 +457,7 @@ evaluate $ rnf ans return ans stack <- Action $ getsRW localStack- res <- liftIO $ build globalPool globalDatabase (Ops (runStored globalRules) exec) stack ks+ res <- liftIO $ build globalPool globalDatabase (Ops (runStored globalRules) (runEqual globalRules) exec) stack ks case res of Left err -> throw err Right (dur, dep, vs) -> do@@ -464,7 +484,7 @@ Global{..} <- Action getRO stack <- Action $ getsRW localStack start <- liftIO globalTimestamp- putNormal $ "# " ++ msg ++ " " ++ showTopStack stack+ putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")" res <- liftIO act stop <- liftIO globalTimestamp Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) start stop : localTraces s}
Development/Shake/Database.hs view
@@ -9,7 +9,7 @@ Ops(..), build, Depends, progress, Stack, emptyStack, topStack, showStack, showTopStack,- showJSON, checkValid,+ toReport, checkValid, ) where import Development.Shake.Classes@@ -20,10 +20,12 @@ import Development.Shake.Storage import Development.Shake.Types import Development.Shake.Special+import Development.Shake.Report import General.Base import General.String import General.Intern as Intern +import Control.Applicative import Control.Exception import Control.Monad import qualified Data.HashSet as Set@@ -185,6 +187,8 @@ 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+ ,equal :: Key -> Value -> Value -> EqualCost+ -- ^ Given both Values, see if they are equal and how expensive that check was ,execute :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace])) -- ^ Given a chunk of stack (bottom element first), and a key, either raise an exception or successfully build it }@@ -252,12 +256,25 @@ Nothing -> err $ "interned value missing from database, " ++ show i Just (k, Missing) -> run stack i k Nothing Just (k, Loaded r) -> do- b <- case assume of- Just AssumeDirty -> return False- Just AssumeSkip -> return True- _ -> fmap (== Just (result r)) $ stored k- diagnostic $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (result r)- if not b then run stack i k $ Just r else check stack i k r (depends r)+ let out b = diagnostic $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (result r)+ let continue r = out True >> check stack i k r (depends r)+ let rebuild = out False >> run stack i k (Just r)+ case assume of+ Just AssumeDirty -> rebuild+ Just AssumeSkip -> continue r+ _ -> do+ s <- stored k+ case s of+ Just s -> case equal k (result r) s of+ NotEqual -> rebuild+ EqualCheap -> continue r+ EqualExpensive -> do+ -- warning, have the db lock while appending (may harm performance)+ r <- return r{result=s}+ journal i (k, Loaded r)+ i #= (k, Loaded r)+ continue r+ _ -> rebuild Just (k, res) -> return res run :: Stack -> Id -> Key -> Maybe Result -> IO Waiting@@ -391,31 +408,32 @@ removeStep :: Map Id (Key, Result) -> Map Id (Key, Result) removeStep = Map.filter (\(k,_) -> k /= stepKey) -showJSON :: Database -> IO String-showJSON Database{..} = do+toReport :: Database -> IO [ReportEntry]+toReport Database{..} = do status <- fmap (removeStep . resultsOnly) $ readIORef status let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status in dependencyOrder shw $ Map.map (concat . depends . snd) status ids = Map.fromList $ zip order [0..] steps = let xs = Set.toList $ Set.fromList $ concat [[changed, built] | (_,Result{..}) <- Map.elems status]- in Map.fromList $ zip (reverse $ sort xs) [0..]+ in Map.fromList $ zip (sortBy (flip compare) xs) [0..] - f (k, Result{..}) =- let xs = ["name:" ++ show (show k)- ,"built:" ++ showStep built- ,"changed:" ++ showStep changed- ,"depends:" ++ show (mapMaybe (`Map.lookup` ids) (concat depends))- ,"execution:" ++ show execution] ++- ["traces:[" ++ intercalate "," (map showTrace traces) ++ "]" | not $ null traces]- showStep i = show $ fromJust $ Map.lookup i steps- 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]"+ f (k, Result{..}) = ReportEntry+ {repName = show k+ ,repBuilt = fromStep built+ ,repChanged = fromStep changed+ ,repDepends = mapMaybe (`Map.lookup` ids) (concat depends)+ ,repExecution = fromFloat execution+ ,repTraces = map fromTrace traces+ }+ where fromStep i = fromJust $ Map.lookup i steps+ fromTrace (Trace a b c) = ReportTrace (unpack a) (fromFloat b) (fromFloat c)+ fromFloat = fromRational . toRational+ return $ [maybe (err "toReport") f $ Map.lookup i status | i <- order] -checkValid :: Database -> (Key -> IO (Maybe Value)) -> [(Key, Key)] -> IO ()-checkValid Database{..} stored missing = do+checkValid :: Database -> (Key -> IO (Maybe Value)) -> (Key -> Value -> Value -> EqualCost) -> [(Key, Key)] -> IO ()+checkValid Database{..} stored equal missing = do status <- readIORef status intern <- readIORef intern diagnostic "Starting validity/lint checking"@@ -424,7 +442,7 @@ bad <- (\f -> foldM f [] (Map.toList status)) $ \seen (i,v) -> case v of (key, Ready Result{..}) -> do now <- stored key- let good = now == Just result+ let good = maybe False ((==) EqualCheap . equal key result) now 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@@ -494,11 +512,12 @@ instance BinaryWith Witness Result where 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+ getWith ws = (\x1 x2 x3 (BinList x4) (BinFloat x5) (BinList x6) -> Result x1 x2 x3 (map fromBinList x4) x5 x6) <$>+ getWith ws <*> get <*> get <*> get <*> get <*> get 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+ get = (\a (BinFloat b) (BinFloat c) -> Trace a b c) <$> get <*> get <*> get instance BinaryWith Witness Status where putWith ctx Missing = putWord8 0
Development/Shake/Derived.hs view
@@ -84,7 +84,10 @@ -- | @copyFile' old new@ copies the existing file from @old@ to @new@. -- The @old@ file will be tracked as a dependency. copyFile' :: FilePath -> FilePath -> Action ()-copyFile' old new = need [old] >> liftIO (copyFile old new)+copyFile' old new = do+ need [old]+ putLoud $ "Copying from " ++ old ++ " to " ++ new+ liftIO $ copyFile old new -- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.
Development/Shake/Errors.hs view
@@ -101,7 +101,7 @@ errorNoApply :: TypeRep -> Maybe String -> String -> a errorNoApply tk k msg = structured (specialIsOracleKey tk)- ("Build system error - cannot currently call _apply_")+ "Build system error - cannot currently call _apply_" [("Reason", Just msg) ,("_Key_ type", Just $ show tk) ,("_Key_ value", k)]
+ Development/Shake/FileInfo.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}++module Development.Shake.FileInfo(+ FileInfo, fileInfoEq, fileInfoNeq, fileInfoVal,+ FileSize, ModTime, FileHash,+ getFileHash, getFileInfo+ ) where++import Control.Exception+import Development.Shake.Classes+import General.String+import qualified Data.ByteString.Lazy as LBS+import Data.Char+import Data.Word+import Numeric+import System.IO++#if defined(PORTABLE)+import System.IO.Error+import System.Directory+import Data.Time+import System.Time++#elif defined(mingw32_HOST_OS)+import qualified Data.ByteString.Char8 as BS+import Foreign+import Foreign.C.Types+import Foreign.C.String++#else+import System.IO.Error+import Control.Exception+import System.Posix.Files.ByteString+#endif++-- A piece of file information, where 0 = Eq to everything, 1 = Eq to nothing, 2+ = normal values+newtype FileInfo a = FileInfo Word32+ deriving (Typeable,Hashable,Binary,NFData)++instance Show (FileInfo a) where+ show (FileInfo x)+ | x == 0 = "EQ"+ | x == 1 = "NEQ"+ | x == 2 = "VAL"+ | otherwise = "0x" ++ map toUpper (showHex (x-2) "")++instance Eq (FileInfo a) where+ FileInfo a == FileInfo b+ | a == 0 || b == 0 = True+ | a == 1 || b == 1 = False+ | otherwise = a == b++fileInfoEq, fileInfoNeq, fileInfoVal :: FileInfo a+fileInfoEq = FileInfo 0+fileInfoNeq = FileInfo 1+fileInfoVal = FileInfo 2++fileInfo :: Word32 -> FileInfo a+fileInfo a = FileInfo $ if a > maxBound - 3 then a else a + 3++data FileInfoHash; type FileHash = FileInfo FileInfoHash+data FileInfoMod ; type ModTime = FileInfo FileInfoMod+data FileInfoSize; type FileSize = FileInfo FileInfoSize+++getFileHash :: BSU -> IO FileHash+getFileHash x = withFile (unpackU x) ReadMode $ \h -> do+ s <- LBS.hGetContents h+ let res = fileInfo $ fromIntegral $ hash s+ evaluate res+ return res+++getFileInfo :: BSU -> IO (Maybe (ModTime, FileSize))++#if defined(PORTABLE)+-- Portable fallback+getFileInfo x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do+ let file = unpackU x+ time <- getModificationTime file+ size <- withFile file ReadMode hFileSize+ return $ Just (fileInfo $ extractFileTime time, fileInfo $ fromIntegral size)++-- deal with difference in return type of getModificationTime between directory versions+class ExtractFileTime a where extractFileTime :: a -> Word32+instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fromIntegral t+instance ExtractFileTime UTCTime where extractFileTime = floor . fromRational . toRational . utctDayTime+++#elif defined(mingw32_HOST_OS)+-- Directly against the Win32 API, twice as fast as the portable version+getFileInfo x = BS.useAsCString (unpackU_ x) $ \file ->+ alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do+ res <- c_getFileAttributesExA file 0 fad+ let peek = do mt <- peekLastWriteTimeLow fad; sz <- peekFileSizeLow fad; return $ Just (fileInfo mt, fileInfo sz)+ if res then+ peek+ else if requireU x then withCWString (unpackU x) $ \file -> do+ res <- c_getFileAttributesExW file 0 fad+ if res then peek else return Nothing+ else+ return Nothing++foreign import stdcall unsafe "Windows.h GetFileAttributesExA" c_getFileAttributesExA :: Ptr CChar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import stdcall unsafe "Windows.h GetFileAttributesExW" c_getFileAttributesExW :: Ptr CWchar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool++data WIN32_FILE_ATTRIBUTE_DATA++alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a+alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act+ where size_WIN32_FILE_ATTRIBUTE_DATA = 36++peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+ where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++peekFileSizeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekFileSizeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow+ where index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow = 32+++#else+-- Unix version+getFileInfo x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do+ s <- getFileStatus $ unpackU_ x+ return $ Just (fileInfo $ extractFileTime s, fileInfo $ fromIntegral $ fileSize s)++extractFileTime :: FileStatus -> Word32+#ifndef MIN_VERSION_unix+#define MIN_VERSION_unix(a,b,c) 0+#endif+#if MIN_VERSION_unix(2,6,0)+extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4 -- precision of 0.1ms+#else+extractFileTime x = fromIntegral $ fromEnum $ modificationTime x+#endif++#endif
Development/Shake/FilePath.hs view
@@ -52,8 +52,11 @@ -- | Normalise a 'FilePath', trying to do: -- -- * All 'pathSeparators' become @\/@+-- -- * @foo\/bar\/..\/baz@ becomes @foo\/baz@+-- -- * @foo\/.\/bar@ becomes @foo\/bar@+-- -- * @foo\/\/bar@ becomes @foo\/bar@ -- -- This function is not based on the normalise function from the filepath library, as that function
Development/Shake/FilePattern.hs view
@@ -2,7 +2,7 @@ module Development.Shake.FilePattern( FilePattern, (?==),- compatible, extract, substitute,+ compatible, simple, extract, substitute, directories, directories1 ) where @@ -144,6 +144,11 @@ --------------------------------------------------------------------- -- MULTIPATTERN COMPATIBLE SUBSTITUTIONS++-- | Is the pattern free from any * and //.+simple :: FilePattern -> Bool+simple = all isChar . lexer+ -- | Do they have the same * and // counts in the same order compatible :: [FilePattern] -> Bool
− Development/Shake/FileTime.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}--module Development.Shake.FileTime(- FileTime, fileTimeNone,- getModTimeError, getModTimeMaybe- ) where--import Development.Shake.Classes-import General.String-import Data.Char-import Data.Int-import Data.Word-import Numeric--#if defined(PORTABLE)-import System.IO.Error-import Control.Exception-import System.Directory-import Data.Time-import System.Time--#elif defined(mingw32_HOST_OS)-import qualified Data.ByteString.Char8 as BS-import Foreign-import Foreign.C.Types-import Foreign.C.String--#else-import System.IO.Error-import Control.Exception-import System.Posix.Files.ByteString-#endif----- FileTime is an optimised type, which stores some portion of the file time,--- or maxBound to indicate there is no valid time. The moral type is @Maybe Datetime@--- but it needs to be more efficient.-newtype FileTime = FileTime Int32- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show FileTime where- show (FileTime x) = "0x" ++ replicate (length s - 8) '0' ++ map toUpper s- where s = showHex (fromIntegral x :: Word32) ""--fileTime :: Int32 -> FileTime-fileTime x = FileTime $ if x == maxBound then maxBound - 1 else x--fileTimeNone :: FileTime-fileTimeNone = FileTime maxBound---getModTimeError :: String -> BSU -> IO FileTime-getModTimeError msg x = do- res <- getModTimeMaybe x- case res of- -- Make sure you raise an error in IO, not return a value which will error later- Nothing -> error $ msg ++ "\n " ++ unpackU x- Just x -> return x---getModTimeMaybe :: BSU -> IO (Maybe FileTime)--#if defined(PORTABLE)--- Portable fallback-getModTimeMaybe x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do- time <- getModificationTime $ unpackU x- return $ Just $ extractFileTime time---- deal with difference in return type of getModificationTime between directory versions-class ExtractFileTime a where extractFileTime :: a -> FileTime-instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fileTime $ fromIntegral t-instance ExtractFileTime UTCTime where extractFileTime = fileTime . floor . fromRational . toRational . utctDayTime---#elif defined(mingw32_HOST_OS)--- Directly against the Win32 API, twice as fast as the portable version-getModTimeMaybe x = BS.useAsCString (unpackU_ x) $ \file ->- alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do- res <- c_getFileAttributesExA file 0 fad- if res then- fmap (Just . fileTime) $ peekLastWriteTimeLow fad- else if requireU x then withCWString (unpackU x) $ \file -> do- res <- c_getFileAttributesExW file 0 fad- if res then fmap (Just . fileTime) $ peekLastWriteTimeLow fad else return Nothing- else- return Nothing--foreign import stdcall unsafe "Windows.h GetFileAttributesExA" c_getFileAttributesExA :: Ptr CChar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool-foreign import stdcall unsafe "Windows.h GetFileAttributesExW" c_getFileAttributesExW :: Ptr CWchar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool--data WIN32_FILE_ATTRIBUTE_DATA--alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a-alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act- where size_WIN32_FILE_ATTRIBUTE_DATA = 36--peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Int32-peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime- where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20---#else--- Unix version-getModTimeMaybe x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do- s <- getFileStatus $ unpackU_ x- return $ Just $ fileTime $ extractFileTime s--extractFileTime :: FileStatus -> Int32-#ifndef MIN_VERSION_unix-#define MIN_VERSION_unix(a,b,c) 0-#endif-#if MIN_VERSION_unix(2,6,0)-extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4 -- precision of 0.1ms-#else-extractFileTime x = fromIntegral $ fromEnum $ modificationTime x-#endif--#endif
Development/Shake/Pool.hs view
@@ -4,6 +4,7 @@ import Control.Concurrent import Control.Exception hiding (blocked)+import Control.Monad import General.Base import General.Timing import qualified Data.HashSet as Set@@ -121,7 +122,7 @@ -- | Add a new task to the pool addPool :: Pool -> IO a -> IO () addPool pool act = step pool $ \s -> do- todo <- enqueue (act >> return ()) (todo s)+ todo <- enqueue (void act) (todo s) return s{todo = todo}
Development/Shake/Report.hs view
@@ -1,23 +1,69 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, RecordWildCards #-} -module Development.Shake.Report(buildReport) where+module Development.Shake.Report(ReportEntry(..), ReportTrace(..), buildReport) where +import General.Base+import Control.Arrow import Control.Monad import Data.Char+import Data.Function+import Data.List import System.FilePath import Paths_shake import qualified Data.ByteString.Lazy.Char8 as LBS --- | Generates an HTML report given some build system--- profiling data in JSON format.-buildReport :: String -> FilePath -> IO ()-buildReport json out = do- htmlDir <- getDataFileName "html"- report <- LBS.readFile $ htmlDir </> "report.html"- let f name | name == "data.js" = return $ LBS.pack $ "var shake = \n" ++ json- | otherwise = LBS.readFile $ htmlDir </> name- LBS.writeFile out =<< runTemplate f report+data ReportEntry = ReportEntry+ {repName :: String, repBuilt :: Int, repChanged :: Int, repDepends :: [Int], repExecution :: Double, repTraces :: [ReportTrace]}+data ReportTrace = ReportTrace+ {repCommand :: String, repStart :: Double, repStop :: Double}+repTime ReportTrace{..} = repStop - repStart+++-- | Generates an report given some build system profiling data.+buildReport :: [ReportEntry] -> FilePath -> IO ()+buildReport reports out+ | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ showJSON reports+ | takeExtension out == ".json" = writeFile out $ showJSON reports+ | out == "-" = putStr $ unlines $ reportSummary reports+ | otherwise = do+ htmlDir <- getDataFileName "html"+ report <- LBS.readFile $ htmlDir </> "report.html"+ let f name | name == "data.js" = return $ LBS.pack $ "var shake = \n" ++ showJSON reports+ | otherwise = LBS.readFile $ htmlDir </> name+ LBS.writeFile out =<< runTemplate f report+++reportSummary :: [ReportEntry] -> [String]+reportSummary xs =+ ["* This database has tracked " ++ show (maximum (0 : map repChanged xs) + 1) ++ " runs."+ ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."+ ,let f = show . sum . map (length . repTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."+ ,"* The total (unparallelised) build time is " ++ showTime (sum $ map repExecution xs) +++ " of which " ++ showTime (sum $ map repTime $ concatMap repTraces xs) ++ " is traced commands."+ ,let f = (\(a,b) -> showTime a ++ " (" ++ b ++ ")") . maximumBy (compare `on` fst) in+ "* The longest rule takes " ++ f (map (repExecution &&& repName) xs) +++ ", and the longest traced command takes " ++ f (map (repTime &&& repCommand) $ concatMap repTraces xs) ++ "."+ ,let sumLast = sum $ map repTime $ concatMap repTraces ls+ maxStop = maximum $ 0 : map repStop (concatMap repTraces ls) in+ "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) +++ " times over " ++ showTime(maxStop) ++ "."+ ]+ where ls = filter ((==) 0 . repBuilt) xs+++showJSON :: [ReportEntry] -> String+showJSON xs = "[" ++ intercalate "\n," (map showEntry xs) ++ "\n]"+ where+ showEntry ReportEntry{..} = (\xs -> "{" ++ intercalate ", " xs ++ "}") $+ ["\"name\":" ++ show repName+ ,"\"built\":" ++ show repBuilt+ ,"\"changed\":" ++ show repChanged+ ,"\"depends\":" ++ show repDepends+ ,"\"execution\":" ++ show repExecution] +++ ["\"traces\":[" ++ intercalate "," (map showTrace repTraces) ++ "]" | not $ null repTraces]+ showTrace ReportTrace{..} =+ "{\"command\":" ++ show repCommand ++ ",\"start\":" ++ show repStart ++ ",\"stop\":" ++ show repStop ++ "}" -- | Template Engine. Perform the following replacements on a line basis:
Development/Shake/Rule.hs view
@@ -6,8 +6,21 @@ #if __GLASGOW_HASKELL__ >= 704 ShakeValue, #endif- Rule(..), defaultRule, rule, apply, apply1,- trackUse, trackChange, trackAllow+ Rule(..), EqualCost(..), rule, apply, apply1,+ trackUse, trackChange, trackAllow,+ -- * Deprecated+ defaultRule ) where import Development.Shake.Core+import Development.Shake.Types++{-# DEPRECATED defaultRule "Use 'rule' with 'priority' 0" #-}++-- | A deprecated way of defining a low priority rule. Defined as:+--+-- @+-- defaultRule = 'priority' 0 . 'rule'+-- @+defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()+defaultRule = priority 0 . rule
Development/Shake/Rules/Directory.hs view
@@ -120,13 +120,13 @@ -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleDirectory :: Rules () defaultRuleDirectory = do- defaultRule $ \(DoesFileExistQ x) -> Just $+ rule $ \(DoesFileExistQ x) -> Just $ liftIO $ fmap DoesFileExistA $ IO.doesFileExist x- defaultRule $ \(DoesDirectoryExistQ x) -> Just $+ rule $ \(DoesDirectoryExistQ x) -> Just $ liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x- defaultRule $ \(x :: GetDirectoryQ) -> Just $+ rule $ \(x :: GetDirectoryQ) -> Just $ liftIO $ getDir x- defaultRule $ \(GetEnvQ x) -> Just $+ rule $ \(GetEnvQ x) -> Just $ liftIO $ fmap GetEnvA $ getEnvMaybe x @@ -263,7 +263,7 @@ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs noDirs <- fmap and $ mapM f dirs let (del,keep) = partition test files- mapM_ IO.removeFile $ map (dir </>) del+ forM del $ \d -> IO.removeFile $ dir </> d let die = noDirs && null keep && not (null xs) when die $ IO.removeDirectory $ dir </> dir2 return die@@ -272,4 +272,6 @@ -- | Remove files, like 'removeFiles', but executed after the build completes successfully. -- Useful for implementing @clean@ actions that delete files Shake may have open for building. removeFilesAfter :: FilePath -> [FilePattern] -> Action ()-removeFilesAfter a b = runAfter $ removeFiles a b+removeFilesAfter a b = do+ putLoud $ "Will remove " ++ unwords b ++ " from " ++ a+ runAfter $ removeFiles a b
Development/Shake/Rules/File.hs view
@@ -4,9 +4,12 @@ need, needBS, needed, neededBS, want, trackRead, trackWrite, trackAllow, defaultRuleFile,- (*>), (**>), (?>), phony, (~>)+ (*>), (|*>), (**>), (?>), phony, (~>),+ -- * Internal only+ FileQ(..), FileA ) where +import Control.Applicative hiding ((*>)) import Control.Monad import Control.Monad.IO.Class import System.Directory@@ -17,37 +20,75 @@ import General.String import Development.Shake.Classes import Development.Shake.FilePattern-import Development.Shake.FileTime+import Development.Shake.FileInfo import Development.Shake.Types import Development.Shake.Errors +import Data.Bits+import Data.List import Data.Maybe import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong+import System.IO.Unsafe(unsafeInterleaveIO) -infix 1 *>, ?>, **>, ~>+infix 1 *>, ?>, |*>, **>, ~> +-- | /Deprecated:/ Alias for '|*>'.+(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+(**>) = (|*>) -newtype FileQ = FileQ BSU++newtype FileQ = FileQ {fromFileQ :: BSU} deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show FileQ where show (FileQ x) = unpackU x -newtype FileA = FileA FileTime- deriving (Typeable,Hashable,Binary,NFData)+data FileA = FileA {-# UNPACK #-} !ModTime {-# UNPACK #-} !FileSize FileHash+ deriving (Typeable,Eq) -instance Eq FileA where FileA x == FileA y = x /= fileTimeNone && x == y+instance Hashable FileA where+ hashWithSalt salt (FileA a b c) = hashWithSalt salt a `xor` hashWithSalt salt b `xor` hashWithSalt salt c -instance Show FileA where show (FileA x) = "FileTimeHash " ++ show x+instance NFData FileA where+ rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c +instance Binary FileA where+ put (FileA a b c) = put a >> put b >> put c+ get = liftA3 FileA get get get++instance Show FileA where+ show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}"+ instance Rule FileQ FileA where- storedValue _ (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x+ storedValue ShakeOptions{shakeChange=c} (FileQ x) = do+ res <- getFileInfo x+ case res of+ Nothing -> return Nothing+ Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoVal+ Just (time,size) -> do+ hash <- unsafeInterleaveIO $ getFileHash x+ return $ Just $ FileA (if c == ChangeDigest then fileInfoVal else time) size hash + equalValue ShakeOptions{shakeChange=c} q (FileA x1 x2 x3) (FileA y1 y2 y3) = case c of+ ChangeModtime -> bool $ x1 == y1+ ChangeDigest -> bool $ x2 == y2 && x3 == y3+ ChangeModtimeOrDigest -> bool $ x1 == y1 && x2 == y2 && x3 == y3+ _ -> if x1 == y1 then EqualCheap+ else if x2 == y2 && x3 == y3 then EqualExpensive+ else NotEqual+ where bool b = if b then EqualCheap else NotEqual +storedValueError :: ShakeOptions -> Bool -> String -> FileQ -> IO FileA+storedValueError opts input msg x = fromMaybe (error err) <$> storedValue opts2 x+ where err = msg ++ "\n " ++ unpackU (fromFileQ x)+ opts2 = if not input && shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts++ -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleFile :: Rules ()-defaultRuleFile = defaultRule $ \(FileQ x) -> Just $- liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x+defaultRuleFile = priority 0 $ rule $ \x -> Just $ do+ opts <- getShakeOptions+ liftIO $ storedValueError opts True "Error, file does not exist and no rule available:" x -- | Add a dependency on the file arguments, ensuring they are built before continuing.@@ -86,10 +127,11 @@ neededCheck :: [BSU] -> Action () neededCheck xs = do- pre <- liftIO $ mapM getModTimeMaybe xs+ opts <- getShakeOptions+ pre <- liftIO $ mapM (storedValue opts . FileQ) xs post <- apply $ map FileQ xs :: Action [FileA] let bad = [ (x, if isJust a then "File change" else "File created")- | (x, a, FileA b) <- zip3 xs pre post, Just b /= a]+ | (x, a, b) <- zip3 xs pre post, Just b /= a] case bad of [] -> return () (file,msg):_ -> errorStructured@@ -142,7 +184,8 @@ if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x act x- liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_+ opts <- getShakeOptions+ liftIO $ storedValueError opts False ("Error, rule " ++ help ++ " failed to build file:") $ FileQ x_ -- | Declare a phony action -- an action that does not produce a file, and will be rerun@@ -156,7 +199,7 @@ phony name act = rule $ \(FileQ x_) -> let x = unpackU x_ in if name /= x then Nothing else Just $ do act- return $ FileA fileTimeNone+ return $ FileA fileInfoNeq fileInfoNeq fileInfoNeq -- | Infix operator alias for 'phony', for sake of consistency with normal -- rules.@@ -175,16 +218,19 @@ -- 'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src -- @ (?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-(?>) = root "with ?>"+(?>) test act = priority 0.5 $ root "with ?>" test act --- | Define a set of patterns, and if any of them match, run the associated rule. See '*>'.-(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()--- Should probably have been called |*>, since it's an or (||) of *>-(**>) test = root "with **>" (\x -> any (?== x) test)+-- | Define a set of patterns, and if any of them match, run the associated rule. Defined in terms of '*>'.+-- Think of it as the OR (@||@) equivalent of '*>'.+(|*>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+(|*>) pats act = let (simp,other) = partition simple pats in f simp >> priority 0.5 (f other)+ where f ps = let ps2 = map (?==) ps in unless (null ps2) $ root "with |*>" (\x -> any ($ x) ps2) act --- | Define a rule that matches a 'FilePattern'. No file required by the system must be--- matched by more than one pattern. For the pattern rules, see '?=='.+-- | Define a rule that matches a 'FilePattern', see '?==' for the pattern rules.+-- Patterns with no wildcards have higher priority than those with wildcards, and no file+-- required by the system may be matched by more than one pattern at the same priority+-- (see 'priority' and 'alternatives' to modify this behaviour). -- This function will create the directory for the result file, if necessary. -- -- @@@ -200,4 +246,4 @@ -- -- Note that matching is case-sensitive, even on Windows. (*>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()-(*>) test = root (show test) (test ?==)+(*>) test act = (if simple test then id else priority 0.5) $ root (show test) (test ?==) act
Development/Shake/Rules/Files.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-} module Development.Shake.Rules.Files(- (?>>), (*>>)+ (?>>), (*>>), (&?>), (&*>) ) where import Control.Monad@@ -15,34 +15,52 @@ import Development.Shake.Classes import Development.Shake.Rules.File import Development.Shake.FilePattern-import Development.Shake.FileTime+import Development.Shake.Types import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong -infix 1 ?>>, *>>+infix 1 ?>>, *>>, &?>, &*> +-- | /Deprecated:/ Alias for '&?>'.+(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()+(?>>) = (&?>) -newtype FilesQ = FilesQ [BSU]+-- | /Deprecated:/ Alias for '&*>'.+(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+(*>>) = (&*>)++++newtype FilesQ = FilesQ [FileQ] deriving (Typeable,Eq,Hashable,Binary,NFData) -newtype FilesA = FilesA [FileTime]+++newtype FilesA = FilesA [FileA] deriving (Typeable,Eq,Hashable,Binary,NFData) -instance Show FilesA where show (FilesA xs) = unwords $ "FileTimeHashes" : map show xs+instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs -instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . unpackU) xs+instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . show) xs instance Rule FilesQ FilesA where- storedValue _ (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs+ storedValue opts (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM (storedValue opts) xs+ equalValue opts (FilesQ qs) (FilesA xs) (FilesA ys)+ | let n = length qs in n /= length xs || n /= length ys = NotEqual+ | otherwise = foldr and_ EqualCheap (zipWith3 (equalValue opts) qs xs ys)+ where and_ NotEqual x = NotEqual+ and_ EqualCheap x = x+ and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive -- | Define a rule for building multiple files at the same time.+-- Think of it as the AND (@&&@) equivalent of '*>'. -- As an example, a single invocation of GHC produces both @.hi@ and @.o@ files: -- -- @--- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do+-- [\"*.o\",\"*.hi\"] '&*>' \\[o,hi] -> do -- let hs = o 'Development.Shake.FilePath.-<.>' \"hs\" -- 'Development.Shake.need' ... -- all files the .hs import -- 'Development.Shake.cmd' \"ghc -c\" [hs]@@ -52,29 +70,30 @@ -- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must -- have the same sequence of @\/\/@ and @*@ wildcards in the same order. -- This function will create directories for the result files, if necessary.-(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()--- Should probably have been called &*>, since it's an and (&&) of *>-ps *>> act+-- Think of it as the OR (@||@) equivalent of '*>'.+(&*>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+ps &*> act | not $ compatible ps = error $- "All patterns to *>> must have the same number and position of // and * wildcards\n" +++ "All patterns to &*> must have the same number and position of // and * wildcards\n" ++ unwords ps | otherwise = do forM_ ps $ \p -> p *> \file -> do- _ :: FilesA <- apply1 $ FilesQ $ map (packU . substitute (extract p file)) ps+ _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU . substitute (extract p file)) ps return ()- 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_+ (if all simple ps then id else priority 0.5) $+ rule $ \(FilesQ xs_) -> let xs = map (unpackU . fromFileQ) 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+ getFileTimes "&*>" xs_ -- | Define a rule for building multiple files at the same time, a more powerful--- and more dangerous version of '*>>'.+-- and more dangerous version of '&*>'. Think of it as the AND (@&&@) equivalent of '?>'. ----- Given an application @test ?>> ...@, @test@ should return @Just@ if the rule applies, and should+-- Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should -- return the list of files that will be produced. This list /must/ include the file passed as an argument and should -- obey the invariant: --@@ -89,35 +108,37 @@ -- @ -- -- Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.-(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()--- Should probably have been called &?>, since it's an and (&&) of ?>-(?>>) test act = do+(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()+(&?>) test act = priority 0.5 $ do let checkedTest x = case test x of Nothing -> Nothing Just ys | x `elem` ys && all ((== Just ys) . test) ys -> Just ys- | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x+ | otherwise -> error $ "Invariant broken in &?> when trying on " ++ x isJust . checkedTest ?> \x -> do- _ :: FilesA <- apply1 $ FilesQ $ map packU $ fromJust $ test x+ -- FIXME: Could optimise this test by calling rule directly and returning FileA Eq Eq Eq+ -- But only saves noticable time on uncommon Change modes+ _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU) $ fromJust $ test x return () - rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpackU xs_ in+ rule $ \(FilesQ xs_) -> let xs@(x:_) = map (unpackU . fromFileQ) xs_ in case checkedTest x of Just ys | ys == xs -> Just $ do liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs act xs- liftIO $ getFileTimes "?>>" xs_- Just ys -> error $ "Error, ?>> is incompatible with " ++ show xs ++ " vs " ++ show ys+ getFileTimes "&?>" xs_+ Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys Nothing -> Nothing -getFileTimes :: String -> [BSU] -> IO FilesA+getFileTimes :: String -> [FileQ] -> Action FilesA getFileTimes name xs = do- ys <- mapM getModTimeMaybe xs+ opts <- getShakeOptions+ ys <- liftIO $ mapM (storedValue opts) xs case sequence ys of Just ys -> return $ FilesA ys Nothing -> do let missing = length $ filter isNothing ys error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++ " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++- concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]+ concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]
Development/Shake/Rules/OrderOnly.hs view
@@ -27,7 +27,7 @@ defaultRuleOrderOnly :: Rules ()-defaultRuleOrderOnly = defaultRule $ \(OrderOnlyQ x) -> Just $ do+defaultRuleOrderOnly = rule $ \(OrderOnlyQ x) -> Just $ do needBS [unpackU_ x] return $ OrderOnlyA ()
Development/Shake/Rules/Rerun.hs view
@@ -34,4 +34,4 @@ alwaysRerun = do AlwaysRerunA _ <- apply1 $ AlwaysRerunQ (); return () defaultRuleRerun :: Rules ()-defaultRuleRerun = defaultRule $ \AlwaysRerunQ{} -> Just $ return $ AlwaysRerunA()+defaultRuleRerun = rule $ \AlwaysRerunQ{} -> Just $ return $ AlwaysRerunA()
Development/Shake/Special.hs view
@@ -11,7 +11,7 @@ specialAlwaysRebuilds :: Value -> Bool-specialAlwaysRebuilds v = con `elem` ["AlwaysRerunA","OracleA"] || (con == "FileA" && show v == "FileTimeHash 0x7FFFFFFF")+specialAlwaysRebuilds v = con `elem` ["AlwaysRerunA","OracleA"] || (con == "FileA" && show v == "File {mod=NEQ,size=NEQ,digest=NEQ}") where con = show $ fst $ splitTyConApp $ typeValue v
Development/Shake/Storage.hs view
@@ -41,10 +41,9 @@ -- @x@ is for the users version number databaseVersion :: String -> String -- 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 -- * Duration and Time should be stored as number of 1/10000th seconds Int32-databaseVersion x = "SHAKE-DATABASE-9-" ++ s ++ "\r\n"+databaseVersion x = "SHAKE-DATABASE-10-" ++ 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/Types.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -- | Types exposed to the user module Development.Shake.Types(- Progress(..), Verbosity(..), Assume(..), Lint(..),+ Progress(..), Verbosity(..), Assume(..), Lint(..), Change(..), EqualCost(..), ShakeOptions(..), shakeOptions ) where @@ -48,8 +48,9 @@ deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum) -{---- | How should you determine if a file has changed, used by 'shakeChange'.+-- | How should you determine if a file has changed, used by 'shakeChange'. The most common values are+-- 'ChangeModtime' (very fast, @touch@ causes files to rebuild) and 'ChangeModtimeAndDigestInput'+-- (a bit slower, @touch@ does not cause input files to rebuild). data Change = ChangeModtime -- ^ Compare equality of modification timestamps, a file has changed if its last modified time changes.@@ -59,18 +60,19 @@ -- 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+ -- time is checked first, and if that has changed, the digest is checked.+ | ChangeModtimeAndDigestInput+ -- ^ Use 'ChangeModtimeAndDigest' for input\/source files and 'ChangeModtime' for output files. | 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': ----- @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just \"report.html\"} @+-- @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=[\"report.html\"]} @ -- -- The 'Data' instance for this type reports the 'shakeProgress' and 'shakeOutput' fields as having the abstract type 'Function', -- because 'Data' cannot be defined for functions.@@ -93,9 +95,11 @@ ,shakeStaunch :: Bool -- ^ Defaults to 'False'. Operate in staunch mode, where building continues even after errors, -- similar to @make --keep-going@.- ,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.+ ,shakeReport :: [FilePath]+ -- ^ Defaults to '[]'. Write a 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.+ -- If the file extension is @.json@ it will write JSON data, if @.js@ it will write Javascript,+ -- otherwise it will write HTML. ,shakeLint :: Maybe Lint -- ^ Defaults to 'Nothing'. Perform sanity checks during building, see 'Lint' for details. ,shakeFlush :: Maybe Double@@ -118,6 +122,8 @@ ,shakeRunCommands :: Bool -- ^ Default to 'True'. Should you run command line actions, set to 'False' to skip actions whose output streams and exit code -- are not used. Useful for profiling the non-command portion of the build system.+ ,shakeChange :: Change+ -- ^ Default to 'ChangeModtime'. How to check if a file has changed, see 'Change' for details. ,shakeProgress :: IO Progress -> IO () -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported. -- The function is called on a separate thread, and that thread is killed when the build completes.@@ -132,23 +138,24 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing Nothing (Just 10) Nothing [] False True False True+shakeOptions = ShakeOptions ".shake" 1 "1" Normal False [] Nothing (Just 10) Nothing [] False True False True ChangeModtime (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS fieldsShakeOptions = ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" ,"shakeLint", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"- ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeProgress", "shakeOutput"]+ ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeProgress", "shakeOutput"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 =- ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 (fromFunction x15) (fromFunction x16)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 =+ ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 (fromFunction x16) (fromFunction x17) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16) =- z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` x14 `k` Function x15 `k` Function x16- gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+ gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17) =+ z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` x14 `k` x15 `k`+ Function x16 `k` Function x17+ gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions @@ -160,8 +167,9 @@ f x | Just x <- cast x = show (x :: Int) | Just x <- cast x = show (x :: FilePath) | Just x <- cast x = show (x :: Verbosity)+ | Just x <- cast x = show (x :: Change) | Just x <- cast x = show (x :: Bool)- | Just x <- cast x = show (x :: Maybe FilePath)+ | Just x <- cast x = show (x :: [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)@@ -190,8 +198,15 @@ data Verbosity = Silent -- ^ Don't print any messages. | Quiet -- ^ Only print essential messages, typically errors.- | Normal -- ^ Print errors and @# /command-name/ /file-name/@ when running a 'Development.Shake.traced' command.+ | Normal -- ^ Print errors and @# /command-name/ (for /file-name/)@ when running a 'Development.Shake.traced' command. | Loud -- ^ Print errors and full command lines when running a 'Development.Shake.command' or 'Development.Shake.cmd' command. | Chatty -- ^ Print errors, full command line and status messages when starting a rule. | Diagnostic -- ^ Print messages for virtually everything (mostly for debugging).+ deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)++-- | An equality check and a cost.+data EqualCost+ = EqualCheap -- ^ The equality check was cheap.+ | EqualExpensive -- ^ The equality check was expensive, as the results are not trivially equal.+ | NotEqual -- ^ The values are not equal. deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)
Examples/Ninja/Main.hs view
@@ -61,4 +61,4 @@ let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b | otherwise = a === b length want === length res- sequence_ $ zipWith eq want res+ zipWithM_ eq want res
Examples/Self/Main.hs view
@@ -57,7 +57,7 @@ xs <- filterM (doesFileExist . fixPaths . moduleToFile "hs") xs writeFileLines out xs - [obj "/*.o",obj "/*.hi"] *>> \[out,_] -> do+ [obj "/*.o",obj "/*.hi"] &*> \[out,_] -> do deps <- readFileLines $ out -<.> "deps" let hs = fixPaths $ unobj $ out -<.> "hs" need $ hs : map (obj . moduleToFile "hi") deps
Examples/Test/Command.hs view
@@ -20,7 +20,7 @@ return stderr "ghc-random2" !> do- () <- cmd (EchoStderr False) "ghc --random"+ () <- cmd (EchoStderr False) (Cwd $ obj "") "ghc --random" return "" "triple" !> do@@ -49,7 +49,7 @@ assertContentsInfix (obj "ghc-random") "unrecognised flag" assertContentsInfix (obj "ghc-random") "--random" - crash ["ghc-random2"] ["unrecognised flag","--random"]+ crash ["ghc-random2"] [obj "","unrecognised flag","--random"] build ["pwd"] assertContentsInfix (obj "pwd") "command"
+ Examples/Test/Digest.hs view
@@ -0,0 +1,78 @@++module Examples.Test.Digest(main) where++import Control.Monad+import Development.Shake+import Examples.Util+++main = shaken test $ \args obj -> do+ want [obj "Out.txt",obj "Out2.txt"]++ obj "Out.txt" *> \out -> do+ txt <- readFile' $ obj "In.txt"+ liftIO $ appendFile out txt++ [obj "Out1.txt",obj "Out2.txt"] &*> \[out1,out2] -> do+ txt <- readFile' $ obj "In.txt"+ liftIO $ appendFile out1 txt+ liftIO $ appendFile out2 txt+++test build obj = do+ let outs = take 1 $ map obj ["Out.txt","Out1.txt","Out2.txt"]+ let writeOut x = forM_ outs $ \out -> writeFile out x+ let writeIn x = writeFile (obj "In.txt") x+ let assertOut x = forM_ outs $ \out -> assertContents out x++ writeOut ""+ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "X"++ -- should not involve a hash calculation (sadly no way to test that)+ build ["--sleep","--digest-and"]+ assertOut "X"++ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "X"++ writeIn "X"+ build ["--sleep","--digest-or"]+ assertOut "XX"++ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "XX"++ build ["--sleep","--digest-and"]+ writeOut "XX"+ build ["--sleep","--digest-and"]+ assertOut "XX"++ build ["--sleep","--digest-and"]+ writeOut "Y"+ build ["--sleep","--digest-and"]+ assertOut "YX"++ writeIn "X"+ build ["--sleep","--digest"]+ assertOut "YX"++ writeIn "Z"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZ"++ build ["--sleep","--digest-and-input"]+ writeOut "YXZ"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZ"++ writeIn "Q"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZQ"++ writeIn "Q"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZQ"
Examples/Test/Directory.hs view
@@ -4,10 +4,9 @@ import Development.Shake import Development.Shake.FilePath import Examples.Util-import System.Directory(createDirectory) import Data.List import Control.Monad-import System.Directory(getCurrentDirectory, setCurrentDirectory, createDirectoryIfMissing)+import System.Directory(getCurrentDirectory, setCurrentDirectory, createDirectory, createDirectoryIfMissing) import qualified System.Directory as IO
Examples/Test/Docs.hs view
@@ -204,11 +204,11 @@ ".. /./ /.. ./ // \\ ../ " ++ "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++ "Data.List System.Directory Development.Shake.FilePath main.m run .rot13 " ++- "NoProgress Error src rot13 " +++ "NoProgress Error src rot13 .js .json " ++ ".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out build " ++ "/usr/special /usr/special/userbinary $CFLAGS %PATH% -O2 -j8 -j -j1 " ++ "-threaded -rtsopts -I0 Function extension $OUT $C_LINK_FLAGS $PATH xterm $TERM main opts result flagValues argValues " ++- "HEADERS_DIR /path/to/dir CFLAGS let -showincludes -MMD gcc.version linkFlags temp pwd code out err " +++ "HEADERS_DIR /path/to/dir CFLAGS let -showincludes -MMD gcc.version linkFlags temp pwd touch code out err " ++ "_metadata/.database _shake _shake/build ./build.sh build.sh build.bat //* [out] manual/examples.zip manual " ++ "docs/manual _build _build/run ninja depfile build.ninja " = True@@ -220,7 +220,7 @@ ,"1m25s (15%)" ,"3m12s (82%)" ,"getPkgVersion $ GhcPkgVersion \"shake\""- ,"# command-name file-name"+ ,"# command-name (for file-name)" ,"ghc --make MyBuildSystem -rtsopts -with-rtsopts=-I0" ,"-with-rtsopts" ,"-qg -qb"@@ -258,7 +258,7 @@ ] types = words $- "MVar IO Monad Monoid String FilePath Data Maybe [String] Eq Typeable Char ExitCode " +++ "MVar IO Monad Monoid String FilePath Data Maybe [String] Eq Typeable Char ExitCode Change " ++ "Action Resource Assume FilePattern Lint Verbosity Rules Rule CmdOption CmdResult Int Double" dupes = words "main progressSimple rules"
Examples/Test/Errors.hs view
@@ -17,7 +17,7 @@ obj "failcreate" *> \_ -> return () - [obj "failcreates", obj "failcreates2"] *>> \_ ->+ [obj "failcreates", obj "failcreates2"] &*> \_ -> writeFile' (obj "failcreates") "" obj "recursive" *> \out ->@@ -49,9 +49,10 @@ need ["resource-dep"] obj "overlap.txt" *> \out -> writeFile' out "overlap.txt"+ obj "overlap.t*" *> \out -> writeFile' out "overlap.t*" obj "overlap.*" *> \out -> writeFile' out "overlap.*" alternatives $ do- obj "alternative.txt" *> \out -> writeFile' out "alternative.txt"+ obj "alternative.t*" *> \out -> writeFile' out "alternative.txt" obj "alternative.*" *> \out -> writeFile' out "alternative.*" @@ -87,7 +88,9 @@ build ["overlap.foo"] assertContents (obj "overlap.foo") "overlap.*"- crash ["overlap.txt"] ["key matches multiple rules","overlap.txt"]+ build ["overlap.txt"]+ assertContents (obj "overlap.txt") "overlap.txt"+ crash ["overlap.txx"] ["key matches multiple rules","overlap.txx"] build ["alternative.foo","alternative.txt"] assertContents (obj "alternative.foo") "alternative.*" assertContents (obj "alternative.txt") "alternative.txt"
Examples/Test/Files.hs view
@@ -12,17 +12,17 @@ let rest = delete "@" args want $ map obj $ if null rest then ["even.txt","odd.txt"] else rest - -- Since ?>> and *>> are implemented separately we test everything in both modes- let deps ?*>> act | fun = (\x -> if x `elem` deps then Just deps else Nothing) ?>> act- | otherwise = deps *>> act+ -- Since &?> and &*> are implemented separately we test everything in both modes+ let deps &?*> act | fun = (\x -> if x `elem` deps then Just deps else Nothing) &?> act+ | otherwise = deps &*> act - map obj ["even.txt","odd.txt"] ?*>> \[evens,odds] -> do+ map obj ["even.txt","odd.txt"] &?*> \[evens,odds] -> do src <- readFileLines $ obj "numbers.txt" let (es,os) = partition even $ map read src writeFileLines evens $ map show es writeFileLines odds $ map show os - map obj ["dir1/out.txt","dir2/out.txt"] ?*>> \[a,b] -> do+ map obj ["dir1/out.txt","dir2/out.txt"] &?*> \[a,b] -> do writeFile' a "a" writeFile' b "b"
Examples/Test/Makefile.hs view
@@ -18,7 +18,7 @@ test build obj = do- copyDirectory "Examples/MakeTutor" $ obj "MakeTutor"+ copyDirectoryChanged "Examples/MakeTutor" $ obj "MakeTutor" build ["@@","--directory=" ++ obj "MakeTutor","--no-report"] build ["@@","--directory=" ++ obj "MakeTutor","--no-report"] build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]
Examples/Test/Manual.hs view
@@ -5,17 +5,16 @@ import Development.Shake.FilePath import Examples.Util import General.Base-import System.Directory main = shaken test $ \args obj -> action $ liftIO $ error "The 'manual' example should only be used in test mode" test build obj = do- copyDirectory "docs/manual" $ obj "manual"- copyDirectory "Development" $ obj "manual/Development"- copyDirectory "General" $ obj "manual/General"- copyFile "Paths.hs" $ obj "manual/Paths_shake.hs"+ copyDirectoryChanged "docs/manual" $ obj "manual"+ copyDirectoryChanged "Development" $ obj "manual/Development"+ copyDirectoryChanged "General" $ obj "manual/General"+ copyFileChanged "Paths.hs" $ obj "manual/Paths_shake.hs" let cmdline = if isWindows then "build.bat" else "/bin/sh build.sh" () <- cmd [Cwd $ obj "manual", Shell] cmdline "-j2" assertExists $ obj "manual/_build/run" <.> exe
Examples/Test/Throttle.hs view
@@ -19,7 +19,7 @@ forM_ [[],["-j8"]] $ \flags -> do -- we are sometimes over the window if the machine is "a bit loaded" at some particular time -- therefore we rerun the test three times, and only fail if it fails on all of them- flip loop 3 $ \i -> do+ flip loopM 3 $ \i -> do build ["clean"] (s, _) <- duration $ build [] -- the 0.1s cap is a guess at an upper bound for how long everything else should take
Examples/Test/Unicode.hs view
@@ -32,7 +32,7 @@ b <- readFile' $ obj pre <.> "multi1" writeFile' out $ a ++ b - map obj ["*.multi1","*.multi2"] *>> \[m1,m2] -> do+ map obj ["*.multi1","*.multi2"] &*> \[m1,m2] -> do b <- doesFileExist $ m1 -<.> "exist" writeFile' m1 $ show b writeFile' m2 $ show b
Examples/Util.hs view
@@ -5,7 +5,7 @@ import Development.Shake.Rule() -- ensure the module gets imported, and thus tested import General.Base import General.String-import Development.Shake.FileTime+import Development.Shake.FileInfo import Development.Shake.FilePath import Control.Exception hiding (assert)@@ -13,6 +13,7 @@ import Data.Char import Data.List import Data.Maybe+import qualified Data.ByteString as BS import System.Directory as IO import System.Environment import System.Random@@ -64,7 +65,7 @@ withArgs (args \\ files) $ shakeWithClean (removeDirectoryRecursive out) - (shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html", shakeLint=Just $ if isJust tracker then LintTracker else LintBasic})+ (shakeOptions{shakeFiles=out, shakeReport=["output/" ++ name ++ "/report.html"], shakeLint=Just $ if isJust tracker then LintTracker else LintBasic}) (rules files (out++)) @@ -130,7 +131,8 @@ noTest :: ([String] -> IO ()) -> (String -> String) -> IO () noTest build obj = do- build ["--abbrev=output=$OUT"]+ build ["--abbrev=output=$OUT","-j3"]+ build ["--no-build","--report=-"] build [] @@ -145,9 +147,9 @@ createDirectoryIfMissing True $ takeDirectory file mtimes <- forM [1..10] $ \i -> fmap fst $ duration $ do writeFile file $ show i- let time = getModTimeError "File is missing" $ packU file+ let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $ getFileInfo $ packU file t1 <- time- flip loop 0 $ \j -> do+ flip loopM 0 $ \j -> do writeFile file $ show (i,j) t2 <- time return $ if t1 == t2 then Left $ j+1 else Right ()@@ -172,13 +174,21 @@ return $ files++rest -copyDirectory :: FilePath -> FilePath -> IO ()-copyDirectory old new = do+copyDirectoryChanged :: FilePath -> FilePath -> IO ()+copyDirectoryChanged old new = do xs <- getDirectoryContentsRecursive old forM_ xs $ \from -> do let to = new </> drop (length $ addTrailingPathSeparator old) from createDirectoryIfMissing True $ takeDirectory to- copyFile from to+ copyFileChanged from to+++copyFileChanged :: FilePath -> FilePath -> IO ()+copyFileChanged old new = do+ good <- IO.doesFileExist new+ good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new)+ when (not good) $ copyFile old new+ withTemporaryDirectory :: (FilePath -> IO ()) -> IO () withTemporaryDirectory act = do
General/Base.hs view
@@ -7,12 +7,14 @@ Duration, duration, Time, offsetTime, sleep, isWindows, getProcessorCount, readFileUCS2, getEnvMaybe, captureOutput,+ showDP, showTime, modifyIORef'', writeIORef'',- whenJust, loop, whileM, partitionM, concatMapM, mapMaybeM,+ whenJust, loopM, whileM, partitionM, concatMapM, mapMaybeM, fastNub, showQuote, withBufferMode, withCapabilities ) where +import Control.Arrow import Control.Concurrent import Control.Exception import Control.Monad@@ -22,6 +24,7 @@ import Data.Maybe import Data.Time import qualified Data.HashSet as Set+import Numeric import System.Directory import System.Environment import System.IO@@ -157,17 +160,33 @@ ---------------------------------------------------------------------+-- Data.String++showDP :: Int -> Double -> String+showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'+ where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""++showTime :: Double -> String+showTime x | x >= 3600 = f (x / 60) "h" "m"+ | x >= 60 = f x "m" "s"+ | otherwise = showDP 2 x ++ "s"+ where+ f x m s = show ms ++ m ++ ['0' | ss < 10] ++ show ss ++ m+ where (ms,ss) = round x `divMod` 60+++--------------------------------------------------------------------- -- Control.Monad whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust (Just a) f = f a whenJust Nothing f = return () -loop :: Monad m => (a -> m (Either a b)) -> a -> m b-loop act x = do+loopM :: Monad m => (a -> m (Either a b)) -> a -> m b+loopM act x = do res <- act x case res of- Left x -> loop act x+ Left x -> loopM act x Right v -> return v whileM :: Monad m => m Bool -> m ()
General/Binary.hs view
@@ -5,6 +5,7 @@ BinList(..), BinFloat(..) ) where +import Control.Applicative import Control.Monad import Data.Binary import Data.List@@ -18,7 +19,7 @@ instance (BinaryWith ctx a, BinaryWith ctx b) => BinaryWith ctx (a,b) where putWith ctx (a,b) = putWith ctx a >> putWith ctx b- getWith ctx = do a <- getWith ctx; b <- getWith ctx; return (a,b)+ getWith ctx = liftA2 (,) (getWith ctx) (getWith ctx) instance BinaryWith ctx a => BinaryWith ctx [a] where putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs
General/Timing.hs view
@@ -1,11 +1,10 @@ module General.Timing(resetTimings, addTiming, printTimings) where -import Control.Arrow import Data.IORef import Data.Time import System.IO.Unsafe-import Numeric+import General.Base {-# NOINLINE timings #-}@@ -51,8 +50,3 @@ showGap :: [(String,String)] -> [String] showGap xs = [a ++ replicate (n - length a - length b) ' ' ++ b | (a,b) <- xs] where n = maximum [length a + length b | (a,b) <- xs]---showDP :: Int -> Double -> String-showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'- where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""
README.md view
@@ -19,3 +19,4 @@ * [Questions](http://stackoverflow.com/questions/tagged/shake-build-system) can be asked on StackOverflow with the tag `shake-build-system`. * [Bugs](https://github.com/ndmitchell/shake/issues) can be reported on the GitHub issue tracker. * [Source code](http://github.com/ndmitchell/shake) in a git repo, stored at GitHub.+* Continuous integration with [Travis](https://travis-ci.org/ndmitchell/shake) and [Hydra](http://hydra.cryp.to/jobset/shake/master).
Test.hs view
@@ -7,7 +7,7 @@ import Data.Maybe import System.Environment import General.Timing-import Development.Shake.FileTime+import Development.Shake.FileInfo import General.String import qualified Data.ByteString.Char8 as BS import Examples.Util(sleepFileTimeCalibrate)@@ -23,6 +23,7 @@ import qualified Examples.Test.Cache as Cache import qualified Examples.Test.Command as Command import qualified Examples.Test.Config as Config+import qualified Examples.Test.Digest as Digest import qualified Examples.Test.Directory as Directory import qualified Examples.Test.Docs as Docs import qualified Examples.Test.Errors as Errors@@ -52,7 +53,7 @@ mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main ,"basic" * Basic.main, "cache" * Cache.main, "command" * Command.main- ,"config" * Config.main, "directory" * Directory.main+ ,"config" * Config.main, "digest" * Digest.main, "directory" * Directory.main ,"docs" * Docs.main, "errors" * Errors.main, "orderonly" * OrderOnly.main ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main ,"journal" * Journal.main, "lint" * Lint.main, "makefile" * Makefile.main, "manual" * Manual.main@@ -114,7 +115,7 @@ vars <- forM [a,b,c,d] $ \xs -> do mvar <- newEmptyMVar forkIO $ do- mapM_ (getModTimeMaybe . packU_) xs+ mapM_ (getFileInfo . packU_) xs putMVar mvar () return $ takeMVar mvar sequence_ vars
docs/Manual.md view
@@ -403,9 +403,9 @@ #### Multiple outputs -Some tools, for example [bison](http://www.gnu.org/software/bison/), can generate multiple outputs from one execution. We can track these in Shake using the `*>>` operator to define rules:+Some tools, for example [bison](http://www.gnu.org/software/bison/), can generate multiple outputs from one execution. We can track these in Shake using the `&*>` operator to define rules: - ["//*.bison.h","//*.bison.c"] *>> \[outh, outc] -> do+ ["//*.bison.h","//*.bison.c"] &*> \[outh, outc] -> do let src = outc -<.> "y" cmd "bison -d -o" [outc] [src] @@ -488,7 +488,7 @@ The previous section described how to deal with generated include files, but only coped with headers included directly by the C file. This section describes how to extend that to work with generated headers used either in C or header files, even when used by headers that were themselves generated. We can write: - ["*.c.dep","*.h.dep"] **> \out -> do+ ["*.c.dep","*.h.dep"] |*> \out -> do src <- readFile' $ dropExtension out writeFileLines out $ usedHeaders src @@ -504,7 +504,7 @@ For simplicity, this code assumes all files are in a single directory and all objects are generated files are placed in the same directory. We define three rules: -* The `*.c.dep` and `*.h.dep` rule uses `**>`, which defines a single action that matches multiple patterns. The file `foo.h.dep` contains a list of headers directly included by `foo.h`, using `usedHeaders` from the previous section.+* The `*.c.dep` and `*.h.dep` rule uses `|*>`, which defines a single action that matches multiple patterns. The file `foo.h.dep` contains a list of headers directly included by `foo.h`, using `usedHeaders` from the previous section. * The `*.deps` rule takes the transitive closure of dependencies, so `foo.h.deps` contains `foo.h` and all headers that `foo.h` pulls in. The rule takes the target file, and all the `.deps` for anything in the `.dep` file, and combines them. More abstractly, the rule calculates the transitive closure of _a_, namely _a*_, by taking the dependencies of _a_ (say _b_ and _c_) and computing _a\* = union(a, b\*, c\*)_. * The `*.o` rule reads the associated `.deps` file (ensuring it is up to date) and then depends on its contents.
html/shake-logic.js view
@@ -44,6 +44,7 @@ ,countTrace : 0, countTraceLast : 0 // :: Int, traced commands run ,sumTrace : 0, sumTraceLast : 0 // :: Seconds, time running traced commands ,maxTrace : 0 // :: Seconds, longest traced command+ ,maxTraceName : "" // :: String, longest trace command ,maxTraceStopLast : 0 // :: Seconds, time the last traced command stopped }; @@ -67,6 +68,7 @@ res.sumTrace += time; res.sumTraceLast += isLast ? time : 0; res.maxTrace = Math.max(res.maxTrace, time);+ if (res.maxTrace == time) res.maxTraceName = traces[j].command; res.maxTraceStopLast = Math.max(res.maxTraceStopLast, isLast ? traces[j].stop : 0); } }@@ -79,7 +81,7 @@ ,"There are " + sum.count + " rules (" + sum.countLast + " rebuilt in the last run)." ,"Building required " + sum.countTrace + " traced commands (" + sum.countTraceLast + " in the last run)." ,"The total (unparallelised) build time is " + showTime(sum.sumExecution) + " of which " + showTime(sum.sumTrace) + " is traced commands."- ,"The longest rule takes " + showTime(sum.maxExecution) + ", and the longest traced command takes " + showTime(sum.maxTrace) + "."+ ,"The longest rule takes " + showTime(sum.maxExecution) + " (" + sum.maxExecutionName + ") and the longest traced command takes " + showTime(sum.maxTrace) + " (" + sum.maxTraceName + ")." ,"Last run gave an average parallelism of " + (sum.maxTraceStopLast === 0 ? 0 : sum.sumTraceLast / sum.maxTraceStopLast).toFixed(2) + " times over " + showTime(sum.maxTraceStopLast) + "." ]; }
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.12+version: 0.13 license: BSD3 license-file: LICENSE category: Development@@ -121,8 +121,8 @@ Development.Shake.Database Development.Shake.Derived Development.Shake.Errors+ Development.Shake.FileInfo Development.Shake.FilePattern- Development.Shake.FileTime Development.Shake.Pool Development.Shake.Progress Development.Shake.Report@@ -231,6 +231,7 @@ Examples.Test.Cache Examples.Test.Command Examples.Test.Config+ Examples.Test.Digest Examples.Test.Directory Examples.Test.Docs Examples.Test.Errors