module Development.Shake.Args(shakeOptDescrs, shakeArgs, shakeArgsWith) where
import Paths_shake
import Development.Shake.Types
import Development.Shake.Core
import Development.Shake.Rules.File
import Development.Shake.FilePath
import Development.Shake.Progress
import Development.Shake.Shake
import General.Timing
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Data.Time
import Data.Version(showVersion)
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
shakeArgs :: ShakeOptions -> Rules () -> IO ()
shakeArgs opts rules = shakeArgsWith opts [] f
where f _ files = return $ Just $ if null files then rules else want (map normalise files) >> withoutActions rules
shakeArgsWith :: ShakeOptions -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO ()
shakeArgsWith baseOpts userOptions rules = do
addTiming "shakeArgsWith"
args <- getArgs
let (flags,files,errs) = getOpt Permute opts args
(flagsError,flag1) = partitionEithers flags
(self,user) = partitionEithers flag1
(flagsExtra,flagsShake) = first concat $ unzip self
assumeNew = [x | AssumeNew x <- flagsExtra]
assumeOld = [x | AssumeOld x <- flagsExtra]
changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]
printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]
shakeOpts = foldl' (flip ($)) baseOpts flagsShake
errs <- return $ errs ++ flagsError ++ ["cannot mix " ++ a ++ " and " ++ b | a:b:_ <-
[["`--assume-new'" | assumeNew/=[] ] ++ ["`--assume-old'" | assumeOld/=[] ] ++ ["explicit targets" | files/=[]]]]
when (errs /= []) $ do
putStr $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs
showHelp
exitFailure
if Help `elem` flagsExtra then do
showHelp
else if Version `elem` flagsExtra then
putStrLn $ "Shake build system, version " ++ showVersion version
else do
when (Sleep `elem` flagsExtra) $ threadDelay 1000000
start <- getCurrentTime
curdir <- getCurrentDirectory
let redir = case changeDirectory of
Nothing -> id
Just d -> bracket_ (getDataFileName "html" >> setCurrentDirectory d) (setCurrentDirectory curdir)
(ran,res) <- redir $ do
when printDirectory $ putStrLn $ "shake: In directory `" ++ curdir ++ "'"
rules <- rules user files
case rules of
Nothing -> return (False,Right ())
Just rules -> do
res <- try $ shake shakeOpts $
if NoBuild `elem` flagsExtra then withoutActions rules else rules
return (True, res)
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
in case res of
Left err ->
if Exception `elem` flagsExtra then
throw err
else do
putStrLn $ esc "31" $ show (err :: SomeException)
exitFailure
Right () -> do
stop <- getCurrentTime
let tot = diffUTCTime stop start
(mins,secs) = divMod (ceiling tot) (60 :: Int)
time = show mins ++ ":" ++ ['0' | secs < 10] ++ show secs
putStrLn $ esc "32" $ "Build completed in " ++ time ++ "m"
where
opts = map (wrap Left . snd) shakeOptsEx ++ map (wrap Right) userOptions
showHelp = putStr $ unlines $ "Usage: shake [options] [target] ..." : "Options:" : showOptDescr opts
wrap :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)
wrap f = fmapOptDescr (either Left (Right . f))
showOptDescr :: [OptDescr a] -> [String]
showOptDescr xs = concat
[ if nargs <= 26 then [" " ++ args ++ replicate (28 nargs) ' ' ++ desc]
else [" " ++ args, replicate 30 ' ' ++ desc]
| Option s l arg desc <- xs
, let args = intercalate ", " $ map (short arg) s ++ map (long arg) l
, let nargs = length args]
where short NoArg{} x = "-" ++ [x]
short (ReqArg _ b) x = "-" ++ [x] ++ " " ++ b
short (OptArg _ b) x = "-" ++ [x] ++ "[=" ++ b ++ "]"
long NoArg{} x = "--" ++ x
long (ReqArg _ b) x = "--" ++ x ++ "=" ++ b
long (OptArg _ b) x = "--" ++ x ++ "[=" ++ b ++ "]"
fmapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b
fmapOptDescr f (Option a b c d) = Option a b (g c) d
where g (NoArg a) = NoArg $ f a
g (ReqArg a b) = ReqArg (f . a) b
g (OptArg a b) = OptArg (f . a) b
shakeOptDescrs :: [OptDescr (Either String (ShakeOptions -> ShakeOptions))]
shakeOptDescrs = [fmapOptDescr (either Left (Right . snd)) o | (True, o) <- shakeOptsEx]
data Extra = ChangeDirectory FilePath
| Version
| AssumeNew FilePath
| AssumeOld FilePath
| PrintDirectory Bool
| Color
| Help
| Sleep
| NoTime
| Exception
| NoBuild
deriving Eq
unescape :: String -> String
unescape ('\ESC':'[':xs) = unescape $ drop 1 $ dropWhile (not . isAlpha) xs
unescape (x:xs) = x : unescape xs
unescape [] = []
escape :: String -> String -> String
escape code x = "\ESC[" ++ code ++ "m" ++ x ++ "\ESC[0m"
shakeOptsEx :: [(Bool, OptDescr (Either String ([Extra], ShakeOptions -> ShakeOptions)))]
shakeOptsEx =
[yes $ Option "a" ["abbrev"] (pairArg "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages."
,yes $ Option "B" ["always-make"] (noArg $ \s -> s{shakeAssume=Just AssumeDirty}) "Unconditionally make all targets."
,no $ Option "" ["no-build"] (NoArg $ Right ([NoBuild], id)) "Don't build anything."
,no $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything."
,yes $ Option "" ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output."
,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."
,no $ Option "" ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."
,yes $ Option "" ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."
,yes $ Option "" ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."
,no $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."
,yes $ Option "j" ["jobs"] (intArg 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 "" ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."
,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."
,no $ Option "o" ["old-file","assume-old"] (ReqArg (\x -> Right ([AssumeOld x],id)) "FILE") "Consider FILE to be very old and don't remake it."
,yes $ Option "" ["old-all"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Don't remake any files."
,yes $ Option "" ["assume-skip"] (noArg $ \s -> s{shakeAssume=Just AssumeSkip}) "Don't remake any files this run."
,yes $ Option "" ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."
,yes $ Option "r" ["report"] (OptArg (\x -> Right ([], \s -> s{shakeReport=Just $ fromMaybe "report.html" x})) "FILE") "Write out profiling information [to report.html]."
,yes $ Option "" ["no-report"] (noArg $ \s -> s{shakeReport=Nothing}) "Turn off --report."
,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."
,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."
,no $ Option "" ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."
,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."
,yes $ Option "" ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."
,yes $ Option "p" ["progress"] (optIntArg 1 "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "Show progress messages [every N seconds, default 5]."
,yes $ Option "" ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."
,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."
,no $ Option "" ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."
,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 "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."
,no $ Option "W" ["what-if","new-file","assume-new"] (ReqArg (\x -> Right ([AssumeNew x],id)) "FILE") "Consider FILE to be infinitely new."
]
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
intArg mn flag a f = flip ReqArg a $ \x -> case reads x of
[(i,"")] | i >= mn -> Right ([],f i)
_ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"
optIntArg mn flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of
[(i,"")] | i >= mn -> Right ([],f $ Just i)
_ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"
pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of
(a,'=':b) -> Right ([],f (a,b))
_ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"
outputDebug output Nothing = output
outputDebug output (Just file) = \v msg -> do
when (v /= Diagnostic) $ output v msg
appendFile file $ unescape msg
outputColor output v msg = output v $ escape "34" msg
prog i p = do
program <- progressProgram
progressDisplay i (\s -> progressTitlebar s >> program s) p