module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ),
DarcsCommand( DarcsCommand, commandProgramName, commandName,
commandHelp, commandDescription,
commandBasicOptions, commandAdvancedOptions,
commandCommand,
commandPrereq,
commandExtraArgHelp,
commandExtraArgs,
commandArgdefaults,
commandGetArgPossibilities,
SuperCommand,
commandSubCommands ),
commandAlias, commandStub,
commandOptions, commandAlloptions,
disambiguateCommands, CommandArgs(..),
getCommandHelp, getCommandMiniHelp,
getSubcommands,
usage, usageHelper, subusage, chompNewline,
extractCommands,
superName,
nodefaults,
putInfo, putVerbose, putWarning, abortRun
) where
import System.Console.GetOpt( OptDescr, usageInfo )
import Control.Monad (when, unless)
import Data.List ( sort, isPrefixOf )
import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help,
anyVerbosity, noCache, posthookCmd, posthookPrompt,
prehookCmd, prehookPrompt, optionFromDarcsOption )
import Darcs.RepoPath ( AbsolutePath, rootDirectory )
import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc )
import System.IO ( stderr )
extractCommands, extractHiddenCommands :: [CommandControl] -> [DarcsCommand]
extractCommands cs = concatMap (\x -> case x of { CommandData cmd_d -> [cmd_d]; _ -> []}) cs
extractHiddenCommands cs = concatMap (\x -> case x of { HiddenCommand cmd_d -> [cmd_d]; _ -> []}) cs
data CommandControl = CommandData DarcsCommand
| HiddenCommand DarcsCommand
| GroupName String
data DarcsCommand =
DarcsCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,
commandExtraArgs :: Int,
commandExtraArgHelp :: [String],
commandCommand :: [DarcsFlag] -> [String] -> IO (),
commandPrereq :: [DarcsFlag] -> IO (Either String ()),
commandGetArgPossibilities :: IO [String],
commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],
commandBasicOptions :: [DarcsOption],
commandAdvancedOptions :: [DarcsOption]}
| SuperCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,
commandPrereq :: [DarcsFlag] -> IO (Either String ()),
commandSubCommands :: [CommandControl]}
commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])
commandAlloptions DarcsCommand { commandBasicOptions = opts1
, commandAdvancedOptions = opts2 }
= (opts1 ++ [disable, help],
anyVerbosity ++ opts2 ++
[noCache
,posthookCmd, posthookPrompt
,prehookCmd, prehookPrompt])
commandAlloptions SuperCommand { } = ([help],[])
commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])
commandOptions cwd c = (convert basic, convert advanced)
where (basic, advanced) = commandAlloptions c
convert = concatMap (optionFromDarcsOption cwd)
nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults _ _ xs = return xs
getSubcommands :: DarcsCommand -> [CommandControl]
getSubcommands c@(SuperCommand {}) = commandSubCommands c
getSubcommands _ = []
commandAlias :: String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias n msuper c =
c { commandName = n
, commandDescription = "Alias for `" ++ commandProgramName c ++ " " ++ cmdName ++ "'."
, commandHelp = "The `" ++ commandProgramName c ++ " " ++ n ++ "' command is an alias for " ++
"`" ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n" ++
commandHelp c
}
where
cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]
commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand
commandStub n h d c =
c { commandName = n
, commandHelp = h
, commandDescription = d
, commandCommand = \_ _ -> putStr h
}
usage :: [CommandControl] -> String
usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++
usageHelper cs ++ "\n" ++
"Use 'darcs COMMAND --help' for help on a single command.\n" ++
"Use 'darcs --version' to see the darcs version number.\n" ++
"Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++
"Use 'darcs help patterns' for help on patch matching.\n" ++
"Use 'darcs help environment' for help on environment variables.\n" ++
"\n" ++
"Check bug reports at http://bugs.darcs.net/\n"
subusage :: DarcsCommand -> String
subusage super =
(usageInfo
("Usage: " ++ commandProgramName super ++ " "++commandName super++" SUBCOMMAND ... " ++
"\n\n"++ commandDescription super++
"\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:")
(optionFromDarcsOption rootDirectory help))
++ "\n" ++ commandHelp super
usageHelper :: [CommandControl] -> String
usageHelper [] = ""
usageHelper (HiddenCommand _:cs) = usageHelper cs
usageHelper ((CommandData c):cs) = " "++padSpaces (commandName c) 15 ++
chompNewline (commandDescription c)++"\n"++usageHelper cs
usageHelper ((GroupName n):cs) = "\n" ++ n ++ "\n" ++ usageHelper cs
chompNewline :: String -> String
chompNewline "" = ""
chompNewline s = if last s == '\n' then init s else s
padSpaces :: String -> Int -> String
padSpaces s n = s ++ replicate (n length s) ' '
superName :: Maybe DarcsCommand -> String
superName Nothing = ""
superName (Just x) = commandName x ++ " "
getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String
getCommandMiniHelp msuper cmd =
getCommandHelpCore msuper cmd ++
"\n\nSee " ++ commandProgramName cmd ++ " help "
++ (maybe "" (\c -> commandName c ++ " ") msuper)
++ commandName cmd ++ " for details."
getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String
getCommandHelp msuper cmd =
unlines (reverse basicR)
++ (if null advanced then ""
else "\nAdvanced options:\n" ++ unlines (reverse advancedR))
++ "\n" ++ commandHelp cmd
where
(advancedR, basicR) =
splitAt (length advanced) $ reverse $ lines combinedUsage
combinedUsage = usageInfo
(getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:")
(basic ++ advanced)
(basic, advanced) = commandOptions rootDirectory cmd
subcommands =
case msuper of
Nothing -> case getSubcommands cmd of
[] -> []
s -> "\n\nSubcommands:\n" ++ (usageHelper s)
Just _ -> ""
getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String
getCommandHelpCore msuper cmd =
"Usage: " ++ commandProgramName cmd ++ " "++superName msuper++commandName cmd++
" [OPTION]... " ++ unwords args_help ++
"\n"++ commandDescription cmd
where args_help = case cmd of
(DarcsCommand {}) ->
commandExtraArgHelp cmd
_ -> []
data CommandArgs = CommandOnly DarcsCommand
| SuperCommandOnly DarcsCommand
| SuperCommandSub DarcsCommand DarcsCommand
disambiguateCommands :: [CommandControl] -> String -> [String]
-> Either String (CommandArgs, [String])
disambiguateCommands allcs cmd args =
do c <- extract cmd allcs
case (getSubcommands c, args) of
([], _) -> return (CommandOnly c, args)
(_ ,[]) -> return (SuperCommandOnly c, args)
(subcs, (a:as)) -> case extract a subcs of
Left _ -> return (SuperCommandOnly c, args)
Right sc -> return (SuperCommandSub c sc, as)
extract :: String -> [CommandControl] -> Either String DarcsCommand
extract cmd cs =
case [ c | c <- extractCommands cs, cmd `isPrefixOf` commandName c ] ++
[ h | h <- extractHiddenCommands cs, cmd == commandName h ] of
[] -> Left $ "No such command '" ++ cmd ++ "'\n"
[c] -> Right c
cs' -> Left $ "Ambiguous command...\n\n" ++
"The command '"++cmd++"' could mean one of:\n" ++
unwords (sort $ map commandName cs')
amVerbose :: [DarcsFlag] -> Bool
amVerbose = elem Verbose
amQuiet :: [DarcsFlag] -> Bool
amQuiet = elem Quiet
putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose opts = when (amVerbose opts) . putDocLn
putInfo :: [DarcsFlag] -> Doc -> IO ()
putInfo opts = unless (amQuiet opts) . putDocLn
putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning opts = unless (amQuiet opts) . hPutDocLn stderr
abortRun :: [DarcsFlag] -> Doc -> IO ()
abortRun opts msg = if DryRun `elem` opts
then putInfo opts $ text "NOTE:" <+> msg
else errorDoc msg