module Development.Shake.Args(shakeOptDescrs, shakeArgs, shakeArgsWith) where
import Paths_shake
import Development.Shake.Types
import Development.Shake.Core
import Development.Shake.Demo
import Development.Shake.Rules.File
import Development.Shake.Progress
import Development.Shake.Shake
import General.Timing
import Data.Tuple.Extra
import Control.Concurrent
import Control.Exception.Extra
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
import System.Time.Extra
shakeArgs :: ShakeOptions -> Rules () -> IO ()
shakeArgs opts rules = shakeArgsWith opts [] f
where f _ files = return $ Just $ if null files then rules else want 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]
progressReplays = [x | ProgressReplay x <- flagsExtra]
progressRecords = [x | ProgressRecord 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 if NumericVersion `elem` flagsExtra then
putStrLn $ showVersion version
else if Demo `elem` flagsExtra then
demo $ shakeStaunch shakeOpts
else if not $ null progressReplays then do
dat <- forM progressReplays $ \file -> do
src <- readFile file
return (file, map read $ lines src)
forM_ (if null $ shakeReport shakeOpts then ["-"] else shakeReport shakeOpts) $ \file -> do
putStrLn $ "Writing report to " ++ file
writeProgressReport file dat
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)
shakeOpts <- if null progressRecords then return shakeOpts else do
t <- offsetTime
return shakeOpts{shakeProgress = \p -> do
bracket
(forkIO $ shakeProgress shakeOpts p)
killThread
$ const $ progressDisplay 1 (const $ return ()) $ do
p <- p
t <- t
forM_ progressRecords $ \file -> do
appendFile file $ show (t,p) ++ "\n"
return p
}
(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
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 = do
progName <- getProgName
putStr $ unlines $ ("Usage: " ++ progName ++ " [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
| NumericVersion
| AssumeNew FilePath
| AssumeOld FilePath
| PrintDirectory Bool
| Color
| Help
| Sleep
| NoTime
| Exception
| NoBuild
| ProgressRecord FilePath
| ProgressReplay FilePath
| Demo
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 "" ["demo"] (NoArg $ Right ([Demo], id)) "Run in demo mode."
,yes $ Option "" ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes."
,yes $ Option "" ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change."
,yes $ Option "" ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."
,yes $ Option "" ["digest-or"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeOrDigest})) "Files change when modtime or digest change."
,no $ Option "" ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."
,yes $ Option "" ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."
,yes $ Option "" ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."
,no $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."
,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."
,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 "" ["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 "" ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."
,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."
,no $ Option "" ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit."
,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","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."
,yes $ Option "" ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."
,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."
,yes $ Option "" ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."
,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"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]."
,yes $ Option "" ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."
,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."
,no $ Option "" ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."
,yes $ Option "" ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."
,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."
,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"
progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of
Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)
Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)
_ -> func x
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