shake 0.10.1 → 0.10.2
raw patch · 36 files changed
+959/−238 lines, 36 filesdep ~process
Dependency ranges changed: process
Files
- Development/Make/Main.hs +32/−21
- Development/Make/Rules.hs +7/−4
- Development/Make/Type.hs +0/−9
- Development/Shake.hs +3/−7
- Development/Shake/Args.hs +13/−5
- Development/Shake/Command.hs +304/−0
- Development/Shake/Core.hs +15/−5
- Development/Shake/Database.hs +3/−1
- Development/Shake/Derived.hs +7/−3
- Development/Shake/Directory.hs +7/−7
- Development/Shake/File.hs +5/−5
- Development/Shake/Files.hs +1/−3
- Development/Shake/Locks.hs +5/−5
- Development/Shake/Oracle.hs +10/−4
- Development/Shake/Progress.hs +60/−17
- Development/Shake/Report.hs +19/−11
- Development/Shake/Shake.hs +1/−1
- Development/Shake/Storage.hs +3/−4
- Development/Shake/Sys.hs +3/−1
- Development/Shake/Types.hs +13/−10
- Examples/C/Main.hs +4/−4
- Examples/MakeTutor/Makefile +17/−0
- Examples/MakeTutor/hellofunc.c +9/−0
- Examples/MakeTutor/hellomake.c +8/−0
- Examples/MakeTutor/hellomake.h +5/−0
- Examples/Self/Main.hs +3/−2
- Examples/Test/Command.hs +61/−0
- Examples/Test/Docs.hs +154/−0
- Examples/Test/FilePath.hs +13/−0
- Examples/Test/Makefile.hs +31/−0
- Examples/Test/Progress.hs +11/−5
- Examples/Util.hs +5/−0
- Main.hs +2/−91
- Test.hs +94/−0
- html/shake-ui.js +18/−8
- shake.cabal +13/−5
Development/Make/Main.hs view
@@ -21,16 +21,19 @@ main :: IO () -main = shakeArgsWith shakeOptions{shakeVerbosity=Quiet} args $ \opts targets -> do - makefile <- case reverse [x | UseMakefile x <- opts] of - x:_ -> return x - _ -> findMakefile - fmap Just $ runMakefile makefile targets +main = do + args <- getArgs + withArgs ("--no-time":args) $ + shakeArgsWith shakeOptions flags $ \opts targets -> do + makefile <- case reverse [x | UseMakefile x <- opts] of + x:_ -> return x + _ -> findMakefile + fmap Just $ runMakefile makefile targets -data Args = UseMakefile FilePath +data Flag = UseMakefile FilePath -args = [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."] findMakefile :: IO FilePath @@ -49,15 +52,15 @@ rs <- eval env mk return $ do defaultRuleFile_ - case rs of - Ruler (x:_) _ _ : _ | null args, '%' `notElem` x -> want_ [x] + case filter (not . isPrefixOf "." . target) rs of + Ruler x _ _ : _ | null args, '%' `notElem` x -> want_ [x] _ -> return () mapM_ (want_ . return) args convert rs data Ruler = Ruler - {target :: [String] + {target :: String ,prereq :: (Env, Expr) -- Env is the Env at this point ,cmds :: (Env, [Command]) -- Env is the Env at the end } @@ -65,29 +68,31 @@ eval :: Env -> Makefile -> IO [Ruler] eval env (Makefile xs) = do - (rs, env) <- runStateT (fmap catMaybes $ mapM f xs) env + (rs, env) <- runStateT (fmap concat $ mapM f xs) env return [r{cmds=(env,snd $ cmds r)} | r <- rs] where - f :: Stmt -> StateT Env IO (Maybe Ruler) + f :: Stmt -> StateT Env IO [Ruler] f Assign{..} = do e <- get e <- liftIO $ addEnv name assign expr e put e - return Nothing + return [] f Rule{..} = do e <- get target <- liftIO $ fmap words $ askEnv e targets - return $ Just $ Ruler target (e, prerequisites) (undefined, commands) + return $ map (\t -> Ruler t (e, prerequisites) (undefined, commands)) target convert :: [Ruler] -> Rules () convert rs = match ??> run where match s = any (isJust . check s) rs - check s r = msum $ map (flip makePattern s) $ target r + check s r = makePattern (target r) s - run target = do + run target = do + let phony = has False ".PHONY" target + let silent = has True ".SILENT" target (deps, cmds) <- fmap (first concat . second concat . unzip) $ forM rs $ \r -> case check target r of Nothing -> return ([], []) @@ -96,7 +101,7 @@ env <- liftIO $ addEnv "@" Equals (Lit target) preEnv pre <- liftIO $ askEnv env preExp vp <- liftIO $ fmap splitSearchPath $ askEnv env $ Var "VPATH" - pre <- mapM (vpath vp) $ words pre + pre <- mapM (vpath vp) $ words $ op pre return (pre, [cmds r]) mapM_ (need_ . return) deps forM_ cmds $ \(env,cmd) -> do @@ -105,15 +110,21 @@ env <- liftIO $ addEnv "<" Equals (Lit $ head $ deps ++ [""]) env forM_ cmd $ \c -> case c of - Expr c -> runCommand =<< liftIO (askEnv env c) + Expr c -> (if silent then quietly else id) $ + runCommand =<< liftIO (askEnv env c) + return $ if phony then Phony else NotPhony + has auto name target = + or [(null ws && auto) || target `elem` ws | Ruler t (_,Lit s) _ <- rs, t == name, let ws = words s] + runCommand :: String -> Action () -runCommand x = traced (unwords $ take 1 $ words x) $ do - res <- if "@" `isPrefixOf` x then system $ drop 1 x - else putStrLn x >> system x +runCommand x = do + res <- if "@" `isPrefixOf` x then sys $ drop 1 x + else putNormal x >> sys x when (res /= ExitSuccess) $ error $ "System command failed: " ++ x + where sys = quietly . traced (unwords $ take 1 $ words x) . system makePattern :: String -> FilePath -> Maybe (String -> String)
Development/Make/Rules.hs view
@@ -4,7 +4,7 @@ module Development.Make.Rules( need_, want_, defaultRuleFile_,- (??>)+ (??>), Phony(..) ) where import Control.Monad.IO.Class@@ -47,10 +47,13 @@ want_ :: [FilePath] -> Rules () want_ = action . need_ +data Phony = Phony | NotPhony deriving Eq -(??>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()+(??>) :: (FilePath -> Bool) -> (FilePath -> Action Phony) -> Rules () (??>) test act = rule $ \(File_Q x_) -> let x = unpack x_ in if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x- act x- liftIO $ fmap File_A $ getModTimeMaybe $ unpack_ x_+ res <- act x+ liftIO $ fmap File_A $ if res == Phony+ then return Nothing+ else getModTimeMaybe $ unpack_ x_
Development/Make/Type.hs view
@@ -56,12 +56,3 @@ g (Lit x:Lit y:xs) = g $ Lit (x ++ y) : xs g (x:xs) = x : g xs g [] = [] - - -substitute :: [(String, Expr)] -> Expr -> Expr -substitute vars = simplifyExpr . transformExpr (f []) - where - f seen (Var x) | x `elem` seen = error $ "Recursion in variables, " ++ show seen - | Just y <- lookup x vars = f (x:seen) y - f seen x = descendExpr (f seen) x -
Development/Shake.hs view
@@ -7,7 +7,7 @@ --import "Development.Shake" --import "Development.Shake.FilePath" -----main = 'shake' 'shakeOptions' $ do+--main = 'shakeArgs' 'shakeOptions' $ do -- 'want' [\"result.tar\"] -- \"*.tar\" '*>' \\out -> do -- contents <- 'readFileLines' $ 'Development.Shake.FilePath.replaceExtension' out \"txt\"@@ -35,17 +35,13 @@ -- * If @ghc --make@ or @cabal@ is capable of building your project, use that instead. Custom build systems are -- necessary for many complex projects, but many projects are not complex. ----- * The CmdArgs package (<http://hackage.haskell.org/package/cmdargs/>) is well suited to providing--- command line parsing for build systems, often using flags to set fields in 'shakeOptions'.+-- * The 'shakeArgs' function automatically handles command line arguments. To define non-file targets use 'phony'. -- -- * Put all result files in a distinguished directory, for example @_make@. You can implement a @clean@--- command by removing that directory, using 'removeDirectoryRecursive'.+-- command by removing that directory, using @'removeFilesAfter' \"_make\" [\"\/\/\*\"]@. -- -- * To obtain parallel builds set 'shakeThreads' to a number greater than 1. You may also need to -- compile with @-threaded@.------ * Often the 'want' commands will be determined by command line arguments, to mirror the behaviour of @make@--- targets. For a default set of 'want' commands that you later override, 'withoutActions' can be useful. -- -- * Lots of compilers produce @.o@ files. To avoid overlapping rules, use @.c.o@ for C compilers, -- @.hs.o@ for Haskell compilers etc.
Development/Shake/Args.hs view
@@ -32,7 +32,7 @@ -- -- @ -- main = 'shakeArgs' 'shakeOptions'{'shakeFiles' = \"_make/\", 'shakeProgress' = 'progressSimple'} $ do--- 'phony' \"clean\" $ 'Development.Shake.removeFilesAfter' \"_make\" \"\/\/*\"+-- 'phony' \"clean\" $ 'Development.Shake.removeFilesAfter' \"_make\" [\"\/\/*\"] -- 'want' [\"_make\/neil.txt\",\"_make\/emily.txt\"] -- \"_make\/*.txt\" '*>' \\out -> -- ... build action here ...@@ -82,7 +82,9 @@ -- As an example of a build system that can use either @gcc@ or @distcc@ for compiling: -- -- @---data Flags = DiscCC deriving Eq+--import System.Console.GetOpt+--+--data Flags = DistCC deriving Eq --flags = [Option \"\" [\"distcc\"] (NoArg $ Right DistCC) \"Run distributed.\"] -- --main = 'shakeArgsWith' 'shakeOptions' flags $ \\flags targets -> return $ Just $ do@@ -137,7 +139,7 @@ res <- try $ shake shakeOpts rules return (True, res) - if not ran || shakeVerbosity shakeOpts < Normal then+ if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then either throwIO return res else let esc code = if Color `elem` flagsExtra then escape code else id@@ -196,6 +198,7 @@ | Color | Help | Sleep+ | NoTime deriving Eq @@ -236,9 +239,10 @@ ,yes $ Option "" ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log." ,yes $ Option "p" ["progress"] (noArg $ \s -> s{shakeProgress=progressSimple}) "Show progress messages." ,yes $ Option " " ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."- ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=Quiet}) "Don't print much."+ ,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 "t" ["touch"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Assume targets are clean."- ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=Loud}) "Print tracing information."+ ,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." ,no $ Option "" ["no-print-directory"] (NoArg $ Right ([PrintDirectory False],id)) "Turn off -w, even if it was turned on implicitly."@@ -247,6 +251,10 @@ where yes = (,) True no = (,) False++ move :: Verbosity -> (Int -> Int) -> Verbosity+ move x by = toEnum $ min (fromEnum mx) $ max (fromEnum mn) $ by $ fromEnum x+ where (mn,mx) = (asTypeOf minBound x, asTypeOf maxBound x) noArg f = NoArg $ Right ([], f) reqArg a f = ReqArg (\x -> Right ([], f x)) a
+ Development/Shake/Command.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-}++-- | /Future plans: I intend to merge this module into "Development.Shake" itself./+--+-- This module provides more powerful and flexible versions of 'Development.Shake.system''.+-- I recommend looking at 'command', followed by 'cmd'.+module Development.Shake.Command(+ command, command_, cmd,+ Stdout(..), Stderr(..), Exit(..),+ CmdResult, CmdOption(..),+ ) where++import Control.Arrow+import Control.Concurrent+import Control.DeepSeq+import Control.Exception as C+import Control.Monad+import Control.Monad.IO.Class+import Data.Either+import Foreign.C.Error+import System.Exit+import System.IO+import System.Process++import Development.Shake.Core+import Development.Shake.FilePath+import Development.Shake.Types++import GHC.IO.Exception (IOErrorType(..), IOException(..))+++---------------------------------------------------------------------+-- ACTUAL EXECUTION++-- | Options passed to 'command' or 'cmd' to control how processes are executed.+data CmdOption+ = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory.+ | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment.+ | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default no @stdin@ is given.+ | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly.+ | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default streams use text encoding.+ | Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable.+ | WithStderr Bool -- ^ Should I include the @stderr@ in the exception if the command fails? Defaults to 'True'.+ | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required.+ | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required.+ deriving (Eq,Ord,Show)++data Result+ = ResultStdout String+ | ResultStderr String+ | ResultCode ExitCode+ deriving Eq+++commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]+commandExplicit funcName opts results exe args = verboser $ tracer $+-- BEGIN COPIED+-- Originally from readProcessWithExitCode with as few changes as possible+ mask $ \restore -> do+ ans <- try $ createProcess cp+ (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++ let close = maybe (return ()) hClose+ flip onException+ (do close inh; close outh; close errh+ terminateProcess pid; waitForProcess pid) $ restore $ do++ -- set pipes to binary if appropriate+ when (BinaryPipes `elem` opts) $ do+ let bin = maybe (return ()) (`hSetBinaryMode` True)+ bin inh; bin outh; bin errh++ -- fork off a thread to start consuming stdout+ (out,waitOut) <- case outh of+ Nothing -> return ("", return ())+ Just outh -> do+ out <- hGetContents outh+ waitOut <- forkWait $ C.evaluate $ rnf out+ when stdoutEcho $ forkIO (hPutStr stdout out) >> return ()+ return (out,waitOut)++ -- fork off a thread to start consuming stderr+ (err,waitErr) <- case errh of+ Nothing -> return ("", return ())+ Just errh -> do+ err <- hGetContents errh+ waitErr <- forkWait $ C.evaluate $ rnf err+ when stderrEcho $ forkIO (hPutStr stderr err) >> return ()+ return (err,waitErr)++ -- now write and flush any input+ let writeInput = do+ case inh of+ Nothing -> return ()+ Just inh -> do+ hPutStr inh input+ hFlush inh+ hClose inh++ C.catch writeInput $ \e -> case e of+ IOError { ioe_type = ResourceVanished+ , ioe_errno = Just ioe }+ | Errno ioe == ePIPE -> return ()+ _ -> throwIO e++ -- wait on the output+ waitOut+ waitErr++ close outh+ close errh++ -- wait on the process+ ex <- waitForProcess pid+-- 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++ return $ flip map results $ \x -> case x of+ ResultStdout _ -> ResultStdout out+ ResultStderr _ -> ResultStderr err+ ResultCode _ -> ResultCode ex+ where+ input = last $ "" : [x | Stdin x <- opts]+ verboser act = do+ v <- getVerbosity+ putLoud $ saneCommandForUser exe args+ (if v >= Loud then quietly else id) act+ tracer = case reverse [x | Traced x <- opts] of+ "":_ -> liftIO+ msg:_ -> traced msg+ [] -> traced (takeFileName exe)++ -- what should I do with these handles+ binary = BinaryPipes `elem` opts+ stdoutEcho = last $ (ResultStdout "" `notElem` results) : [b | EchoStdout b <- opts]+ stdoutCapture = ResultStdout "" `elem` results+ stderrEcho = last $ (ResultStderr "" `notElem` results) : [b | EchoStderr b <- opts]+ stderrThrow = last $ True : [b | WithStderr b <- opts]+ stderrCapture = ResultStderr "" `elem` results || (stderrThrow && ResultCode ExitSuccess `notElem` results)++ cp0 = (if Shell `elem` opts then shell $ unwords $ exe:args else proc exe args)+ {std_out = if binary || stdoutCapture || not stdoutEcho then CreatePipe else Inherit+ ,std_err = if binary || stderrCapture || not stderrEcho then CreatePipe else Inherit+ ,std_in = if null input then Inherit else CreatePipe+ }+ cp = foldl applyOpt cp0{std_out = CreatePipe, std_err = CreatePipe} opts+ applyOpt :: CreateProcess -> CmdOption -> CreateProcess+ applyOpt o (Cwd x) = o{cwd = if x == "" then Nothing else Just x}+ applyOpt o (Env x) = o{env = Just x}+ applyOpt o _ = o+++-- Copied from System.Process+forkWait :: IO a -> IO (IO a)+forkWait a = do+ res <- newEmptyMVar+ _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res+ return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)+++-- Like System.Process, but tweaked to show less escaping,+-- Relies on relatively detailed internals of showCommandForUser.+saneCommandForUser :: FilePath -> [String] -> String+saneCommandForUser cmd args = unwords $ map f $ cmd:args+ where+ f x = if take (length y - 2) (drop 1 y) == x then x else y+ where y = showCommandForUser x []+++---------------------------------------------------------------------+-- FIXED ARGUMENT WRAPPER++-- | Collect the @stdout@ of the process.+-- If you are collecting the @stdout@, it will not be echoed to the terminal, unless you include 'EchoStdout'.+newtype Stdout = Stdout String++-- | Collect the @stderr@ of the process.+-- If you are collecting the @stderr@, it will not be echoed to the terminal, unless you include 'EchoStderr'.+newtype Stderr = Stderr String++-- | Collect the 'ExitCode' of the process.+-- If you do not collect the exit code, any 'ExitFailure' will cause an exception.+newtype Exit = Exit ExitCode++-- | A class for specifying what results you want to collect from a process.+-- Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those.+class CmdResult a where+ -- Return a list of results (with the right type but dummy data)+ -- and a function to transform a populated set of results into a value+ cmdResult :: ([Result], [Result] -> a)++instance CmdResult Exit where+ cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> Exit x)++instance CmdResult Stdout where+ cmdResult = ([ResultStdout ""], \[ResultStdout x] -> Stdout x)++instance CmdResult Stderr where+ cmdResult = ([ResultStderr ""], \[ResultStderr x] -> Stderr x)++instance CmdResult () where+ cmdResult = ([], \[] -> ())++instance (CmdResult x1, CmdResult x2) => CmdResult (x1,x2) where+ cmdResult = (a1++a2, \rs -> let (r1,r2) = splitAt (length a2) rs in (b1 r1, b2 r2))+ where (a1,b1) = cmdResult+ (a2,b2) = cmdResult++cmdResultWith f = second (f .) cmdResult++instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where+ cmdResult = cmdResultWith $ \(a,(b,c)) -> (a,b,c)+++-- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files+-- that are required by the command.+--+-- This function takes a list of options (often just @[]@, see 'CmdOption' for the available+-- options), the name of the executable (either a full name, or a program on the @$PATH@) and+-- a list of arguments. The result is often @()@, but can be a tuple containg any of 'Stdout',+-- 'Stderr' and 'Exit'. Some examples:+--+-- @+-- 'command_' [] \"gcc\" [\"-c\",\"myfile.c\"] -- compile a file, throwing an exception on failure+-- 'Exit' c <- 'command' [] \"gcc\" [\"-c\",myfile] -- run a command, recording the exit code+-- ('Exit' c, 'Stderr' err) <- 'command' [] \"gcc\" [\"-c\",\"myfile.c\"] -- run a command, recording the exit code and error output+-- 'Stdout' out <- 'command' [] \"gcc\" [\"-MM\",\"myfile.c\"] -- run a command, recording the output+-- 'command_' ['Cwd' \"generated\"] \"gcc\" [\"-c\",myfile] -- run a command in a directory+-- @+--+-- Unless you retrieve the 'ExitCode' using 'Exit', any 'ExitFailure' will throw an error, including+-- the 'Stderr' in the exception message. If you capture the 'Stdout' or 'Stderr', that stream will not be echoed to the console,+-- unless you use the option 'EchoStdout' or 'EchoStderr'.+--+-- If you use 'command' inside a @do@ block and do not use the result, you may get a compile-time error about being+-- unable to deduce 'CmdResult'. To avoid this error, use 'command_'.+command :: CmdResult r => [CmdOption] -> String -> [String] -> Action r+command opts x xs = fmap b $ commandExplicit "command" opts a x xs+ where (a,b) = cmdResult++-- | 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 ()+++---------------------------------------------------------------------+-- VARIABLE ARGUMENT WRAPPER++type a :-> t = a+++-- | A variable arity version of 'command'.+--+-- * @String@ arguments are treated as whitespace separated arguments.+--+-- * @[String]@ arguments are treated as literal arguments.+--+-- * 'CmdOption' arguments are used as options.+--+-- To take the examples from 'command':+--+-- @+-- () <- 'cmd' \"gcc -c myfile.c\" -- compile a file, throwing an exception on failure+-- 'Exit' c <- 'cmd' \"gcc -c\" [myfile] -- run a command, recording the exit code+-- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\" -- run a command, recording the exit code and error output+-- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\" -- run a command, recording the output+-- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'Action' () -- run a command in a directory+-- @+--+-- When passing file arguments we use @[myfile]@ so that if the @myfile@ variable contains spaces they are properly escaped.+--+-- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being+-- unable to deduce 'CmdResult'. To avoid this error, bind the result to @()@, or include a type signature.+cmd :: CmdArguments args => args :-> Action r+cmd = cmdArguments []++class CmdArguments t where cmdArguments :: [Either CmdOption String] -> t+instance (Arg a, CmdArguments r) => CmdArguments (a -> r) where+ cmdArguments xs x = cmdArguments $ xs ++ arg x+instance CmdResult r => CmdArguments (Action r) where+ cmdArguments x = case partitionEithers x of+ (opts, x:xs) -> let (a,b) = cmdResult in fmap b $ commandExplicit "cmd" opts a x xs+ _ -> error "Error, no executable or arguments given to Development.Shake.cmd"++class Arg a where arg :: a -> [Either CmdOption String]+instance Arg String where arg = map Right . words+instance Arg [String] where arg = map Right+instance Arg CmdOption where arg = return . Left+instance Arg [CmdOption] where arg = map Left
Development/Shake/Core.hs view
@@ -34,6 +34,7 @@ import Data.Monoid import Data.IORef import System.Directory+import System.IO import Development.Shake.Classes import Development.Shake.Pool@@ -214,7 +215,7 @@ ,traces :: [Trace] -- in reverse } --- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'need' to execute files.+-- | 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'. newtype Action a = Action (StateT SAction IO a) deriving (Monad, MonadIO, Functor, Applicative)@@ -239,7 +240,7 @@ -- | Internal main function (not exported publicly) run :: ShakeOptions -> Rules () -> IO ()-run opts@ShakeOptions{..} rs = do+run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do start <- startTime rs <- getRules rs registerWitnesses rs@@ -278,7 +279,7 @@ flip finally (writeIORef running False) $ do withDatabase opts diagnostic $ \database -> do forkIO $ shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}- runPool shakeDeterministic shakeThreads $ \pool -> do+ runPool (shakeDeterministic || shakeThreads == 1) shakeThreads $ \pool -> do let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 [] mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs) when shakeLint $ do@@ -294,6 +295,15 @@ sequence_ . reverse =<< readIORef after +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++ abbreviate :: [(String,String)] -> String -> String abbreviate [] = id abbreviate abbrev = f@@ -382,7 +392,7 @@ let s2 = s{depends=[], stack=stack, discount=0, traces=[]} lint s "before building" (dur,(res,s2)) <- duration $ runAction s2 $ do- putLoud $ "# " ++ show k+ putWhen Chatty $ "# " ++ show k runExecute (ruleinfo s) k lint s "after building" let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2)@@ -409,7 +419,7 @@ traced msg act = do s <- Action State.get start <- liftIO $ timestamp s- putNormal $ "# " ++ topStack (stack s) ++ " " ++ msg+ putNormal $ "# " ++ msg ++ " " ++ topStack (stack s) res <- liftIO act stop <- liftIO $ timestamp s Action $ State.modify $ \s -> s{traces = (pack msg,start,stop):traces s}
Development/Shake/Database.hs view
@@ -383,10 +383,12 @@ resultsOnly mp = Map.map (\(k, v) -> (k, let Just r = getResult v in r{depends = map (filter (isJust . flip Map.lookup keep)) $ depends r})) keep where keep = Map.filter (isJust . getResult . snd) mp +removeStep :: Map Id (Key, Result) -> Map Id (Key, Result)+removeStep = Map.filter (\(k,_) -> k /= stepKey) showJSON :: Database -> IO String showJSON Database{..} = do- status <- fmap resultsOnly $ readIORef status+ 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..]
Development/Shake/Derived.hs view
@@ -16,6 +16,7 @@ import Development.Shake.Core import Development.Shake.File import Development.Shake.FilePath+import Development.Shake.Types checkExitCode :: String -> ExitCode -> Action ()@@ -28,8 +29,9 @@ system' path args = do let path2 = toNative path let cmd = unwords $ path2 : args+ v <- getVerbosity putLoud cmd- res <- traced (takeBaseName path) $ rawSystem path2 args+ res <- (if v >= Loud then quietly else id) $ traced (takeBaseName path) $ rawSystem path2 args checkExitCode cmd res @@ -37,7 +39,9 @@ -- This function will raise an error if the exit code is non-zero. -- Before running 'systemCwd' make sure you 'need' any required files. ----- > systemCwd "/usr/MyDirectory" "pwd" []+-- @+-- 'systemCwd' \"\/usr\/MyDirectory\" \"pwd\" []+-- @ systemCwd :: FilePath -> FilePath -> [String] -> Action () systemCwd cwd path args = do let path2 = toNative path@@ -64,7 +68,7 @@ return (stdout, stderr) --- | @copyFile old new@ copies the existing file from @old@ to @new@. The @old@ file is has 'need' called on it+-- | @copyFile' old new@ copies the existing file from @old@ to @new@. The @old@ file is has 'need' called on it -- before copying the file. copyFile' :: FilePath -> FilePath -> Action () copyFile' old new = need [old] >> liftIO (copyFile old new)
Development/Shake/Directory.hs view
@@ -208,11 +208,11 @@ f (dir2,False) = do xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- flip filterM xs $ \x -> if not $ test x then return False else IO.doesFileExist $ dir </> x+ flip filterM xs $ \x -> if not $ test x then return False else fmap not $ IO.doesDirectoryExist $ dir </> x f (dir2,True) = do xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- (files,dirs) <- partitionM (\x -> IO.doesFileExist $ dir </> x) xs+ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs rest <- concatMapM (\d -> f (d, True)) dirs return $ filter test files ++ rest @@ -230,12 +230,12 @@ -- Some examples: -- -- @--- 'removeFiles' \"output\" [\"\/\/*\"]--- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"]+-- 'removeFiles' \"output\" [\"\/\/*\"]+-- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"] -- @ ----- This function is often useful when writing a \'clean\' function for your build system,--- often as the first argument to 'shakeWithArgs'.+-- This function is often useful when writing a @clean@ action for your build system,+-- often as a 'phony' rule. removeFiles :: FilePath -> [FilePattern] -> IO () removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir -- optimisation removeFiles dir pat = f "" >> return ()@@ -246,7 +246,7 @@ f :: FilePath -> IO Bool f dir2 = do xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- (files,dirs) <- partitionM (\x -> IO.doesFileExist $ dir </> x) xs+ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs noDirs <- fmap and $ mapM f dirs let (del,keep) = partition test files mapM_ IO.removeFile del
Development/Shake/File.hs view
@@ -103,7 +103,7 @@ -- \"//*.rot13\" '*>' \\out -> do -- let src = 'Development.Shake.FilePath.dropExtension' out -- 'need' [src]--- 'Development.Shake.system'' [\"rot13\",src,\"-o\",out]+-- 'Development.Shake.system'' \"rot13\" [src,\"-o\",out] -- @ need :: [FilePath] -> Action () need xs = (apply $ map (FileQ . pack) xs :: Action [FileA]) >> return ()@@ -130,7 +130,7 @@ -- | Declare a phony action, this is an action that does not produce a file, and will be rerun--- in every execution that requires it. You can demand 'phony' rules using 'want'/'need'.+-- in every execution that requires it. You can demand 'phony' rules using 'want' \/ 'need'. phony :: String -> Action () -> Rules () phony name act = rule $ \(FileQ x_) -> let x = unpack x_ in if name /= x then Nothing else Just $ do@@ -145,7 +145,7 @@ -- @ -- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do -- let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out--- 'Development.Shake.writeFile'' . map toUpper =<< 'Development.Shake.readFile'' src+-- 'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src -- @ (?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules () (?>) = root "with ?>"@@ -162,7 +162,7 @@ -- \"*.asm.o\" '*>' \\out -> do -- let src = 'Development.Shake.FilePath.dropExtension' out -- 'need' [src]--- 'Development.Shake.system'' [\"as\",src,\"-o\",out]+-- 'Development.Shake.system'' \"as\" [src,\"-o\",out] -- @ -- -- To define a build system for multiple compiled languages, we recommend using @.asm.o@,@@ -205,7 +205,7 @@ -- digits \<- 'newCache' $ \\file -> do -- src \<- readFile file -- return $ length $ filter isDigit src--- \"*.digits\" '*>' \\x ->+-- \"*.digits\" '*>' \\x -> do -- v1 \<- digits ('dropExtension' x) -- v2 \<- digits ('dropExtension' x) -- 'Development.Shake.writeFile'' x $ show (v1,v2)
Development/Shake/Files.hs view
@@ -67,9 +67,7 @@ -- return the list of files that will be produced. This list /must/ include the file passed as an argument and should -- obey the invariant: ----- @---test x == Just ys ==> x \`elem\` ys && all ((== Just ys) . test) ys--- @+-- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys -- -- As an example of a function satisfying the invariaint: --
Development/Shake/Locks.hs view
@@ -97,11 +97,11 @@ -- @ -- disk <- 'Development.Shake.newResource' \"Disk\" 4 -- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]--- \"*.exe\" 'Development.Shake.*>' \\out ->--- 'Development.Shake.withResource' disk 1 $--- 'Development.Shake.system'' \"ld\" [\"-o\",out,...]--- \"*.o\" 'Development.Shake.*>' \\out ->--- 'Development.Shake.system'' \"cl\" [\"-o\",out,...]+-- \"*.exe\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.withResource' disk 1 $+-- 'Development.Shake.system'' \"ld\" [\"-o\",out,...]+-- \"*.o\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.system'' \"cl\" [\"-o\",out,...] -- @ data Resource = Resource String Int (Var (Int,[(Int,IO ())])) instance Show Resource where show (Resource name _ _) = "Resource " ++ name
Development/Shake/Oracle.hs view
@@ -38,7 +38,9 @@ -- -- @ -- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--- 'addOracle' $ \\(GhcVersion _) -> fmap (last . words . fst) $ 'Development.Shake.systemOutput' \"ghc\" [\"--version\"]+-- rules = do+-- 'addOracle' $ \\(GhcVersion _) -> fmap (last . words . fst) $ 'Development.Shake.systemOutput' \"ghc\" [\"--version\"]+-- ... rules ... -- @ -- -- If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.@@ -62,18 +64,22 @@ --newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) --newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData) -----do+--rules = do -- getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do -- (out,_) <- 'Development.Shake.systemOutput' \"ghc-pkg\" [\"list\",\"--simple-output\"] -- return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x] -- -- -- getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do--- pkgs <- getPkgList+-- pkgs <- getPkgList $ GhcPkgList () -- return $ lookup pkg pkgs+-- --+-- \"myrule\" *> \\_ -> do+-- getPkgVersion $ GhcPkgVersion \"shake\"+-- ... rule using the shake version ... -- @ -- -- Using these definitions, any rule depending on the version of @shake@--- should call @getPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.+-- should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded. addOracle :: ( #if __GLASGOW_HASKELL__ >= 704 ShakeValue q, ShakeValue a
Development/Shake/Progress.hs view
@@ -4,10 +4,12 @@ module Development.Shake.Progress( Progress(..), progressSimple, progressDisplay, progressTitlebar,+ progressDisplayTester -- INTERNAL FOR TESTING ONLY ) where import Control.Concurrent import Control.Exception+import Control.Monad import System.Environment import Data.Data import Data.Monoid@@ -78,8 +80,8 @@ -- This function polls the progress information every /n/ seconds, produces a status -- message and displays it using the display function. ----- Typical status messages will take the form of @1:25m (15%)@, indicating that the build--- is predicted to complete in 1min 25sec, and 15% of the necessary build time has elapsed.+-- Typical status messages will take the form of @1m25s (15%)@, indicating that the build+-- is predicted to complete in 1 minute 25 seconds (85 seconds total), and 15% of the necessary build time has elapsed. -- This function uses past observations to predict future behaviour, and as such, is only -- guessing. The time is likely to go up as well as down, and will be less accurate from a -- clean build (as the system has fewer past observations).@@ -87,34 +89,75 @@ -- The current implementation is to predict the time remaining (based on 'timeTodo') and the -- work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@, -- while time left is calculated by scaling @remaining@ by the observed work rate in this build,--- namely @done / time_elapsed@.+-- roughly @done / time_elapsed@. progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()-progressDisplay sample disp prog = loop 0+progressDisplay = progressDisplayer True+++-- | Version of 'progressDisplay' that omits the sleep+progressDisplayTester :: Double -> (String -> IO ()) -> IO Progress -> IO ()+progressDisplayTester = progressDisplayer False+++progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO ()+progressDisplayer sleep sample disp prog = do+ disp "Starting..." -- no useful info at this stage+ loop $ tick0 sample where- loop steps = do+ loop :: Tick -> IO ()+ loop t = do+ when sleep $ threadDelay $ ceiling $ sample * 1000000 p <- prog if not $ isRunning p then disp "Finished" else do- disp $ if steps == 0- then "Starting..."- else let done = progressDone p- todo = progressTodo p- comp = if done == 0 then todo else sample * todo / (done / fromIntegral steps)- (mins,secs) = divMod (ceiling comp) (60 :: Int)- time = (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs- perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int)- in time ++ "s (" ++ perc ++ "%)"- threadDelay $ ceiling $ sample * 1000000- loop $! steps+1+ (t, msg) <- return $ tick p t+ disp msg+ loop $! t +-- work_ and done_ are both as recorded at step_+data Tick = Tick+ {sample :: {-# UNPACK #-} !Double+ ,step :: {-# UNPACK #-} !Double+ ,work_ :: {-# UNPACK #-} !Double+ ,done_ :: {-# UNPACK #-} !Double+ ,step_ :: {-# UNPACK #-} !Double+ } deriving Show++tick0 :: Double -> Tick+tick0 sample = Tick sample 0 0 0 0++-- How much additional weight to give to the latest work values+factor :: Double+factor = 1.2++tick :: Progress -> Tick -> (Tick, String)+tick p tickOld@Tick{..}+ | done == 0 = (tick, display 1) -- no scaling, or we'd divide by zero+ | done == done_ = (tick, display work_) -- use the last work rate+ | otherwise = (tick{work_=newWork, done_=done, step_=step'}, display newWork)+ where+ step' = step+sample+ tick = tickOld{step=step'}+ done = progressDone p+ todo = progressTodo p++ newWork = ((step_ * work_) + ((done - done_) * factor)) /+ ((step_ + ((step' - step_) * factor)))++ display work = time ++ "s (" ++ perc ++ "%)"+ where guess = todo / work+ (mins,secs) = divMod (ceiling guess) (60 :: Int)+ time = (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs+ perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int)++ {-# NOINLINE xterm #-} xterm :: Bool xterm = System.IO.Unsafe.unsafePerformIO $ Control.Exception.catch (fmap (== "xterm") $ getEnv "TERM") $ \(e :: SomeException) -> return False- -- | Set the title of the current console window to the given text. If the
Development/Shake/Report.hs view
@@ -4,9 +4,9 @@ import Control.Monad import Data.Char-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@@ -14,10 +14,10 @@ buildReport :: String -> FilePath -> IO () buildReport json out = do htmlDir <- getDataFileName "html"- report <- readFile $ htmlDir </> "report.html"- let f name | name == "data.js" = return $ "var shake = \n" ++ json- | otherwise = readFile $ htmlDir </> name- writeFile out =<< runTemplate f report+ 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 -- | Template Engine. Perform the following replacements on a line basis:@@ -25,12 +25,20 @@ -- * <script src="foo"></script> ==> <script>[[foo]]</script> -- -- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>-runTemplate :: Monad m => (String -> m String) -> String -> m String-runTemplate ask = liftM unlines . mapM f . lines+runTemplate :: Monad m => (FilePath -> m LBS.ByteString) -> LBS.ByteString -> m LBS.ByteString+runTemplate ask = liftM LBS.unlines . mapM f . LBS.lines where- f x | Just file <- stripPrefix "<script src=\"" y = do res <- grab file; return $ "<script>\n" ++ res ++ "\n</script>"- | Just file <- stripPrefix "<link href=\"" y = do res <- grab file; return $ "<style type=\"text/css\">\n" ++ res ++ "\n</style>"+ link = LBS.pack "<link href=\""+ script = LBS.pack "<script src=\""++ f x | Just file <- lbs_stripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+ | Just file <- lbs_stripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>" | otherwise = return x where- y = dropWhile isSpace x- grab = ask . takeWhile (/= '\"')+ y = LBS.dropWhile isSpace x+ grab = ask . takeWhile (/= '\"') . LBS.unpack+++lbs_stripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString+lbs_stripPrefix prefix text = if a == prefix then Just b else Nothing+ where (a,b) = LBS.splitAt (LBS.length prefix) text
Development/Shake/Shake.hs view
@@ -14,7 +14,7 @@ -- Use 'ShakeOptions' to specify how the system runs, and 'Rules' to specify what to build. The function will throw -- an exception if the build fails. ----- To use command line flags to modify 'ShakeOptions' see 'Development.Shake.shakeWithArgs'.+-- To use command line flags to modify 'ShakeOptions' see 'Development.Shake.shakeArgs'. shake :: ShakeOptions -> Rules () -> IO () shake opts r = do run opts $ do
Development/Shake/Storage.hs view
@@ -158,7 +158,6 @@ continue h mp = do when (Map.null mp) $ reset h mp -- might as well, no data to lose, and need to ensure a good witness table- lock <- newLock flushThread outputErr shakeFlush h $ \out -> act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v) @@ -170,6 +169,7 @@ alive <- newVar True kick <- newEmptyMVar + lock <- newLock case flush of Nothing -> return () Just flush -> do@@ -180,7 +180,7 @@ b <- withVar alive $ \b -> do when b $ do tryTakeMVar kick- hFlush h+ withLock lock $ hFlush h return b when b loop forkIO $ do@@ -188,14 +188,13 @@ (loop >> return ()) `E.catch` \(e :: SomeException) -> outputErr $ msg ++ show e ++ "\n" return () - lock <- newLock (act $ \s -> do withLock lock $ LBS.hPut h s tryPutMVar kick () return ()) `finally` do- tryPutMVar kick () modifyVar_ alive $ const $ return False+ tryPutMVar kick () -- Return the amount of junk at the end, along with all the chunk
Development/Shake/Sys.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} --- | This module provides versions of the 'Development.Shake.Derived.system'' family of functions+-- | /Warning: I intend to remove this module. Please use "Development.Shake.Command" instead./+--+-- 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.
Development/Shake/Types.hs view
@@ -84,6 +84,8 @@ ,shakeStorageLog :: Bool -- ^ Defaults to 'False'. Write a message to @'shakeFiles'.storage@ whenever a storage event happens which may impact -- on the current stored progress. Examples include database version number changes, database compaction or corrupt files.+ ,shakeLineBuffering :: Bool+ -- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake. ,shakeProgress :: IO Progress -> IO () -- ^ Defaults to no action. A function called on a separate thread when the build starts, allowing progress to be reported. -- For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced@@ -97,21 +99,21 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False False (Just 10) Nothing [] False (const $ return ())+shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False False (Just 10) Nothing [] False True (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS fieldsShakeOptions = ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"- ,"shakeProgress","shakeOutput"]+ ,"shakeLineBuffering","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 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 (fromFunction x13) (fromFunction x14)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 (fromFunction x14) (fromFunction x15) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14) =- 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` Function x13 `k` Function x14- gunfold k z c = 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) =+ z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` Function x14 `k` Function x15+ gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions @@ -151,10 +153,11 @@ -- | The verbosity data type, used by 'shakeVerbosity'. data Verbosity = Silent -- ^ Don't print any messages.- | Quiet -- ^ Only print essential messages (typically errors).- | Normal -- ^ Print normal messages (typically errors and warnings).- | Loud -- ^ Print lots of messages (typically errors, warnings and status updates).- | Diagnostic -- ^ Print messages for virtually everything (for debugging a build system).+ | Quiet -- ^ Only print essential messages, typically errors.+ | Normal -- ^ Print errors and @# /command-name/ /file-name/@ when running a 'Development.Shake.traced' command.+ | Loud -- ^ Print errors and full command lines when running a 'Development.Shake.system'' 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)
Examples/C/Main.hs view
@@ -3,7 +3,7 @@ import Development.Shake import Development.Shake.FilePath-import Development.Shake.Sys+import Development.Shake.Command import Examples.Util main = shaken noTest $ \args obj -> do@@ -14,16 +14,16 @@ cs <- getDirectoryFiles src ["*.c"] let os = map (obj . (<.> "o")) cs need os- sys "gcc -o" [out] os+ cmd "gcc -o" [out] os obj "*.c.o" *> \out -> do let c = src </> takeBaseName out need [c] headers <- cIncludes c need $ map ((</>) src . takeFileName) headers- sys "gcc -o" [out] "-c" [c]+ cmd "gcc -o" [out] "-c" [c] cIncludes :: FilePath -> Action [FilePath] cIncludes x = do- (stdout,_) <- systemOutput "gcc" ["-MM",x]+ Stdout stdout <- cmd "gcc" ["-MM",x] return $ drop 2 $ words stdout
+ Examples/MakeTutor/Makefile view
@@ -0,0 +1,17 @@+# From http://www.cs.colby.edu/maxwell/courses/tutorials/maketutor/, Makefile 4++CC=gcc+CFLAGS=-I.+DEPS = hellomake.h+OBJ = hellomake.o hellofunc.o ++hellomake$(EXE): $(OBJ)+ $(CC) -o $@ $^ $(CFLAGS)++%.o: %.c $(DEPS)+ $(CC) -c -o $@ $< $(CFLAGS)++.PHONY: clean+clean:+ rm hellomake$(EXE)+ rm *.o
+ Examples/MakeTutor/hellofunc.c view
@@ -0,0 +1,9 @@+#include <stdio.h>+#include <hellomake.h>++void myPrintHelloMake(void) {++ printf("Hello makefiles!\n");++ return;+}
+ Examples/MakeTutor/hellomake.c view
@@ -0,0 +1,8 @@+#include <hellomake.h>++int main() {+ // call a function in another file+ myPrintHelloMake();++ return(0);+}
+ Examples/MakeTutor/hellomake.h view
@@ -0,0 +1,5 @@+/*+example include file+*/++void myPrintHelloMake(void);
Examples/Self/Main.hs view
@@ -4,6 +4,7 @@ import Development.Shake import Development.Shake.Classes+import Development.Shake.Command import Development.Shake.FilePath import Examples.Util @@ -25,7 +26,7 @@ let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x ghcPkg <- addOracle $ \GhcPkg{} -> do- (out,_) <- quietly $ systemOutput "ghc-pkg" ["list","--simple-output"]+ Stdout out <- quietly $ cmd "ghc-pkg list --simple-output" return $ words out ghcFlags <- addOracle $ \GhcFlags{} -> do@@ -36,7 +37,7 @@ -- since ghc-pkg includes the ghc package, it changes if the version does ghcPkg $ GhcPkg () flags <- ghcFlags $ GhcFlags ()- system' "ghc" $ args ++ flags+ cmd "ghc" flags args obj "/*.exe" *> \out -> do src <- readFileLines $ replaceExtension out "deps"
+ Examples/Test/Command.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Examples.Test.Command(main) where++import Control.Exception hiding (assert)+import Control.Monad+import Data.List+import Development.Shake+import Development.Shake.Command+import Examples.Util+++main = shaken test $ \args obj -> do+ want $ map obj args++ let a !> b = obj a *> \out -> do alwaysRerun; res <- b; writeFile' out res++ "ghc-version" !> do+ Stdout stdout <- cmd "ghc --version"+ return stdout++ "ghc-random" !> do+ (Stderr stderr, Exit _) <- cmd "ghc --random"+ return stderr++ "ghc-random2" !> do+ () <- cmd (EchoStderr False) "ghc --random"+ return ""++ "pwd" !> do+ writeFileLines (obj "pwd space.hs") ["import System.Directory","main = putStrLn =<< getCurrentDirectory"]+ Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"]+ return out++ "env" !> do+ (Exit _, Stdout out1) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo %FOO%"+ (Exit _, Stdout out2) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo $FOO"+ return $ unlines [out1, out2]+++test build obj = do+ let crash args parts = do+ res <- try $ build $ "--quiet" : args+ case res of+ Left (err :: SomeException) -> let s = show err in forM_ parts $ \p ->+ assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p+ Right _ -> error "Expected an exception but succeeded"++ build ["ghc-version"]+ assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System"++ build ["ghc-random"]+ assertContentsInfix (obj "ghc-random") "unrecognised flags: --random"++ crash ["ghc-random2"] ["unrecognised flags: --random"]++ build ["pwd"]+ assertContentsInfix (obj "pwd") "command"++ build ["env"]+ assertContentsInfix (obj "env") "HELLO SHAKE"
+ Examples/Test/Docs.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE PatternGuards #-}++module Examples.Test.Docs(main) where++import Development.Shake+import Development.Shake.FilePath+import Examples.Util+import Data.Char+import Data.List+import Data.Maybe+++reps from to = map (\x -> if x == from then to else x)++main = shaken noTest $ \args obj -> do+ let index = "dist/doc/html/shake/index.html"+ want [obj "Success.txt"]++ want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args++ index *> \_ -> do+ xs <- getDirectoryFiles "Development" ["//*.hs"]+ need $ map ("Development" </>) xs+ system' "cabal" ["haddock"]++ obj "Paths_shake.hs" *> \out -> do+ copyFile' "Paths.hs" out++ obj "Part_*.hs" *> \out -> do+ need ["Examples/Test/Docs.hs"] -- so much of the generator is in this module+ src <- readFile' $ "dist/doc/html/shake/" ++ reps '_' '-' (drop 5 $ takeBaseName out) ++ ".html"+ let f i (Stmt x) = restmt i $ map undefDots x+ f i (Expr x) | x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x]+ | otherwise = ["expr_" ++ show i ++ " = (" ++ undefDots x2 ++ ")" | let x2 = trim $ dropComment x, not $ whitelist x2]+ code = concat $ zipWith f [1..] (nub $ findCode src)+ (imports,rest) = partition ("import " `isPrefixOf`) code+ writeFileLines out $+ ["{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}"+ ,"module " ++ takeBaseName out ++ "() where"+ ,"import Control.Concurrent"+ ,"import Data.Char"+ ,"import Data.Data"+ ,"import Data.List"+ ,"import Data.Monoid"+ ,"import Development.Shake"+ ,"import Development.Shake.Classes"+ ,"import System.Console.GetOpt"+ ,"import System.Exit"+ ,"import System.IO"+ ,"import " ++ reps '_' '.' (drop 5 $ takeBaseName out)+ ] +++ imports +++ ["(==>) :: Bool -> Bool -> Bool"+ ,"(==>) = undefined"+ ,"infix 1 ==>"+ ,"forAll f = f undefined"+ ,"remaining = 1.1"+ ,"done = 1.1"+ ,"time_elapsed = 1.1"+ ,"old = \"\""+ ,"new = \"\""+ ,"myfile = \"\""+ ,"opts = shakeOptions"+ ,"result = undefined :: IO (Maybe (Rules ()))"+ ,"instance Eq (OptDescr a)"+ ,"inputs = [\"\"]"+ ,"output = \"\""+ ] +++ rest++ obj "Main.hs" *> \out -> do+ need [index,obj "Paths_shake.hs"]+ files <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]+ files <- return $ filter (not . isSuffixOf "-Classes.html") files+ let mods = map ((++) "Part_" . reps '-' '_' . takeBaseName) files+ need [obj m <.> "hs" | m <- mods]+ writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"]++ obj "Success.txt" *> \out -> do+ need [obj "Main.hs"]+ system' "runhaskell" ["-hide-package=hashmap","-i" ++ obj "",obj "Main.hs"]+ writeFile' out ""+++data Code = Stmt [String] | Expr String deriving (Show,Eq)++findCode :: String -> [Code]+findCode x | Just x <- stripPrefix "<pre>" x = f (Stmt . shift . lines . strip) "</pre>" x+ | Just x <- stripPrefix "<code>" x = f (Expr . strip) "</code>" x+ where+ f ctor end x | Just x <- stripPrefix end x = ctor "" : findCode x+ f ctor end (x:xs) = f (ctor . (x:)) end xs+findCode (x:xs) = findCode xs+findCode [] = []++trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++restmt i ("":xs) = restmt i xs+restmt i (x:xs) | " ?== " `isInfixOf` x || " == " `isInfixOf` x =+ zipWith (\j x -> "hack_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] (x:xs)+restmt i (x:xs) | " = " `isInfixOf` x || " | " `isInfixOf` x ||+ "import " `isPrefixOf` x || "infix" `isPrefixOf` x || "instance " `isPrefixOf` x = map f $ x:xs+ where f x = if takeWhile (not . isSpace) x `elem` dupes then "_" ++ show i ++ "_" ++ x else x+restmt i xs = ("stmt_" ++ show i ++ " = do") : map (" " ++) xs+++shift :: [String] -> [String]+shift xs | all null xs = xs+ | all (\x -> null x || " " `isPrefixOf` x) xs = shift $ map (drop 1) xs+ | otherwise = xs+++dropComment ('-':'-':_) = []+dropComment xs = onTail dropComment xs++undefDots ('.':'.':'.':xs) = "undefined" ++ (if "..." `isSuffixOf` xs then "" else undefDots xs)+undefDots xs = onTail undefDots xs++strip :: String -> String+strip ('<':xs) = strip $ drop 1 $ dropWhile (/= '>') xs+strip ('&':xs)+ | Just xs <- stripPrefix "quot;" xs = '\"' : strip xs+ | Just xs <- stripPrefix "lt;" xs = '<' : strip xs+ | Just xs <- stripPrefix "gt;" xs = '>' : strip xs+ | Just xs <- stripPrefix "amp;" xs = '&' : strip xs+strip xs = onTail strip xs++onTail f (x:xs) = x : f xs+onTail f [] = []+++whitelist :: String -> Bool+whitelist x | takeExtension x `elem` words ".txt .hi .o .exe .tar .cpp" = True+whitelist x | elem x $ words $+ "newtype do MyFile.txt.digits excel a q value key gcc make contents tar ghc cabal clean _make distcc ghc " +++ ".. /./ /.. ./ // \\ ../ " +++ "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " +++ ".make/i586-linux-gcc/output _make/.database foo/.. " +++ "-threaded Function extension $OUT $PATH xterm $TERM main opts result flagValues argValues "+ = True+whitelist x = x `elem`+ ["[Foo.hi, Foo.o]"+ ,"main -j6"+ ,"main clean"+ ,"1m25s (15%)"+ ,"getPkgVersion $ GhcPkgVersion \"shake\""+ ,"# command-name file-name"+ ]++types = words $+ "MVar IO Monad Monoid String FilePath Data [String] Eq Typeable Char ExitCode " +++ "Action Resource Assume FilePattern Verbosity Rules Rule CmdOption CmdResult"++dupes = words "main progressSimple rules"
Examples/Test/FilePath.hs view
@@ -15,3 +15,16 @@ normalise "../../foo" === "../../foo" normalise "foo/bar/../../neil" === "neil" normalise "foo/../bar/../neil" === "neil"++ dropDirectory1 "aaa/bbb" === "bbb"+ dropDirectory1 "aaa/" === ""+ dropDirectory1 "aaa" === ""+ dropDirectory1 "" === ""++ takeDirectory1 "aaa/bbb" === "aaa"+ takeDirectory1 "aaa/" === "aaa"+ takeDirectory1 "aaa" === "aaa"++ combine "aaa/bbb" "ccc" === "aaa/bbb/ccc"+ combine "aaa/bbb" "./ccc" === "aaa/bbb/ccc"+ combine "aaa/bbb" "../ccc" === "aaa/ccc"
+ Examples/Test/Makefile.hs view
@@ -0,0 +1,31 @@++module Examples.Test.Makefile(main) where++import Development.Shake(action, liftIO)+import Development.Shake.FilePath+import qualified Development.Make.Main as Makefile+import System.Environment+import System.Directory+import Examples.Util+import Control.Monad+import Data.List+import Data.Maybe+++main = shaken test $ \args obj ->+ action $ liftIO $ do+ withArgs [fromMaybe x $ stripPrefix "@" x | x <- args] Makefile.main+++test build obj = do+ let copyTo from to = do+ xs <- getDirectoryContents from+ createDirectoryIfMissing True (obj to)+ forM_ xs $ \x ->+ when (not $ all (== '.') x) $+ copyFile (from </> x) (obj to </> x)++ copyTo "Examples/MakeTutor" "MakeTutor"+ build ["--directory=" ++ obj "MakeTutor","--no-report"]+ build ["--directory=" ++ obj "MakeTutor","--no-report"]+ build ["--directory=" ++ obj "MakeTutor","@clean","--no-report"]
Examples/Test/Progress.hs view
@@ -16,10 +16,9 @@ progEx :: Double -> [Double] -> IO [Double] progEx mxDone todo = do- let scale = 100 -- Use scale so we can run the test faster let resolution = 10000 -- Use resolution to get extra detail on the numbers let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)- pile <- newIORef $ zipWith (\t d -> mempty{timeBuilt=d,timeTodo=(t*scale*resolution,0)}) todo done+ pile <- newIORef $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done let get = do a <- readIORef pile case a of [] -> return mempty{isRunning=False}@@ -29,7 +28,7 @@ let put x = do let (mins,secs) = break (== 'm') $ takeWhile (/= '(') x let f x = let y = filter isDigit x in if null y then 0/0 else read y modifyIORef out (++ [(if null secs then f mins else f mins * 60 + f secs) / resolution])- progressDisplay (1/scale) put get+ progressDisplayTester resolution put get fmap (take $ length todo) $ readIORef out @@ -43,11 +42,11 @@ let dp3 x = fromIntegral (round $ x * 1000 :: Int) / 1000 map dp3 (drop 2 xs) === [8,7..1] - -- The properties below this line could be weakened+ -- The properties below this line could be weakened -- increasing functions can't match xs <- prog [5,6,7]- last xs === 700 -- because of the scale issues+ last xs === 7 -- the first value must be plausible, or missing xs <- prog [187]@@ -59,3 +58,10 @@ xs <- progEx 1 $ [10,9,100,8,7,6,5,4,3,2,1] assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close" + -- if no progress is made, don't keep the time going up+ xs <- prog [10,9,8,7,7,7,7,7]+ drop 5 xs === [7,7,7]++ -- if the work rate changes, should somewhat reflect that+ xs <- prog [10,9,8,7,6.5,6,5.5,5]+ assert (last xs > 7.1) "Some discounting (factor=0 would give 7)"
Examples/Util.hs view
@@ -90,6 +90,11 @@ got <- readFile file assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got +assertContentsInfix :: FilePath -> String -> IO ()+assertContentsInfix file want = do+ got <- readFile file+ assert (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (anywhere): " ++ want ++ "\nGOT: " ++ got+ noTest :: ([String] -> IO ()) -> (String -> String) -> IO () noTest build obj = do
Main.hs view
@@ -1,93 +1,4 @@-module Main(main) where -import Control.Concurrent-import Control.Exception-import Control.Monad-import Data.List-import Data.Maybe-import System.Environment--import Examples.Util(sleepFileTime)-import qualified Examples.Tar.Main as Tar-import qualified Examples.Self.Main as Self-import qualified Examples.C.Main as C-import qualified Examples.Test.Assume as Assume-import qualified Examples.Test.Basic as Basic-import qualified Examples.Test.Benchmark as Benchmark-import qualified Examples.Test.Cache as Cache-import qualified Examples.Test.Directory as Directory-import qualified Examples.Test.Errors as Errors-import qualified Examples.Test.Files as Files-import qualified Examples.Test.FilePath as FilePath-import qualified Examples.Test.FilePattern as FilePattern-import qualified Examples.Test.Journal as Journal-import qualified Examples.Test.Lint as Lint-import qualified Examples.Test.Oracle as Oracle-import qualified Examples.Test.Pool as Pool-import qualified Examples.Test.Progress as Progress-import qualified Examples.Test.Random as Random-import qualified Examples.Test.Resources as Resources--import qualified Development.Make.Main as Makefile---fakes = ["clean" * clean, "test" * test, "makefile" * makefile]- where (*) = (,)--mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main- ,"basic" * Basic.main, "cache" * Cache.main, "directory" * Directory.main, "errors" * Errors.main- ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main- ,"journal" * Journal.main, "lint" * Lint.main, "pool" * Pool.main, "random" * Random.main- ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main- ,"oracle" * Oracle.main, "progress" * Progress.main]- where (*) = (,)---main :: IO ()-main = do- xs <- getArgs- case flip lookup (fakes ++ mains) =<< listToMaybe xs of- Nothing -> putStrLn $ unlines- ["Welcome to the Shake demo"- ,""- ,unwords $ "Modes:" : map fst fakes- ,unwords $ "Demos:" : map fst mains- ,""- ,"As an example, try:"- ,""- ," main self --threads2 --loud"- ,""- ,"Which will build Shake, using Shake, on 2 threads."]- Just main -> main sleepFileTime---makefile :: IO () -> IO ()-makefile _ = do- args <- getArgs- withArgs (drop 1 args) Makefile.main---clean :: IO () -> IO ()-clean extra = sequence_ [withArgs [name,"clean"] $ main extra | (name,main) <- mains]-+module Main(main) where -test :: IO () -> IO ()-test _ = do- args <- getArgs- one <- newMVar () -- Only one may execute at a time- let pause = do putMVar one (); sleepFileTime; takeMVar one- let tests = filter ((/= "random") . fst) mains- -- priority tests have more pauses in, so doing them sooner gets the whole tests done faster- self <- myThreadId- let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests- (dones,threads) <- fmap unzip $ forM (priority ++ normal) $ \(name,main) -> do- done <- newEmptyMVar- thread <- forkIO $ handleJust (guard . (/=) ThreadKilled) (const $ killThread self) $ do- takeMVar one- withArgs (name:"test":drop 1 args) $ main pause- putMVar one ()- putMVar done ()- return (done, thread)- onException (mapM_ takeMVar dones) $ do- mapM_ killThread threads- putStrLn "TESTS FAILED"+import Development.Make.Main(main)
+ Test.hs view
@@ -0,0 +1,94 @@++module Main(main) where++import Control.Exception+import Control.Monad+import Data.List+import Data.Maybe+import System.Environment+import Development.Shake.Pool++import Examples.Util(sleepFileTime)+import qualified Examples.Tar.Main as Tar+import qualified Examples.Self.Main as Self+import qualified Examples.C.Main as C+import qualified Examples.Test.Assume as Assume+import qualified Examples.Test.Basic as Basic+import qualified Examples.Test.Benchmark as Benchmark+import qualified Examples.Test.Cache as Cache+import qualified Examples.Test.Command as Command+import qualified Examples.Test.Directory as Directory+import qualified Examples.Test.Docs as Docs+import qualified Examples.Test.Errors as Errors+import qualified Examples.Test.Files as Files+import qualified Examples.Test.FilePath as FilePath+import qualified Examples.Test.FilePattern as FilePattern+import qualified Examples.Test.Journal as Journal+import qualified Examples.Test.Lint as Lint+import qualified Examples.Test.Makefile as Makefile+import qualified Examples.Test.Oracle as Oracle+import qualified Examples.Test.Pool as Pool+import qualified Examples.Test.Progress as Progress+import qualified Examples.Test.Random as Random+import qualified Examples.Test.Resources as Resources++import qualified Development.Make.Main as Make+++fakes = ["clean" * clean, "test" * test, "make" * makefile]+ where (*) = (,)++mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main+ ,"basic" * Basic.main, "cache" * Cache.main, "command" * Command.main, "directory" * Directory.main+ ,"docs" * Docs.main, "errors" * Errors.main+ ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main+ ,"journal" * Journal.main, "lint" * Lint.main, "makefile" * Makefile.main+ ,"pool" * Pool.main, "random" * Random.main+ ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main+ ,"oracle" * Oracle.main, "progress" * Progress.main]+ where (*) = (,)+++main :: IO ()+main = do+ xs <- getArgs+ case flip lookup (fakes ++ mains) =<< listToMaybe xs of+ Nothing -> putStrLn $ unlines+ ["Welcome to the Shake demo"+ ,""+ ,unwords $ "Modes:" : map fst fakes+ ,unwords $ "Demos:" : map fst mains+ ,""+ ,"As an example, try:"+ ,""+ ," main self --threads2 --loud"+ ,""+ ,"Which will build Shake, using Shake, on 2 threads."]+ Just main -> main sleepFileTime+++makefile :: IO () -> IO ()+makefile _ = do+ args <- getArgs+ withArgs (drop 1 args) Make.main+++clean :: IO () -> IO ()+clean extra = sequence_ [withArgs [name,"clean"] $ main extra | (name,main) <- mains]+++test :: IO () -> IO ()+test _ = do+ args <- getArgs+ let tests = filter ((/= "random") . fst) mains+ let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests+ flip onException (putStrLn "TESTS FAILED") $+ execute sleepFileTime [\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
html/shake-ui.js view
@@ -218,13 +218,23 @@ data.push([j, x[j]]); ys.push({label:s, values:x, data:data, color:xs[s].back, avg:sum(x) / x.length}); }- ys.sort(function(a,b){return a.avg - b.avg;});- showPlot(ys, {- legend: {show:true, position:"nw"},- series: {stack:true, lines:{lineWidth:0,fill:1}},- yaxis: {min:0},- xaxis: {tickFormatter: function (i){return showTime(shakeSummary.maxTraceStopLast * i / 100);}}- });+ if (ys.length === 0)+ {+ $("#output").html("No data found, " ++ (shakeEx.summary.countTraceLast === 0+ ? "there were no traced commands in the last run."+ : "perhaps your filter is too restrictive?"));+ }+ else+ {+ ys.sort(function(a,b){return a.avg - b.avg;});+ showPlot(ys, {+ legend: {show:true, position:"nw", sorted:"reverse"},+ series: {stack:true, lines:{lineWidth:0,fill:1}},+ yaxis: {min:0},+ xaxis: {tickFormatter: function (i){return showTime(shakeSummary.maxTraceStopLast * i / 100);}}+ });+ } break; case "cmd-table":@@ -238,7 +248,7 @@ case "rule-graph": var xs = ruleGraph(shakeEx, report.query); if (xs.length > 250)- $("#output").html("Cannot view graph with > 250 nodes, try grouping more aggressively");+ $("#output").html("Viewing a graph with > 250 nodes is not supported, and you have " + xs.length + " nodes. Try grouping more aggressively"); else { var res = "digraph \"\"{";
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: shake-version: 0.10.1+version: 0.10.2 license: BSD3 license-file: LICENSE category: Development@@ -43,6 +43,10 @@ Examples/C/constants.c Examples/C/constants.h Examples/C/main.c+ Examples/MakeTutor/Makefile+ Examples/MakeTutor/hellofunc.c+ Examples/MakeTutor/hellomake.c+ Examples/MakeTutor/hellomake.h Examples/Tar/list.txt Paths.hs @@ -76,7 +80,7 @@ hashable >= 1.1.2.3 && < 1.3, binary, filepath,- process,+ process >= 1.1, unordered-containers (>= 0.1.4.3 && < 0.2) || (>= 0.2.1 && < 0.3), bytestring, time,@@ -93,6 +97,7 @@ exposed-modules: Development.Shake Development.Shake.Classes+ Development.Shake.Command Development.Shake.FilePath Development.Shake.Sys @@ -123,8 +128,7 @@ executable shake- main-is: Development/Make/Main.hs- ghc-options: -main-is Development.Make.Main+ main-is: Main.hs build-depends: base == 4.*, old-time,@@ -148,13 +152,14 @@ other-modules: Development.Make.Env+ Development.Make.Main Development.Make.Parse Development.Make.Rules Development.Make.Type executable shake-test- main-is: Main.hs+ main-is: Test.hs if flag(testprog) buildable: True else@@ -194,13 +199,16 @@ Examples.Test.Basic Examples.Test.Benchmark Examples.Test.Cache+ Examples.Test.Command Examples.Test.Directory+ Examples.Test.Docs Examples.Test.Errors Examples.Test.FilePath Examples.Test.FilePattern Examples.Test.Files Examples.Test.Journal Examples.Test.Lint+ Examples.Test.Makefile Examples.Test.Oracle Examples.Test.Pool Examples.Test.Progress