%  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 DarcsCommands ( CommandControl( Command_data, Group_name ),
                       DarcsCommand( DarcsCommand, command_name,
                                     command_help, command_description,
                                     command_darcsoptions, command_command,
                                     command_prereq,
                                     command_extra_arg_help,
                                     command_extra_args,
                                     command_argdefaults,
                                     command_get_arg_possibilities,
                                     SuperCommand,
                                     command_sub_commands ),
                       disambiguate_commands, 
                       get_command_help, 
                       usage, extended_usage, extract_commands,
                       run_the_command, command_options, nodefaults,
                       loggers,
                     ) where
import System.Console.GetOpt
import Monad ( liftM, when )
import List ( sort )
import Control.Exception ( catch, throwIO, Exception ( ExitException ) )
import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
import Test ( run_posthook )
import Global ( setSshControlMasterDisabled )
import Workaround ( getCurrentDirectory )

import DarcsArguments
import DarcsUtils ( formatPath, putStrLnError )
import ArgumentDefaults ( get_default_flag )
import Printer ( Doc, putDocLn )
#ifdef HAVEWX
import Graphics.UI.WXCore ( logMessage, logError )
import Printer ( renderString )
#endif
\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 & no\\
\hline
revert & no & yes\\
\hline
unrevert & no & yes\\
\hline
pull & yes & yes\\
\hline
unpull & 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 :: [CommandControl] -> [DarcsCommand]
extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs

run_the_command :: String -> [String] -> [CommandControl] -> IO ()
run_the_command cmd args cs = run_maybe_sub_command Nothing cmd args cs

run_maybe_sub_command :: Maybe DarcsCommand
                      -> String -> [String] -> [CommandControl] -> IO ()
run_maybe_sub_command super cmd args cs =
    case filter ((==cmd).take (length cmd).command_name) (extract_commands cs) of
    [] -> case super of
          Nothing -> fail $ "Invalid command '"++cmd++"'!\n\n" ++ usage cs
          Just s -> run_raw_supercommand s (cmd:args) cs
    [c] ->
        case get_subcommands c of
        [] -> run_command super c args
        cs' ->
          case args of
          (cmd':args') -> run_maybe_sub_command (Just c) cmd' args' cs'
          [] -> fail $"Subcommand required!\n\n" ++  subusage c cs'
    cs' -> fail $ "Ambiguous command...\n\n" ++
                  "The command '"++cmd++"' could mean one of:\n" ++
                  unwords (sort $ map command_name cs')
\end{code}

\input{DarcsArguments.lhs}

\begin{code}
data CommandControl = Command_data 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 :: FilePath -> [String] -> IO [String],
                  command_darcsoptions :: [DarcsOption]}
  | SuperCommand {command_name, command_help, command_description :: String,
                  command_prereq :: [DarcsFlag] -> IO (Either String FilePath),
                  command_sub_commands :: [CommandControl]}

command_alloptions :: DarcsCommand -> [DarcsOption]
command_alloptions DarcsCommand { command_darcsoptions = opts }
    = opts ++ [disable, help, posthook_cmd, posthook_prompt]
--  Supercommands cannot be disabled.
command_alloptions SuperCommand { } = [help]

--  Obtain a list of 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]
command_options = concat . map option_from_darcsoption . command_alloptions

nodefaults :: FilePath -> [String] -> IO [String]
nodefaults _ xs = return xs

get_subcommands :: DarcsCommand -> [CommandControl]
get_subcommands c@(SuperCommand {}) = command_sub_commands c
get_subcommands _ = []
\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  unpull        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 inverse of a particular patch and add it to PATCHES,"
    ++ "\n                but DO NOT apply it to WORKING.  Note that this command is the"
    ++ "\n                only way to wind up with a patch in PATCHES which has not been"
    ++ "\n                applied to WORKING."
    ++ "\n"
\end{code}

\begin{code}
usage :: [CommandControl] -> String
usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++
           usage_helper cs ++ "\n" ++
           "Use 'darcs --extended-help' for more detailed help.\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" ++
           "Report bugs to bugs@darcs.net or via http://bugs.darcs.net/.\n"

subusage :: DarcsCommand -> [CommandControl] -> String
subusage super cs =
    (usageInfo
     ("Usage: darcs "++command_name super++" SUBCOMMAND ... " ++
      "\n\n"++ command_description super++
      "\n\nSubcommands:\n" ++ usage_helper cs ++ "\nOptions:")
     (option_from_darcsoption help))
    ++ "\n" ++ command_help super

usage_helper :: [CommandControl] -> String
usage_helper [] = ""
usage_helper ((Command_data c):cs) = "  "++pad_spaces (command_name c) 14 ++
                      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 -> putStr $ get_command_help msuper cmd
      | ListOptions `elem` opts  -> do
           maybe_fix <- command_prereq cmd opts
           fix <- case maybe_fix of
                  Right f -> return f
                  Left complaint -> fail $ "Can't run command " ++
                             command_name cmd ++" here.\n" ++
                             complaint
           command_args <- unfix_filepaths [FixFilePath fix]
                   `liftM` command_get_arg_possibilities cmd
           putStrLn $ get_command_options cmd++unlines command_args
      | otherwise -> do             
           do  l <- get_default_flag (command_name cmd) disable
               when (length l > 0) $ do
                   fail $ "Command " ++ (command_name cmd) ++
                          " disabled by configuration!"
           when (Disable `elem` opts) $ do
               fail $ "Command " ++ (command_name cmd) ++
                      " disabled with --disable option!"
           consider_running msuper cmd opts extra
    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
    where options = command_options cmd

consider_running :: Maybe DarcsCommand -> DarcsCommand
                 -> [DarcsFlag] -> [String] -> IO ()
consider_running msuper cmd opts old_extra = do
 location <- command_prereq cmd opts
 case location of
   Left complaint -> fail $ "Unable to " ++
                     formatPath ("darcs "++ command_name cmd) ++
                     " here.\n\n" ++ complaint
   Right fix_path -> do
    extra <- (command_argdefaults cmd) fix_path old_extra
    specops <- add_command_defaults cmd $ map (fix_flag fix_path) opts
    if command_extra_args cmd < 0
      then runWithPostHook specops extra
      else if length extra > command_extra_args cmd
           then fail $ "Bad argument: `"++unwords extra++"'\n"++
                       get_command_help msuper cmd
           else if length extra < command_extra_args cmd
                then fail $ "Missing argument:  " ++
                            nth_arg (length extra + 1) ++
                            "\n" ++ get_command_help msuper cmd
                else runWithPostHook 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"
             runWithPostHook os ex =
                 do here <- getCurrentDirectory
                    -- set any global variables
                    when (DisableSSHControlMaster `elem` os) setSshControlMasterDisabled
                    -- actually run the command and its posthooks
                    (command_command cmd) (FixFilePath fix_path : os) ex
                       `Control.Exception.catch`
                       (\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 (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 options)
    where options = 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)


get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String
get_command_help msuper cmd =
    (usageInfo
     ("Usage: darcs "++super_name++command_name cmd++" [OPTION]... " ++
      unwords args_help ++ 
      "\n"++ command_description cmd ++ subcommands ++ "\n\nOptions:")
     (command_options cmd))
    ++ "\n" ++ command_help cmd
    where args_help = 
            case cmd of
            (DarcsCommand _ _ _ _ _ _ _ _ _ _) -> 
              command_extra_arg_help cmd
            _ -> [] 
          super_name = case msuper of
                       Nothing -> ""
                       Just x -> command_name x ++ " "
          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 _  -> ""
\end{code}

\begin{code}
run_raw_supercommand :: DarcsCommand -> [String] -> [CommandControl] -> IO ()
run_raw_supercommand super [] cs =
    fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"
             ++ subusage super cs
run_raw_supercommand super args cs =
    case getOpt RequireOrder
             (option_from_darcsoption help++
              option_from_darcsoption list_options) args of
    (opts,_,[]) 
      | ListOptions `elem` opts -> do 
            putStrLn "--help"
            mapM_ (putStrLn . command_name) (extract_commands cs)
      | otherwise -> 
            if Disable `elem` opts
            then fail $ "Command " ++ (command_name super) ++
                      " disabled with --disable option!"
            else fail $ "Invalid subcommand!\n\n" ++ subusage super cs
    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
\end{code}

\begin{code}
-- parses a darcs command line with potentially abbreviated commands
-- If it fails, returns Left (error message)
-- If it suceeds, returns Right (cmds, args)
-- where cmds is a disambiguated list [command, subcommand, sub-subcommand, ..]  
-- and   args are the arguments to the commands
--
-- Fails if it there is a command that it cannot disambiguate
-- note that currently in darcs, there are only two layers, command and sub-command
disambiguate_commands :: [CommandControl] -> [String] -> Either String ([DarcsCommand], [String])
disambiguate_commands _ [] = Right ([],[])
disambiguate_commands cs (cmd:args) = 
   case filter ((==cmd).take (length cmd).command_name) (extract_commands cs) of
   []  -> Left $ "No such command '" ++ cmd ++ "'\n"
   [c] -> let possibleSub = get_subcommands c
          in if null possibleSub 
             then Right ([c], args)
             else let next = disambiguate_commands possibleSub args 
                  in case next of 
                       Right (c', args') -> Right (c:c', args')
                       err               -> err
   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 ())
#ifdef HAVEWX
loggers opts | SubGui `elem` opts  =
  (logMessage, logError, logMessage.renderString)
#endif
loggers _ = (putStrLn, putStrLnError, putDocLn)
\end{code}
