shake 0.11.7 → 0.12
raw patch · 19 files changed
+593/−425 lines, 19 files
Files
- CHANGES.txt +10/−0
- Development/Make/All.hs +4/−4
- Development/Ninja/All.hs +46/−4
- Development/Shake/Args.hs +2/−2
- Development/Shake/Core.hs +254/−262
- Development/Shake/Derived.hs +4/−0
- Development/Shake/FileTime.hs +48/−42
- Development/Shake/Sys.hs +0/−82
- Examples/Ninja/Main.hs +9/−0
- Examples/Ninja/compdb.ninja +45/−0
- Examples/Ninja/compdb.output +17/−0
- Examples/Self/Main.hs +2/−1
- Examples/Test/Command.hs +2/−1
- Examples/Util.hs +3/−5
- General/Base.hs +35/−1
- General/RAW.hs +96/−0
- Start.hs +9/−2
- Test.hs +4/−17
- shake.cabal +3/−2
CHANGES.txt view
@@ -1,5 +1,15 @@ Changelog for Shake +0.12+ #62, move to a ReaderT/IORef for the Action monad+ Add DEPRECATED pragmas on system' calls+ Delete Development.Shake.Sys, use command or cmd instead+ Add a 'console' pool to Ninja+ Avoid using System.Cmd (deprecated in GHC HEAD)+ #41, use higher precision file times on POSIX+ #117, use higher precision times for Unicode files on Windows+ #118, add support for Ninja -t compdb+ #119, more test fixes for Linux GHC 7.8 0.11.7 #119, test fixes for Linux GHC 7.8 0.11.6
Development/Make/All.hs view
@@ -14,7 +14,7 @@ import Data.Maybe import Control.Arrow import Control.Monad -import System.Cmd +import System.Process import System.Exit import Control.Monad.Trans.State.Strict @@ -85,15 +85,15 @@ forM_ cmd $ \c -> case c of Expr c -> (if silent then quietly else id) $ - runCommand =<< liftIO (askEnv env c) + execCommand =<< liftIO (askEnv env c) return $ if phony then Phony else NotPhony has auto name target = or [(null ws && auto) || target `elem` ws | Ruler t (_,Lit s) _ <- rs, t == name, let ws = words s] -runCommand :: String -> Action () -runCommand x = do +execCommand :: String -> Action () +execCommand x = do res <- if "@" `isPrefixOf` x then sys $ drop 1 x else putNormal x >> sys x when (res /= ExitSuccess) $
Development/Ninja/All.hs view
@@ -23,17 +23,39 @@ import Data.Char -runNinja :: FilePath -> [String] -> IO (Rules ()) -runNinja file args = do +runNinja :: FilePath -> [String] -> Maybe String -> IO (Maybe (Rules ())) +runNinja file args (Just "compdb") = do + dir <- getCurrentDirectory + Ninja{..} <- parse file =<< newEnv + rules <- return $ Map.fromList [r | r <- rules, BS.unpack (fst r) `elem` args] + -- the build items are generated in reverse order, hence the reverse + let xs = [(a,b,file,rule) | (a,b@Build{..}) <- reverse $ multiples ++ map (first return) singles + , Just rule <- [Map.lookup ruleName rules], file:_ <- [depsNormal]] + xs <- forM xs $ \(out,Build{..},file,Rule{..}) -> do + -- the order of adding new environment variables matters + env <- scopeEnv env + addEnv env (BS.pack "out") (BS.unwords $ map quote out) + addEnv env (BS.pack "in") (BS.unwords $ map quote depsNormal) + addEnv env (BS.pack "in_newline") (BS.unlines depsNormal) + addBinds env buildBind + addBinds env ruleBind + commandline <- fmap BS.unpack $ askVar env $ BS.pack "command" + return $ CompDb dir commandline $ BS.unpack $ head depsNormal + putStr $ printCompDb xs + return Nothing + +runNinja file args (Just x) = error $ "Unknown tool argument, expected 'compdb', got " ++ x + +runNinja file args tool = do addTiming "Ninja parse" ninja@Ninja{..} <- parse file =<< newEnv - return $ do + return $ Just $ do needDeps <- return $ needDeps ninja -- partial application phonys <- return $ Map.fromList phonys singles <- return $ Map.fromList $ map (first normalise) singles multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map normalise) multiples, x <- xs] rules <- return $ Map.fromList rules - pools <- fmap Map.fromList $ forM pools $ \(name,depth) -> + pools <- fmap Map.fromList $ forM ((BS.pack "console",1):pools) $ \(name,depth) -> fmap ((,) name) $ newResource (BS.unpack name) depth action $ needBS $ map normalise $ concatMap (resolvePhony phonys) $ @@ -172,3 +194,23 @@ bsNote = BS.pack "Note: including file:" bsProgFiles = BS.pack "PROGRAM FILES" bsVisStudio = BS.pack "MICROSOFT VISUAL STUDIO" + + +data CompDb = CompDb + {cdbDirectory :: String + ,cdbCommand :: String + ,cdbFile :: String + } + deriving Show + +printCompDb :: [CompDb] -> String +printCompDb xs = unlines $ ["["] ++ concat (zipWith f [1..] xs) ++ ["]"] + where + n = length xs + f i CompDb{..} = + [" {" + ," \"directory\": " ++ g cdbDirectory ++ "," + ," \"command\": " ++ g cdbCommand ++ "," + ," \"file\": " ++ g cdbFile + ," }" ++ (if i == n then "" else ",")] + g = show
Development/Shake/Args.hs view
@@ -239,7 +239,7 @@ ,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=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 "" ["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."@@ -258,7 +258,7 @@ ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much." ,no $ Option "" ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time." ,yes $ Option "" ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."- ,yes $ Option "t" ["touch"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Assume targets are clean."+ ,yes $ Option "" ["touch"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Assume targets are clean." ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print tracing information." ,no $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit." ,no $ Option "w" ["print-directory"] (NoArg $ Right ([PrintDirectory True],id)) "Print the current directory."
Development/Shake/Core.hs view
@@ -28,7 +28,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Writer.Strict-import Control.Monad.Trans.State.Strict as State import Data.Typeable import Data.Function import Data.List@@ -50,6 +49,7 @@ import General.Timing import General.Base import General.String+import General.RAW ---------------------------------------------------------------------@@ -86,40 +86,40 @@ storedValue :: ShakeOptions -> key -> IO (Maybe value) -data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value))+data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value)) -ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key+ruleKey :: Rule key value => (key -> Maybe (m value)) -> key ruleKey = err "ruleKey" -ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value+ruleValue :: Rule key value => (key -> Maybe (m value)) -> value ruleValue = err "ruleValue" -- | Define a set of rules. Rules can be created with calls to functions such as 'Development.Shake.*>' 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)+newtype Rules a = Rules (WriterT (SRules Action) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars) deriving (Monad, Functor, Applicative) rulesIO :: IO a -> Rules a rulesIO = Rules . liftIO -newRules :: SRules -> Rules ()+newRules :: SRules Action -> Rules () newRules = Rules . tell -modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()+modifyRules :: (SRules Action -> SRules Action) -> Rules () -> Rules () modifyRules f (Rules r) = Rules $ censor f r -getRules :: Rules () -> IO SRules+getRules :: Rules () -> IO (SRules Action) getRules (Rules r) = execWriterT r -data SRules = SRules- {actions :: [Action ()]- ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule)]) -- higher fst is higher priority+data SRules m = SRules+ {actions :: [m ()]+ ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Int,ARule m)]) -- higher fst is higher priority } -instance Monoid SRules where+instance Monoid (SRules m) where mempty = SRules [] (Map.fromList []) mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2) where f (k, v1, xs) (_, v2, ys)@@ -128,7 +128,7 @@ instance Monoid a => Monoid (Rules a) where mempty = return mempty- mappend a b = do a <- a; b <- b; return $ mappend a b+ mappend = liftA2 mappend -- | Like 'rule', but lower priority, if no 'rule' exists then 'defaultRule' is checked.@@ -168,101 +168,6 @@ 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. -- -- @@@ -288,52 +193,88 @@ withoutActions = modifyRules $ \x -> x{actions=[]} ------------------------------------------------------------------------- MAKE+registerWitnesses :: SRules m -> IO ()+registerWitnesses SRules{..} =+ forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do+ registerWitness $ ruleKey r+ registerWitness $ ruleValue r -data RuleInfo = RuleInfo++data RuleInfo m = RuleInfo {stored :: Key -> IO (Maybe Value)- ,execute :: Key -> Action Value+ ,execute :: Key -> m Value ,resultType :: TypeRep } -data SAction = SAction- -- global constants- {database :: Database- ,pool :: Pool- ,timestamp :: IO Time- ,ruleinfo :: Map.HashMap TypeRep RuleInfo- ,output :: Verbosity -> String -> IO ()- ,opts :: ShakeOptions- ,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- ,verbosity :: Verbosity- ,depends :: [Depends] -- built up in reverse- ,discount :: !Duration- ,traces :: [Trace] -- in reverse- ,blockapply :: Maybe String -- reason to block apply, or Nothing to allow- ,trackAllows :: [Key -> Bool]- ,trackUsed :: [Key]+createRuleinfo :: ShakeOptions -> SRules Action -> Map.HashMap TypeRep (RuleInfo Action)+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 (m value)) -> (key -> IO (Maybe value))+ f _ = storedValue opt++ execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of+ [r]:_ -> r+ rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)+ where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] ++ sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest+ sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)++runStored :: Map.HashMap TypeRep (RuleInfo m) -> Key -> IO (Maybe Value)+runStored mp k = case Map.lookup (typeKey k) mp of+ Nothing -> return Nothing+ Just RuleInfo{..} -> stored k++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+ Just RuleInfo{..} -> execute k+++---------------------------------------------------------------------+-- MAKE++-- global constants of Action+data Global = Global+ {globalDatabase :: Database+ ,globalPool :: Pool+ ,globalTimestamp :: IO Time+ ,globalRules :: Map.HashMap TypeRep (RuleInfo Action)+ ,globalOutput :: Verbosity -> String -> IO ()+ ,globalOptions :: ShakeOptions+ ,globalDiagnostic :: String -> IO ()+ ,globalLint :: String -> IO ()+ ,globalAfter :: IORef [IO ()]+ ,globalTrackAbsent :: IORef [(Key, Key)] -- in rule fst, snd must be absent } ++-- local variables of Action+data Local = Local+ -- constants+ {localStack :: Stack+ -- stack scoped local variables+ ,localVerbosity :: Verbosity+ ,localBlockApply :: Maybe String -- reason to block apply, or Nothing to allow+ -- mutable local variables+ ,localDepends :: [Depends] -- built up in reverse+ ,localDiscount :: !Duration+ ,localTraces :: [Trace] -- in reverse+ ,localTrackAllows :: [Key -> Bool]+ ,localTrackUsed :: [Key]+ }+ -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files. -- Action values are used by 'rule' and 'action'. The 'Action' monad tracks the dependencies of a 'Rule'.-newtype Action a = Action (StateT SAction IO a)- deriving (Monad, MonadIO, Functor, Applicative)+newtype Action a = Action {fromAction :: RAW Global Local a}+ deriving (Functor, Applicative, Monad, MonadIO) -- | If an exception is raised by the 'Action', perform some 'IO'. actionOnException :: Action a -> IO b -> Action a-actionOnException act clean = do- s <- Action State.get- (res,s) <- liftIO $ onException (runAction s act) clean- Action $ State.put s- return res+actionOnException act clean = Action $+ catchRAW (fromAction act) (\(e :: SomeException) -> liftIO clean >> throwRAW e) -- | After an 'Action', perform some 'IO', even if there is an exception.@@ -400,8 +341,9 @@ 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 absent emptyStack shakeVerbosity [] 0 [] Nothing [] []- mapM_ (addPool pool . staunch . runAction s0) (actions rs)+ let s0 = Global database pool start ruleinfo output opts diagnostic lint after absent+ let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] []+ mapM_ (addPool pool . staunch . runAction s0 s1) (actions rs) when (isJust shakeLint) $ do addTiming "Lint checking"@@ -419,22 +361,8 @@ sequence_ . reverse =<< readIORef after -withCapabilities :: Int -> IO a -> IO a-#if __GLASGOW_HASKELL__ >= 706-withCapabilities new act | rtsSupportsBoundThreads = do- old <- getNumCapabilities- if old == new then act else- bracket_ (setNumCapabilities new) (setNumCapabilities old) act-#endif-withCapabilities new act = act- lineBuffering :: IO a -> IO a-lineBuffering = f stdout . f stderr- where- f h act = do- bracket (hGetBuffering h) (hSetBuffering h) $ const $ do- hSetBuffering h LineBuffering- act+lineBuffering = withBufferMode stdout LineBuffering . withBufferMode stderr LineBuffering abbreviate :: [(String,String)] -> String -> String@@ -458,64 +386,31 @@ else throwIO $ ShakeException (last stk) stk $ SomeException e -registerWitnesses :: SRules -> IO ()-registerWitnesses SRules{..} =- forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do- registerWitness $ ruleKey r- registerWitness $ ruleValue r---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 opt-- execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of- [r]:_ -> r- rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)- where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] -- sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest- sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)--runStored :: Map.HashMap TypeRep RuleInfo -> Key -> IO (Maybe Value)-runStored mp k = case Map.lookup (typeKey k) mp of- Nothing -> return Nothing- Just RuleInfo{..} -> stored k--runExecute :: Map.HashMap TypeRep RuleInfo -> Key -> Action Value-runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of- Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing -- Not sure if this is even possible, but best be safe- Just RuleInfo{..} -> execute k---runAction :: SAction -> Action a -> IO (a, SAction)-runAction s (Action x) = runStateT x s+runAction :: Global -> Local -> Action a -> IO a+runAction g l (Action x) = runRAW g l x runAfter :: IO () -> Action () runAfter op = do- s <- Action State.get- liftIO $ atomicModifyIORef (after s) $ \ops -> (op:ops, ())+ Global{..} <- Action getRO+ liftIO $ atomicModifyIORef globalAfter $ \ops -> (op:ops, ()) -- | 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'. -- 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+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] f ks = do let tk = typeOf (err "apply key" :: key) tv = typeOf (err "apply type" :: value)- ruleinfo <- Action $ State.gets ruleinfo- block <- Action $ State.gets blockapply+ Global{..} <- Action getRO+ block <- Action $ getsRW localBlockApply whenJust block $ errorNoApply tk (fmap show $ listToMaybe ks)- case Map.lookup tk ruleinfo of+ case Map.lookup tk globalRules of Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv) Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks@@ -524,27 +419,29 @@ applyKeyValue :: [Key] -> Action [Value] applyKeyValue [] = return [] applyKeyValue ks = do- s <- Action State.get- let exec stack k = try $ wrapStack (showStack (database s) stack) $ do+ global@Global{..} <- Action getRO+ let exec stack k = try $ wrapStack (showStack globalDatabase stack) $ do evaluate $ rnf k- let s2 = s{verbosity=shakeVerbosity $ opts s, depends=[], stack=stack, discount=0, traces=[], trackAllows=[], trackUsed=[]}+ let s = Local {localVerbosity=shakeVerbosity globalOptions, localDepends=[], localStack=stack, localBlockApply=Nothing+ ,localDiscount=0, localTraces=[], localTrackAllows=[], localTrackUsed=[]} let top = showTopStack stack- lint s $ "before building " ++ top- (dur,(res,s2)) <- duration $ runAction s2 $ do+ globalLint $ "before building " ++ top+ (dur,(res,Local{..})) <- duration $ runAction global s $ do putWhen Chatty $ "# " ++ show k- res <- runExecute (ruleinfo s) k- when (shakeLint (opts s) == Just LintTracker)+ res <- runExecute globalRules k+ when (shakeLint globalOptions == Just LintTracker) trackCheckUsed- return res- lint s $ "after building " ++ top- let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2)+ Action $ fmap ((,) res) getRW+ globalLint $ "after building " ++ top+ let ans = (res, reverse localDepends, dur - localDiscount, reverse localTraces) evaluate $ rnf ans return ans- res <- liftIO $ build (pool s) (database s) (Ops (runStored (ruleinfo s)) exec) (stack s) ks+ stack <- Action $ getsRW localStack+ res <- liftIO $ build globalPool globalDatabase (Ops (runStored globalRules) exec) stack ks case res of Left err -> throw err Right (dur, dep, vs) -> do- Action $ State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s}+ Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s} return vs @@ -556,7 +453,7 @@ -- | Get the initial 'ShakeOptions', these will not change during the build process. getShakeOptions :: Action ShakeOptions-getShakeOptions = Action $ gets opts+getShakeOptions = Action $ getsRO globalOptions -- | Write an action to the trace list, along with the start/end time of running the IO action.@@ -564,20 +461,22 @@ -- The trace list is used for profile reports (see 'shakeReport'). traced :: String -> IO a -> Action a traced msg act = do- s <- Action State.get- start <- liftIO $ timestamp s- putNormal $ "# " ++ msg ++ " " ++ showTopStack (stack s)+ Global{..} <- Action getRO+ stack <- Action $ getsRW localStack+ start <- liftIO globalTimestamp+ putNormal $ "# " ++ msg ++ " " ++ showTopStack stack res <- liftIO act- stop <- liftIO $ timestamp s- Action $ State.modify $ \s -> s{traces = Trace (pack msg) start stop : traces s}+ stop <- liftIO globalTimestamp+ Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) start stop : localTraces s} return res putWhen :: Verbosity -> String -> Action () putWhen v msg = do- s <- Action State.get- when (verbosity s >= v) $- liftIO $ output s v msg+ Global{..} <- Action getRO+ verb <- getVerbosity+ when (verb >= v) $+ liftIO $ globalOutput v msg -- | Write a message to the output when the verbosity ('shakeVerbosity') is appropriate.@@ -594,19 +493,15 @@ -- 'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are -- not interleaved. The verbosity can be modified locally by 'withVerbosity'. getVerbosity :: Action Verbosity-getVerbosity = Action $ gets verbosity+getVerbosity = Action $ getsRW localVerbosity -- | Run an action with a particular verbosity level. -- Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will -- not have any impact on 'Diagnostic' tracing. withVerbosity :: Verbosity -> Action a -> Action a-withVerbosity new act = do- old <- Action $ State.gets verbosity- Action $ State.modify $ \s -> s{verbosity=new}- res <- act- Action $ State.modify $ \s -> s{verbosity=old}- return res+withVerbosity new = Action . unmodifyRW f . fromAction+ where f s0 = (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0}) -- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'@@ -617,6 +512,112 @@ quietly = withVerbosity Quiet +---------------------------------------------------------------------+-- TRACKING++-- | 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+ Global{..} <- Action getRO+ l@Local{..} <- Action getRW+ deps <- liftIO $ concatMapM (listDepends globalDatabase) localDepends+ let top = topStack localStack+ if top == Just k then+ return () -- condition 1+ else if k `elem` deps then+ return () -- condition 2+ else if any ($ k) localTrackAllows then+ return () -- condition 3+ else+ Action $ putRW l{localTrackUsed = k : localTrackUsed} -- condition 4+++trackCheckUsed :: Action ()+trackCheckUsed = do+ Global{..} <- Action getRO+ Local{..} <- Action getRW+ liftIO $ do+ deps <- concatMapM (listDepends globalDatabase) localDepends++ -- check 3a+ bad <- return $ localTrackUsed \\ 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 <- flip filterM localTrackUsed $ \k -> fmap (not . null) $ lookupDependencies globalDatabase 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+ Global{..} <- Action getRO+ Local{..} <- Action getRW+ liftIO $ do+ let top = topStack localStack+ if top == Just k then+ return () -- condition 1+ else if any ($ k) localTrackAllows then+ return () -- condition 2+ else+ -- condition 3+ atomicModifyIORef globalTrackAbsent $ \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 $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows 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)+++---------------------------------------------------------------------+-- RESOURCES+ -- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists. -- Shake will ensure that actions using the same finite resource do not execute in parallel. -- As an example, only one set of calls to the Excel API can occur at one time, therefore@@ -684,32 +685,27 @@ blockApply :: String -> Action a -> Action a-blockApply msg act = do- s0 <- Action State.get- Action $ State.put s0{blockapply=Just msg}- res <- act- Action $ State.modify $ \s -> s{blockapply=blockapply s0}- return res+blockApply msg = Action . unmodifyRW f . fromAction+ where f s0 = (s0{localBlockApply=Just msg}, \s -> s{localBlockApply=localBlockApply s0}) -- | Run an action which uses part of a finite resource. For more details see 'Resource'. -- 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- (res,s) <- liftIO $ bracket_+withResource r i act = Action $ do+ Global{..} <- getRO+ act <- evalRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) act+ join $ liftIO $ bracket_ (do res <- acquireResource r i case res of- Nothing -> diagnostic s $ show r ++ " acquired " ++ show i ++ " with no wait"+ Nothing -> globalDiagnostic $ show r ++ " acquired " ++ show i ++ " with no wait" Just wait -> do- diagnostic s $ show r ++ " waiting to acquire " ++ show i- blockPool (pool s) $ fmap ((,) False) wait- diagnostic s $ show r ++ " acquired " ++ show i ++ " after waiting")+ globalDiagnostic $ show r ++ " waiting to acquire " ++ show i+ blockPool globalPool $ fmap ((,) False) wait+ globalDiagnostic $ show r ++ " acquired " ++ show i ++ " after waiting") (do releaseResource r i- diagnostic s $ show r ++ " released " ++ show i)- (runAction s $ blockApply ("Within withResource using " ++ show r) act)- Action $ State.put s- return res+ globalDiagnostic $ show r ++ " released " ++ show i)+ act -- | Run an action which uses part of several finite resources. Acquires the resources in a stable@@ -734,31 +730,28 @@ 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+ Nothing -> do pool <- Action $ getsRO globalPool; liftIO $ blockPool pool $ fmap ((,) False) $ waitBarrier bar Just res -> return res case res of- Left err -> liftIO $ throwIO err+ Left err -> Action $ throwRAW err Right (deps,v) -> do- Action $ modify $ \s -> s{depends = deps ++ depends s}+ Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends 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+ pre <- Action $ getsRW localDepends+ res <- Action $ tryRAW $ fromAction $ 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+ Left err -> do+ liftIO $ signalBarrier bar $ Left (err :: SomeException)+ Action $ throwRAW err+ Right v -> do+ post <- Action $ getsRW localDepends 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'.@@ -787,8 +780,7 @@ -- on remote machines using barely any local CPU resources. Unsafe as it allows the 'shakeThreads' limit to be exceeded. -- 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- (res,s) <- liftIO $ blockPool (pool s) $ fmap ((,) False) $ runAction s act- Action $ State.put s- return res+unsafeExtraThread act = Action $ do+ Global{..} <- getRO+ act <- evalRAW $ fromAction act+ join $ liftIO $ blockPool globalPool $ fmap ((,) False) act
Development/Shake/Derived.hs view
@@ -23,6 +23,10 @@ checkExitCode cmd ExitSuccess = return () checkExitCode cmd (ExitFailure i) = error $ "System command failed (code " ++ show i ++ "):\n" ++ cmd +{-# DEPRECATED system' "Use 'command' or 'cmd'" #-}+{-# DEPRECATED systemCwd "Use 'command' or 'cmd' with 'Cwd'" #-}+{-# DEPRECATED systemOutput "Use 'command' or 'cmd' with 'Stdout' or 'Stderr'" #-}+ -- | /Deprecated:/ Please use 'command' or 'cmd' instead. -- This function will be removed in a future version. --
Development/Shake/FileTime.hs view
@@ -10,29 +10,24 @@ import Data.Char import Data.Int import Data.Word-import qualified Data.ByteString.Char8 as BS-import System.IO.Error-import Control.Exception import Numeric --- Required for Portable+#if defined(PORTABLE)+import System.IO.Error+import Control.Exception import System.Directory import Data.Time import System.Time --- Required for non-portable Windows-#if defined(mingw32_HOST_OS)+#elif defined(mingw32_HOST_OS)+import qualified Data.ByteString.Char8 as BS import Foreign import Foreign.C.Types-type WIN32_FILE_ATTRIBUTE_DATA = Ptr ()-type LPCSTR = Ptr CChar-foreign import stdcall unsafe "Windows.h GetFileAttributesExA" c_getFileAttributesEx :: LPCSTR -> Int32 -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool-size_WIN32_FILE_ATTRIBUTE_DATA = 36-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20-#endif+import Foreign.C.String --- Required for non-portable Unix (since it requires a non-standard library, only require if not portable)-#if !defined(PORTABLE) && !defined(mingw32_HOST_OS)+#else+import System.IO.Error+import Control.Exception import System.Posix.Files.ByteString #endif @@ -64,19 +59,10 @@ getModTimeMaybe :: BSU -> IO (Maybe FileTime)-#if defined(PORTABLE)-getModTimeMaybe x = getModTimeMaybePortable x-#elif defined(mingw32_HOST_OS)-getModTimeMaybe x = getModTimeMaybeWindows x-#else-getModTimeMaybe x = getModTimeMaybeUnix x-#endif --+#if defined(PORTABLE) -- Portable fallback-getModTimeMaybePortable :: BSU -> IO (Maybe FileTime)-getModTimeMaybePortable x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do+getModTimeMaybe x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do time <- getModificationTime $ unpackU x return $ Just $ extractFileTime time @@ -86,27 +72,47 @@ 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-#if defined(mingw32_HOST_OS)-getModTimeMaybeWindows :: BSU -> IO (Maybe FileTime)-getModTimeMaybeWindows x = BS.useAsCString (unpackU_ x) $ \file ->- allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do- res <- c_getFileAttributesEx file 0 info- if res then do- -- Technically a Word32, but we can treak it as an Int32 for peek- dword <- peekByteOff info index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: IO Int32- return $ Just $ fileTime dword- else if requireU x then- getModTimeMaybePortable x+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-#endif +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-#if !defined(PORTABLE) && !defined(mingw32_HOST_OS)-getModTimeMaybeUnix :: BSU -> IO (Maybe FileTime)-getModTimeMaybeUnix x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do- t <- fmap modificationTime $ getFileStatus $ unpackU_ x- return $ Just $ fileTime $ fromIntegral $ fromEnum t+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/Sys.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-}---- | /Deprecated: Please use command or cmd instead. This module will be removed in a future version./------ This module provides versions of the 'Development.Shake.Derived.system'' family of functions--- which take a variable number of arguments.------ All these functions take a variable number of arguments.------ * @String@ arguments are treated as whitespace separated arguments.------ * @[String]@ arguments are treated as literal arguments.------ As an example, to run @ghc --make -O2 inputs -o output@:------ @--- 'sys' \"ghc --make -O2\" inputs \"-o\" [output]--- @------ Note that we enclose @output@ as a list so that if the output name contains spaces they are--- appropriately escaped.-module Development.Shake.Sys {-# DEPRECATED "Use 'command' or 'cmd' instead" #-} (- sys, sysCwd, sysOutput, args- ) where- -import Development.Shake.Core-import Development.Shake.Derived---type a :-> t = a----- | A variable arity version of 'system''.-sys :: SysArguments v => String -> v :-> Action ()-sys x = sys_ [] x--class SysArguments t where sys_ :: [String] -> t-instance (Arg a, SysArguments r) => SysArguments (a -> r) where- sys_ xs x = sys_ $ xs ++ arg x-instance SysArguments (Action ()) where- sys_ (x:xs) = system' x xs- sys_ [] = error "No executable or arguments given to sys"----- | A variable arity version of 'systemCwd'.-sysCwd :: SysCwdArguments v => FilePath -> String -> v :-> Action ()-sysCwd dir x = sysCwd_ dir [] x--class SysCwdArguments t where sysCwd_ :: FilePath -> [String] -> t-instance (Arg a, SysCwdArguments r) => SysCwdArguments (a -> r) where- sysCwd_ dir xs x = sysCwd_ dir $ xs ++ arg x-instance SysCwdArguments (Action ()) where- sysCwd_ dir (x:xs) = systemCwd dir x xs- sysCwd_ dir [] = error "No executable or arguments given to sysCwd"----- | A variable arity version of 'systemOutput'.-sysOutput :: SysOutputArguments v => String -> v :-> Action (String, String)-sysOutput x = sysOutput_ [] x--class SysOutputArguments t where sysOutput_ :: [String] -> t-instance (Arg a, SysOutputArguments r) => SysOutputArguments (a -> r) where- sysOutput_ xs x = sysOutput_ $ xs ++ arg x-instance SysOutputArguments (Action (String, String)) where- sysOutput_ (x:xs) = systemOutput x xs- sysOutput_ [] = error "No executable or arguments given to sys"----- | A variable arity function to accumulate a list of arguments.-args :: ArgsArguments v => v :-> [String]-args = args_ []--class ArgsArguments t where args_ :: [String] -> t-instance (Arg a, ArgsArguments r) => ArgsArguments (a -> r) where- args_ xs x = args_ $ xs ++ arg x-instance ArgsArguments [String] where- args_ = id---class Arg a where arg :: a -> [String]-instance Arg String where arg = words-instance Arg [String] where arg = id
Examples/Ninja/Main.hs view
@@ -4,6 +4,8 @@ import Development.Shake import Development.Shake.FilePath import System.Directory(copyFile)+import Control.Monad+import General.Base import Examples.Util import Data.List import qualified Start@@ -53,3 +55,10 @@ runFail "-f../../Examples/Ninja/lint.ninja bad --lint" "'needed' file required rebuilding" run "-f../../Examples/Ninja/lint.ninja good --lint" runFail "-f../../Examples/Ninja/lint.ninja bad --lint" "not a pre-dependency"++ res <- fmap (reverse . drop 2 . reverse . drop 1 . lines) $ captureOutput $ run "-f../../Examples/Ninja/compdb.ninja -t compdb cxx"+ want <- fmap lines $ readFile "Examples/Ninja/compdb.output"+ 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
+ Examples/Ninja/compdb.ninja view
@@ -0,0 +1,45 @@+# Copied from the Ninja repo++ninja_required_version = 1.3++builddir = build+cxx = g+++ar = ar+cflags = -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti $+ -fno-exceptions -pipe -Wno-missing-field-initializers $+ -DNINJA_PYTHON="python.exe" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501+ldflags = -L$builddir -static++rule cxx+ command = $cxx -MMD -MT $out -MF $out.d $cflags -c $in -o $out+ description = CXX $out+ depfile = $out.d+ deps = gcc++rule ar+ command = cmd /c $ar cqs $out.tmp $in && move /Y $out.tmp $out+ description = AR $out++rule link+ command = $cxx $ldflags -o $out $in $libs+ description = LINK $out++# the depfile parser and ninja lexers are generated using re2c.++# Core source files all build into ninja library.+build $builddir\build.o: cxx src\build.cc+build $builddir\build_log.o: cxx src\build_log.cc+build $builddir\clean.o: cxx src\clean.cc++rule doxygen+ command = doxygen $in+ description = DOXYGEN $in+doxygen_mainpage_generator = src\gen_doxygen_mainpage.sh+rule doxygen_mainpage+ command = $doxygen_mainpage_generator $in > $out+ description = DOXYGEN_MAINPAGE $out+build $builddir\doxygen_mainpage: doxygen_mainpage README COPYING | $+ $doxygen_mainpage_generator+build doxygen: doxygen doc\doxygen.config | $builddir\doxygen_mainpage++default ninja.exe
+ Examples/Ninja/compdb.output view
@@ -0,0 +1,17 @@+[+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\build.o -MF build\\build.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build.cc -o build\\build.o",+ "file": "src\\build.cc"+ },+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\build_log.o -MF build\\build_log.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build_log.cc -o build\\build_log.o",+ "file": "src\\build_log.cc"+ },+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\clean.o -MF build\\clean.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\clean.cc -o build\\clean.o",+ "file": "src\\clean.cc"+ }+]
Examples/Self/Main.hs view
@@ -61,7 +61,8 @@ deps <- readFileLines $ out -<.> "deps" let hs = fixPaths $ unobj $ out -<.> "hs" need $ hs : map (obj . moduleToFile "hi") deps- ghc ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"]+ ghc $ ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] +++ ["-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch obj ".pkgs" *> \out -> do src <- readFile' "shake.cabal"
Examples/Test/Command.hs view
@@ -46,7 +46,8 @@ assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System" build ["ghc-random"]- assertContentsInfix (obj "ghc-random") "unrecognised flags: --random"+ assertContentsInfix (obj "ghc-random") "unrecognised flag"+ assertContentsInfix (obj "ghc-random") "--random" crash ["ghc-random2"] ["unrecognised flag","--random"]
Examples/Util.hs view
@@ -143,16 +143,14 @@ sleepFileTimeCalibrate = do let file = "output/calibrate" createDirectoryIfMissing True $ takeDirectory file- mtimes <- forM [1..3] $ \i -> fmap fst $ duration $ do+ mtimes <- forM [1..10] $ \i -> fmap fst $ duration $ do writeFile file $ show i- -- important to benchmark both modtimes, since #117 means unicode files- -- fall back to getModificationTime on Windows- let time = liftM2 (,) (getModificationTime file) (getModTimeError "File is missing" $ packU file)+ let time = getModTimeError "File is missing" $ packU file t1 <- time flip loop 0 $ \j -> do writeFile file $ show (i,j) t2 <- time- return $ if fst t1 == fst t2 || snd t1 == snd t2 then Left $ j+1 else Right ()+ return $ if t1 == t2 then Left $ j+1 else Right () putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum mtimes * 1000)) ++ "ms" return $ sleep $ min 1 $ maximum mtimes * 2
General/Base.hs view
@@ -6,10 +6,11 @@ Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, Duration, duration, Time, offsetTime, sleep, isWindows, getProcessorCount,- readFileUCS2, getEnvMaybe,+ readFileUCS2, getEnvMaybe, captureOutput, modifyIORef'', writeIORef'', whenJust, loop, whileM, partitionM, concatMapM, mapMaybeM, fastNub, showQuote,+ withBufferMode, withCapabilities ) where import Control.Concurrent@@ -21,10 +22,12 @@ import Data.Maybe import Data.Time import qualified Data.HashSet as Set+import System.Directory import System.Environment import System.IO import System.IO.Error import System.IO.Unsafe+import GHC.IO.Handle(hDuplicate,hDuplicateTo) import Development.Shake.Classes @@ -220,3 +223,34 @@ getEnvMaybe :: String -> IO (Maybe String) getEnvMaybe x = catchJust (\x -> if isDoesNotExistError x then Just x else Nothing) (fmap Just $ getEnv x) (const $ return Nothing)++captureOutput :: IO () -> IO String+captureOutput act = do+ tmp <- getTemporaryDirectory+ (f,h) <- openTempFile tmp "hlint"+ sto <- hDuplicate stdout+ ste <- hDuplicate stderr+ hDuplicateTo h stdout+ hDuplicateTo h stderr+ hClose h+ act+ hDuplicateTo sto stdout+ hDuplicateTo ste stderr+ res <- readFile f+ evaluate $ length res+ removeFile f+ return res++withCapabilities :: Int -> IO a -> IO a+#if __GLASGOW_HASKELL__ >= 706+withCapabilities new act | rtsSupportsBoundThreads = do+ old <- getNumCapabilities+ if old == new then act else+ bracket_ (setNumCapabilities new) (setNumCapabilities old) act+#endif+withCapabilities new act = act++withBufferMode :: Handle -> BufferMode -> IO a -> IO a+withBufferMode h b act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do+ hSetBuffering h LineBuffering+ act
+ General/RAW.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module General.RAW(+ RAW, runRAW,+ getRO, getRW, getsRO, getsRW, putRW, modifyRW,+ withRO, withRW,+ catchRAW, tryRAW, throwRAW,+ evalRAW, unmodifyRW+ ) where++import Control.Exception as E+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.IORef+++newtype RAW ro rw a = RAW {fromRAW :: ReaderT (ro, IORef rw) IO a}+ deriving (Functor, Applicative, Monad, MonadIO)++runRAW :: ro -> rw -> RAW ro rw a -> IO a+runRAW ro rw (RAW m) = do+ ref <- newIORef rw+ runReaderT m (ro, ref)+++---------------------------------------------------------------------+-- STANDARD++getRO :: RAW ro rw ro+getRO = RAW $ asks fst++getRW :: RAW ro rw rw+getRW = RAW $ liftIO . readIORef =<< asks snd++getsRO :: (ro -> a) -> RAW ro rw a+getsRO f = fmap f getRO++getsRW :: (rw -> a) -> RAW ro rw a+getsRW f = fmap f getRW++-- | Strict version+putRW :: rw -> RAW ro rw ()+putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks snd++modifyRW :: (rw -> rw) -> RAW ro rw ()+modifyRW f = do x <- getRW; putRW $ f x++withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a+withRO f m = RAW $ withReaderT (\(ro,rw) -> (f ro, rw)) $ fromRAW m++withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a+withRW f m = RAW $ do+ rw <- asks snd+ ref <- liftIO $ newIORef . f =<< readIORef rw+ withReaderT (\(ro,_) -> (ro,ref)) $ fromRAW m+++---------------------------------------------------------------------+-- EXCEPTIONS++catchRAW :: Exception e => RAW ro rw a -> (e -> RAW ro rw a) -> RAW ro rw a+catchRAW m handle = RAW $ liftCatch E.catch (fromRAW m) (fromRAW . handle)++tryRAW :: Exception e => RAW ro rw a -> RAW ro rw (Either e a)+tryRAW m = catchRAW (fmap Right m) (return . Left)++throwRAW :: Exception e => e -> RAW ro rw a+throwRAW = liftIO . throwIO+++---------------------------------------------------------------------+-- WEIRD STUFF++-- | Given an action, produce a 'RAW' that runs fast, containing+-- an 'IO' that runs slowly (the bulk of the work) and a 'RAW'+-- that runs fast.+evalRAW :: RAW ro rw a -> RAW ro rw (IO (RAW ro rw a))+evalRAW m = RAW $ do+ (ro,rw) <- ask+ return $ do+ ref <- newIORef =<< readIORef rw+ res <- runReaderT (fromRAW m) (ro,ref)+ return $ RAW $ do+ (ro,rw) <- ask+ liftIO $ writeIORef rw =<< readIORef ref+ return res++-- | Apply a modification, run an action, then undo the changes after.+unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a+unmodifyRW f m = do+ (s2,undo) <- fmap f getRW+ putRW s2+ res <- m+ modifyRW undo+ return res
Start.hs view
@@ -7,6 +7,7 @@ import Development.Shake import Development.Shake.FilePath import General.Timing+import Data.Maybe import qualified System.Directory as IO import System.Console.GetOpt @@ -17,18 +18,24 @@ args <- getArgs withArgs ("--no-time":args) $ shakeArgsWith shakeOptions flags $ \opts targets -> do+ let tool = listToMaybe [x | Tool x <- opts] makefile <- case reverse [x | UseMakefile x <- opts] of x:_ -> return x _ -> findMakefile if takeExtension makefile == ".ninja" then- fmap Just $ runNinja makefile targets+ runNinja makefile targets tool+ else if isJust tool then+ error "--tool flag is not supported without a .ninja Makefile" else fmap Just $ runMakefile makefile targets data Flag = UseMakefile FilePath+ | Tool String -flags = [Option "f" ["file","makefile"] (ReqArg (Right . UseMakefile) "FILE") "Read FILE as a makefile."]+flags = [Option "f" ["file","makefile"] (ReqArg (Right . UseMakefile) "FILE") "Read FILE as a makefile."+ ,Option "t" ["tool"] (ReqArg (Right . Tool) "TOOL") "Ninja-compatible tools."+ ] findMakefile :: IO FilePath
Test.hs view
@@ -4,15 +4,13 @@ import Control.Exception import Control.Monad-import Data.List import Data.Maybe import System.Environment-import Development.Shake.Pool import General.Timing import Development.Shake.FileTime import General.String import qualified Data.ByteString.Char8 as BS-import Examples.Util(sleepFileTime, sleepFileTimeCalibrate)+import Examples.Util(sleepFileTimeCalibrate) import Control.Concurrent import qualified Examples.Tar.Main as Tar@@ -92,7 +90,7 @@ ,unwords [" ", exePath, "self", "--jobs=2", "--trace"] ,"" ,"Which will build Shake, using Shake, on 2 threads."]- Just main -> main sleepFileTime+ Just main -> main =<< sleepFileTimeCalibrate makefile :: IO () -> IO ()@@ -128,18 +126,7 @@ test :: IO () -> IO ()-test _ = do+test yield = do args <- getArgs- let tests = filter ((/= "random") . fst) mains- let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests- yield <- sleepFileTimeCalibrate flip onException (putStrLn "TESTS FAILED") $- execute yield [\pause -> withArgs (name:"test":drop 1 args) $ test pause | (name,test) <- priority ++ normal]----- | Execute each item in the list. They may yield (call the first parameter) in which case--- you must execute yield for each one of them.-execute :: IO () -> [IO () -> IO ()] -> IO ()-execute yield acts = runPool True 1 $ \pool -> do- let pause = blockPool pool $ yield >> return (False,())- forM_ acts $ \act -> addPool pool $ act pause+ sequence_ [withArgs (name:"test":drop 1 args) $ test yield | (name,test) <- mains, name /= "random"]
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.11.7+version: 0.12 license: BSD3 license-file: LICENSE category: Development@@ -42,6 +42,7 @@ Examples/MakeTutor/hellomake.h Examples/Tar/list.txt Examples/Ninja/*.ninja+ Examples/Ninja/*.output Paths.hs CHANGES.txt README.md@@ -107,7 +108,6 @@ Development.Shake.Config Development.Shake.FilePath Development.Shake.Rule- Development.Shake.Sys Development.Shake.Util other-modules:@@ -141,6 +141,7 @@ General.Base General.Binary General.Intern+ General.RAW General.String General.Timing Paths_shake