% Copyright (C) 2002,2003,2005 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; see the file COPYING. If not, write to
% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
% Boston, MA 02110-1301, USA.
\begin{code}
module Darcs.Commands ( CommandControl( Command_data, Hidden_command, Group_name ),
DarcsCommand( DarcsCommand, command_name,
command_help, command_description,
command_basic_options, command_advanced_options,
command_command,
command_prereq,
command_extra_arg_help,
command_extra_args,
command_argdefaults,
command_get_arg_possibilities,
SuperCommand,
command_sub_commands ),
command_alias, command_stub,
disambiguate_commands, CommandArgs(..),
get_command_help,
usage, extended_usage, extract_commands,
run_the_command, command_options, nodefaults,
loggers,
) where
import System.Console.GetOpt
import Control.Monad ( when, unless )
import Data.List ( sort, isPrefixOf )
import Control.Exception ( throwIO, Exception ( ExitException ) )
import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
import Darcs.Test ( run_posthook, run_prehook )
import Darcs.Global ( setTimingsMode, setDebugMode, setVerboseMode,
setSshControlMasterDisabled )
import Darcs.Progress ( setProgressMode )
import Workaround ( getCurrentDirectory )
import Darcs.SignalHandler ( catchNonSignal )
import Darcs.Arguments
import Darcs.External ( viewDoc )
import Darcs.RepoPath ( mkAbsolutePath )
import Darcs.Utils ( formatPath, putStrLnError )
import Darcs.ArgumentDefaults ( get_default_flag )
import Darcs.Match ( checkMatchSyntax )
import Printer ( text, Doc, putDocLn )
\end{code}
The general format of a darcs command is
\begin{verbatim}
% darcs COMMAND OPTIONS ARGUMENTS ...
\end{verbatim}
Here \verb|COMMAND| is a command such as \verb|add| or \verb|record|, which of
course may have one or more arguments. Options have the form
\verb!--option! or \verb!-o!, while arguments vary from command to
command. There are many options which are common to a number of different
commands, which will be summarized here.
If you wish, you may use any unambiguous beginning of a command name as a
shortcut: for \verb!darcs record!, you could type \verb!darcs recor! or
\verb!darcs rec!, but not \verb!darcs re! since that could be confused with
\verb!darcs replace!, \verb!darcs revert! and \verb!darcs remove!.
In some cases, \verb|COMMAND| actually consists of two words, a
super-command and a subcommand. For example, the ``display the
manifest'' command has the form \verb|darcs query manifest|.
\paragraph{Command overview}
Not all commands modify the ``patches'' of your repository (that
is, the named patches which other users can pull); some commands only
affect the copy of the source tree you're working on (your ``working
directory''), and some affect both. This table summarizes what you should
expect from each one and will hopefully serve as guide when you're having
doubts about which command to use.
\begin{center}
\footnotetext[1]{But it affects the repository and working directory targeted
by the push}
\footnotetext[2]{As for the other end, see apply}
\begin{tabular}{|c|c|c|}
\hline
affects & patches & working directory\\
\hline
record & yes & no\\
\hline
unrecord & yes & no\\
\hline
rollback & yes & yes\\
\hline
revert & no & yes\\
\hline
unrevert & no & yes\\
\hline
pull & yes & yes\\
\hline
obliterate & yes & yes\\
\hline
apply & yes & yes\\
\hline
push\footnote{But it affects the repository and working directory targeted by
the push} & no & no\\
\hline
send\footnote{As for the other end, see apply} & no & no\\
\hline
put\footnote{Creates a new repository} & no & no\\
\hline
\end{tabular}
\end{center}
\begin{code}
extract_commands, extract_hidden_commands :: [CommandControl] -> [DarcsCommand]
extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs
extract_hidden_commands cs = concatMap (\x -> case x of { Hidden_command cmd_d -> [cmd_d]; _ -> []}) cs
run_the_command :: String -> [String] -> [CommandControl] -> IO ()
run_the_command cmd args cs =
either fail rtc $ disambiguate_commands cs cmd args
where
rtc (CommandOnly c, as) = run_command Nothing c as
rtc (SuperCommandOnly c, as) = run_raw_supercommand c as
rtc (SuperCommandSub c s, as) = run_command (Just c) s as
\end{code}
\input{Darcs/Arguments.lhs}
\begin{code}
data CommandControl = Command_data DarcsCommand
| Hidden_command DarcsCommand
| Group_name String
data DarcsCommand =
DarcsCommand {command_name, command_help, command_description :: String,
command_extra_args :: Int,
command_extra_arg_help :: [String],
command_command :: [DarcsFlag] -> [String] -> IO (),
command_prereq :: [DarcsFlag] -> IO (Either String FilePath),
command_get_arg_possibilities :: IO [String],
command_argdefaults :: [DarcsFlag] -> FilePath -> [String] -> IO [String],
command_basic_options :: [DarcsOption],
command_advanced_options :: [DarcsOption]}
| SuperCommand {command_name, command_help, command_description :: String,
command_prereq :: [DarcsFlag] -> IO (Either String FilePath),
command_sub_commands :: [CommandControl]}
command_alloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])
command_alloptions DarcsCommand { command_basic_options = opts1
, command_advanced_options = opts2 }
= (opts1 ++ [disable, help],
any_verbosity ++ opts2 ++
[posthook_cmd, posthook_prompt
,prehook_cmd, prehook_prompt])
-- Supercommands cannot be disabled.
command_alloptions SuperCommand { } = ([help],[])
-- Obtain options suitable as input to
-- System.Console.Getopt, including the --disable option (which is
-- not listed explicitly in the DarcsCommand definitions).
command_options :: DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])
command_options c = (convert basic, convert advanced)
where (basic, advanced) = command_alloptions c
convert = concatMap option_from_darcsoption
nodefaults :: [DarcsFlag] -> FilePath -> [String] -> IO [String]
nodefaults _ _ xs = return xs
get_subcommands :: DarcsCommand -> [CommandControl]
get_subcommands c@(SuperCommand {}) = command_sub_commands c
get_subcommands _ = []
command_alias :: String -> DarcsCommand -> DarcsCommand
command_alias n c =
c { command_name = n
, command_help = desc ++ "\n" ++ command_help c
, command_description = desc
}
where desc = "Alias for " ++ command_name c
command_stub :: String -> String -> String -> DarcsCommand -> DarcsCommand
command_stub n h d c =
c { command_name = n
, command_help = h
, command_description = d
, command_command = \_ _ -> putStr h
}
\end{code}
\begin{code}
extended_usage :: String
extended_usage = "Usage: darcs COMMAND ..."
++ "\n"
++ "\nExtended Help:"
++ "\n"
++ "\nA darcs repository consists of:"
++ "\n"
++ "\n - a set of PATCHES"
++ "\n - a WORKING directory"
++ "\n"
++ "\nHere is a description of which of these components is altered by each"
++ "\ncommand, and how it is used or altered:"
++ "\n"
++ "\n whatsnew Show the differences between WORKING and the \"recorded\""
++ "\n version, that is, the result of applying all PATCHES in the"
++ "\n repository. This difference, we will call LOCAL CHANGES."
++ "\n"
++ "\n record Add a patch to PATCHES representing the LOCAL CHANGES."
++ "\n"
++ "\n unrecord Delete a patch from PATCHES, but *do not* alter WORKING."
++ "\n This works for any patch, not just one that was previously "
++ "\n \"record\"ed"
++ "\n"
++ "\n revert Remove LOCAL CHANGES. Note that this command is interactive,"
++ "\n so you can use it to revert only some of these changes."
++ "\n"
++ "\n unrevert Undo the last revert operation."
++ "\n"
++ "\n obliterate Delete a patch from PATCHES and unapply it from WORKING."
++ "\n Note that this command works for any patch, not just one that"
++ "\n was previously \"pull\"ed. If there are no LOCAL CHANGES,"
++ "\n this command is equivalent to \"darcs unrecord; darcs revert\""
++ "\n"
++ "\n rollback Create the new patch that inverts some changes from one or more"
++ "\n patches. These changes are also inverted in the working"
++ "\n directory."
++ "\n"
\end{code}
\begin{code}
usage :: [CommandControl] -> String
usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++
usage_helper cs ++ "\n" ++
"Use 'darcs --overview' for more detailed help on basic commands.\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\n" ++
"Check bug reports at http://bugs.darcs.net/\n"
subusage :: DarcsCommand -> String
subusage super =
(usageInfo
("Usage: darcs "++command_name super++" SUBCOMMAND ... " ++
"\n\n"++ command_description super++
"\n\nSubcommands:\n" ++ usage_helper (get_subcommands super) ++ "\nOptions:")
(option_from_darcsoption help))
++ "\n" ++ command_help super
usage_helper :: [CommandControl] -> String
usage_helper [] = ""
usage_helper (Hidden_command _:cs) = usage_helper cs
usage_helper ((Command_data c):cs) = " "++pad_spaces (command_name c) 15 ++
chomp_newline (command_description c)++"\n"++usage_helper cs
usage_helper ((Group_name n):cs) = n ++ "\n" ++ usage_helper cs
chomp_newline :: String -> String
chomp_newline "" = ""
chomp_newline s = if last s == '\n' then init s else s
pad_spaces :: String -> Int -> String
pad_spaces s n = s ++ replicate (n - length s) ' '
\end{code}
\begin{comment}
This is the actual heavy lifter code, which is responsible for parsing the
arguments and then running the command itself.
\end{comment}
\begin{code}
run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()
run_command _ _ args -- Check for "dangerous" typoes...
| "-all" `elem` args = -- -all indicates --all --look-for-adds!
fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?"
run_command msuper cmd args =
case getOpt Permute
(option_from_darcsoption list_options++options) args of
(opts,extra,[])
| Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd
| ListOptions `elem` opts -> do
setProgressMode False
maybe_fix <- command_prereq cmd opts
repodir <- mkAbsolutePath `fmap` getCurrentDirectory
file_args <- case maybe_fix of
Right f -> unfix_filepaths [FixFilePath repodir f]
`fmap` command_get_arg_possibilities cmd
Left _ -> return []
putStrLn $ get_command_options cmd ++ unlines file_args
| otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra
(_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
where options = opts1 ++ opts2
(opts1, opts2) = command_options cmd
addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts
| otherwise = opts
consider_running :: Maybe DarcsCommand -> DarcsCommand
-> [DarcsFlag] -> [String] -> IO ()
consider_running msuper cmd opts old_extra = do
pwd <- mkAbsolutePath `fmap` getCurrentDirectory
location <- command_prereq cmd opts
case location of
Left complaint -> fail $ "Unable to " ++
formatPath ("darcs " ++ super_name msuper ++ command_name cmd) ++
" here.\n\n" ++ complaint
Right fix_path -> do
specops <- add_command_defaults cmd $ map (fix_flag pwd) opts
extra <- (command_argdefaults cmd) specops fix_path old_extra
when (Disable `elem` specops) $
fail $ "Command "++command_name cmd++" disabled with --disable option!"
if command_extra_args cmd < 0
then runWithHooks specops extra
else if length extra > command_extra_args cmd
then fail $ "Bad argument: `"++unwords extra++"'\n"++
get_command_mini_help msuper cmd
else if length extra < command_extra_args cmd
then fail $ "Missing argument: " ++
nth_arg (length extra + 1) ++
"\n" ++ get_command_mini_help msuper cmd
else runWithHooks specops extra
where nth_arg n = nth_of n (command_extra_arg_help cmd)
nth_of 1 (h:_) = h
nth_of n (_:hs) = nth_of (n-1) hs
nth_of _ [] = "UNDOCUMENTED"
runWithHooks os ex = do
here <- getCurrentDirectory
checkMatchSyntax os
-- set any global variables
when (Timings `elem` os) setTimingsMode
when (Debug `elem` os) setDebugMode
when (Verbose `elem` os) setVerboseMode
when (Quiet `elem` os) $ setProgressMode False
unless (SSHControlMaster `elem` os) setSshControlMasterDisabled
-- actually run the command and its hooks
preHookExitCode <- run_prehook os here
if preHookExitCode /= ExitSuccess
then exitWith preHookExitCode
else do let fixFlag = FixFilePath (mkAbsolutePath here) fix_path
(command_command cmd) (fixFlag : os) ex
`catchNonSignal`
(\e -> case e of
ExitException ExitSuccess -> return ()
_ -> throwIO e)
postHookExitCode <- run_posthook os here
--
exitWith postHookExitCode
add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]
add_command_defaults cmd already =
acd (command_name cmd) already (opts1 ++ opts2)
where (opts1, opts2) = command_alloptions cmd
acd :: String -> [DarcsFlag] -> [DarcsOption] -> IO [DarcsFlag]
acd _ flags [] = return flags
acd c flags (dao:dos)
= case dao of
DarcsNoArgOption _ _ f _
-> if f `elem` flags then acd c flags dos
else do flags' <- get_default_flag c dao
acd c (flags++flags') dos
DarcsArgOption _ _ f _ _
-> if f `isin` flags then acd c flags dos
else do flags' <- get_default_flag c dao
acd c (flags++flags') dos
DarcsMultipleChoiceOption os
-> if os `arein` flags then acd c flags dos
else do flags' <- get_default_flag c dao
acd c (flags++flags') dos
where f `isin` fs = any (`isa` f) fs
(DarcsNoArgOption _ _ f _ : dos') `arein` fs
= f `elem` fs || dos' `arein` fs
(DarcsArgOption _ _ f _ _ : dos') `arein` fs
= f `isin` fs || dos' `arein` fs
(DarcsMultipleChoiceOption os: dos') `arein` fs
= os `arein` fs || dos' `arein` fs
[] `arein` _ = False
get_command_options :: DarcsCommand -> String
get_command_options cmd =
(get_options_options $ opts1 ++ opts2)
where (opts1, opts2) = command_options cmd
get_options_options :: [OptDescr DarcsFlag] -> String
get_options_options [] = ""
get_options_options (o:os) =
get_long_option o ++"\n"++ get_options_options os
get_long_option :: OptDescr DarcsFlag -> String
get_long_option (Option _ [] _ _) = ""
get_long_option (Option a (o:os) b c) = "--"++o++
get_long_option (Option a os b c)
super_name :: Maybe DarcsCommand -> String
super_name Nothing = ""
super_name (Just x) = command_name x ++ " "
get_command_mini_help :: Maybe DarcsCommand -> DarcsCommand -> String
get_command_mini_help msuper cmd =
get_command_help_core msuper cmd ++
"\n\nSee darcs help "
++ (maybe "" (\c -> command_name c ++ " ") msuper)
++ command_name cmd ++ " for details."
get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String
get_command_help msuper cmd =
unlines (reverse basicR)
++ (if null advanced then ""
else "\nAdvanced options:\n" ++ unlines (reverse advancedR))
++ "\n" ++ command_help cmd
where -- we could just call usageInfo twice, but then the advanced
-- options might not line up with the basic ones (no short flags)
(advancedR, basicR) =
splitAt (length advanced) $ reverse $ lines combinedUsage
combinedUsage = usageInfo
(get_command_help_core msuper cmd ++ subcommands ++ "\n\nOptions:")
(basic ++ advanced)
(basic, advanced) = command_options cmd
subcommands =
case msuper of
Nothing -> case get_subcommands cmd of
[] -> []
s -> "\n\nSubcommands:\n" ++ (usage_helper s)
-- we don't want to list subcommands if we're already specifying them
Just _ -> ""
get_command_help_core :: Maybe DarcsCommand -> DarcsCommand -> String
get_command_help_core msuper cmd =
"Usage: darcs "++super_name msuper++command_name cmd++
" [OPTION]... " ++ unwords args_help ++
"\n"++ command_description cmd
where args_help = case cmd of
(DarcsCommand _ _ _ _ _ _ _ _ _ _ _) ->
command_extra_arg_help cmd
_ -> []
\end{code}
\begin{code}
run_raw_supercommand :: DarcsCommand -> [String] -> IO ()
run_raw_supercommand super [] =
fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"
++ subusage super
run_raw_supercommand super args =
case getOpt RequireOrder
(option_from_darcsoption help++
option_from_darcsoption list_options) args of
(opts,_,[])
| Help `elem` opts ->
viewDoc $ text $ get_command_help Nothing super
| ListOptions `elem` opts -> do
putStrLn "--help"
mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super)
| otherwise ->
if Disable `elem` opts
then fail $ "Command " ++ (command_name super) ++
" disabled with --disable option!"
else fail $ "Invalid subcommand!\n\n" ++ subusage super
(_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
\end{code}
\begin{code}
data CommandArgs = CommandOnly DarcsCommand
| SuperCommandOnly DarcsCommand
| SuperCommandSub DarcsCommand DarcsCommand
-- Parses a darcs command line with potentially abbreviated commands
disambiguate_commands :: [CommandControl] -> String -> [String]
-> Either String (CommandArgs, [String])
disambiguate_commands allcs cmd args =
do c <- extract cmd allcs
case (get_subcommands 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 <- extract_commands cs, cmd `isPrefixOf` command_name c ] ++
[ h | h <- extract_hidden_commands cs, cmd == command_name 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 command_name cs')
\end{code}
\begin{code}
-- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn)
loggers :: [DarcsFlag] -> ( String -> IO ()
, String -> IO ()
, Doc -> IO ())
loggers _ = (putStrLn, putStrLnError, putDocLn)
\end{code}