--  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.

{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands
    ( CommandControl ( CommandData, HiddenCommand, GroupName )
    , DarcsCommand ( .. )
    , WrappedCommand(..)
    , wrappedCommandName
    , wrappedCommandDescription
    , commandAlias
    , commandStub
    , commandOptions
    , commandAlloptions
    , withStdOpts
    , disambiguateCommands
    , CommandArgs(..)
    , getSubcommands
    , extractCommands
    , extractAllCommands
    , normalCommand
    , hiddenCommand
    , commandGroup
    , superName
    , nodefaults
    , putInfo
    , putVerbose
    , putWarning
    , putVerboseWarning
    , abortRun
    , setEnvDarcsPatches
    , setEnvDarcsFiles
    , defaultRepo
    , amInHashedRepository
    , amInRepository
    , amNotInRepository
    , findRepository
    ) where

import Prelude ()
import Darcs.Prelude

import Prelude hiding ( (^) )
import Control.Monad ( when, unless )
import Data.List ( sort, isPrefixOf )
import Darcs.Util.Tree ( Tree )
import System.Console.GetOpt ( OptDescr )
import System.IO ( stderr )
import System.IO.Error ( catchIOError )
import System.Environment ( setEnv )
import Darcs.Patch ( listTouchedFiles )
import qualified Darcs.Patch ( summary )
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Info ( toXml )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )

import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository
                                       , amNotInRepository, findRepository )
import Darcs.Repository.Prefs ( defaultrepo )

import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags, (?) )
import Darcs.UI.Options.All
    ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, HooksConfig, hooks
    , Verbosity(..), DryRun(..), dryRun
    )

import Darcs.UI.Flags ( DarcsFlag, remoteRepos, workRepo, quiet, verbose )

import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8 )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer
    ( Doc, text, (<+>), ($$), vcat
    , putDocLnWith, hPutDocLn, errorDoc, renderString
    )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Progress
    ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )

extractCommands :: [CommandControl] -> [WrappedCommand]
extractCommands :: [CommandControl] -> [WrappedCommand]
extractCommands ccl :: [CommandControl]
ccl = [ WrappedCommand
cmd | CommandData cmd :: WrappedCommand
cmd <- [CommandControl]
ccl ]

extractHiddenCommands :: [CommandControl] -> [WrappedCommand]
extractHiddenCommands :: [CommandControl] -> [WrappedCommand]
extractHiddenCommands ccl :: [CommandControl]
ccl = [ WrappedCommand
cmd | HiddenCommand cmd :: WrappedCommand
cmd <- [CommandControl]
ccl ]

extractAllCommands :: [CommandControl] -> [WrappedCommand]
extractAllCommands :: [CommandControl] -> [WrappedCommand]
extractAllCommands ccl :: [CommandControl]
ccl = (WrappedCommand -> [WrappedCommand])
-> [WrappedCommand] -> [WrappedCommand]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WrappedCommand -> [WrappedCommand]
flatten ([CommandControl] -> [WrappedCommand]
extractCommands [CommandControl]
ccl [WrappedCommand] -> [WrappedCommand] -> [WrappedCommand]
forall a. [a] -> [a] -> [a]
++ [CommandControl] -> [WrappedCommand]
extractHiddenCommands [CommandControl]
ccl)
    where flatten :: WrappedCommand -> [WrappedCommand]
flatten c :: WrappedCommand
c@(WrappedCommand (DarcsCommand {})) = [WrappedCommand
c]
          flatten c :: WrappedCommand
c@(WrappedCommand (SuperCommand { commandSubCommands :: forall parsedFlags. DarcsCommand parsedFlags -> [CommandControl]
commandSubCommands = [CommandControl]
scs })) = WrappedCommand
c WrappedCommand -> [WrappedCommand] -> [WrappedCommand]
forall a. a -> [a] -> [a]
: [CommandControl] -> [WrappedCommand]
extractAllCommands [CommandControl]
scs

-- |A 'WrappedCommand' is a 'DarcsCommand' where the options type has been hidden
data WrappedCommand where
    WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand

normalCommand :: DarcsCommand parsedFlags -> CommandControl
normalCommand :: DarcsCommand parsedFlags -> CommandControl
normalCommand c :: DarcsCommand parsedFlags
c = WrappedCommand -> CommandControl
CommandData (DarcsCommand parsedFlags -> WrappedCommand
forall parsedFlags. DarcsCommand parsedFlags -> WrappedCommand
WrappedCommand DarcsCommand parsedFlags
c)

hiddenCommand :: DarcsCommand parsedFlags -> CommandControl
hiddenCommand :: DarcsCommand parsedFlags -> CommandControl
hiddenCommand c :: DarcsCommand parsedFlags
c = WrappedCommand -> CommandControl
HiddenCommand (DarcsCommand parsedFlags -> WrappedCommand
forall parsedFlags. DarcsCommand parsedFlags -> WrappedCommand
WrappedCommand DarcsCommand parsedFlags
c)

commandGroup :: String -> CommandControl
commandGroup :: String -> CommandControl
commandGroup = String -> CommandControl
GroupName

wrappedCommandName :: WrappedCommand -> String
wrappedCommandName :: WrappedCommand -> String
wrappedCommandName (WrappedCommand c :: DarcsCommand parsedFlags
c) = DarcsCommand parsedFlags -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand parsedFlags
c

wrappedCommandDescription :: WrappedCommand -> String
wrappedCommandDescription :: WrappedCommand -> String
wrappedCommandDescription (WrappedCommand c :: DarcsCommand parsedFlags
c) = DarcsCommand parsedFlags -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandDescription DarcsCommand parsedFlags
c

data CommandControl
  = CommandData WrappedCommand
  | HiddenCommand WrappedCommand
  | GroupName String

-- |A 'DarcsCommand' represents a command like add, record etc.
-- The 'parsedFlags' type represents the options that are
-- passed to the command's implementation
data DarcsCommand parsedFlags =
      DarcsCommand
          { DarcsCommand parsedFlags -> String
commandProgramName -- programs that use libdarcs can change the name here
          , DarcsCommand parsedFlags -> String
commandName
          , DarcsCommand parsedFlags -> String
commandHelp
          , DarcsCommand parsedFlags -> String
commandDescription :: String
          , DarcsCommand parsedFlags -> Int
commandExtraArgs :: Int
          , DarcsCommand parsedFlags -> [String]
commandExtraArgHelp :: [String]
          , DarcsCommand parsedFlags
-> (AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO ()
commandCommand :: -- First 'AbsolutePath' is the repository path,
                              -- second one is the path where darcs was executed.
                              (AbsolutePath, AbsolutePath)
                           -> parsedFlags -> [String] -> IO ()
          , DarcsCommand parsedFlags -> [DarcsFlag] -> IO (Either String ())
commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand parsedFlags
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
commandCompleteArgs :: (AbsolutePath, AbsolutePath)
                                -> [DarcsFlag] -> [String] -> IO [String]
          , DarcsCommand parsedFlags
-> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]
                               -> IO [String]
          , DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
commandBasicOptions :: [DarcsOptDescr DarcsFlag]
          , DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
          , DarcsCommand parsedFlags -> [DarcsFlag]
commandDefaults :: [DarcsFlag]
          , DarcsCommand parsedFlags -> [DarcsFlag] -> [String]
commandCheckOptions :: [DarcsFlag] -> [String]
          , DarcsCommand parsedFlags -> [DarcsFlag] -> parsedFlags
commandParseOptions :: [DarcsFlag] -> parsedFlags
          }
    | SuperCommand
          { commandProgramName
          , commandName
          , commandHelp
          , commandDescription :: String
          , commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand parsedFlags -> [CommandControl]
commandSubCommands :: [CommandControl]
          }

withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
            -> DarcsOption (UseCache -> HooksConfig -> a) b
            -> DarcsOption a c
withStdOpts :: DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
withStdOpts basicOpts :: DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
basicOpts advancedOpts :: DarcsOption (UseCache -> HooksConfig -> a) b
advancedOpts =
  DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
basicOpts DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Bool -> Verbosity -> Bool -> b)
     (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b)
-> OptSpec
     DarcsOptDescr DarcsFlag (Bool -> Bool -> Verbosity -> Bool -> b) c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Bool -> Verbosity -> Bool -> b)
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions OptSpec
  DarcsOptDescr DarcsFlag (Bool -> Bool -> Verbosity -> Bool -> b) c
-> OptSpec
     DarcsOptDescr DarcsFlag b (Bool -> Bool -> Verbosity -> Bool -> b)
-> OptSpec DarcsOptDescr DarcsFlag b c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr DarcsFlag b (Bool -> Bool -> Verbosity -> Bool -> b)
forall a. DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)
anyVerbosity OptSpec DarcsOptDescr DarcsFlag b c
-> DarcsOption (UseCache -> HooksConfig -> a) b
-> OptSpec DarcsOptDescr DarcsFlag (UseCache -> HooksConfig -> a) c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ DarcsOption (UseCache -> HooksConfig -> a) b
advancedOpts OptSpec DarcsOptDescr DarcsFlag (UseCache -> HooksConfig -> a) c
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (HooksConfig -> a)
     (UseCache -> HooksConfig -> a)
-> OptSpec DarcsOptDescr DarcsFlag (HooksConfig -> a) c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (HooksConfig -> a)
  (UseCache -> HooksConfig -> a)
PrimDarcsOption UseCache
useCache OptSpec DarcsOptDescr DarcsFlag (HooksConfig -> a) c
-> OptSpec DarcsOptDescr DarcsFlag a (HooksConfig -> a)
-> DarcsOption a c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (HooksConfig -> a)
forall a. DarcsOption a (HooksConfig -> a)
hooks

commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions :: DarcsCommand pf
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand { commandBasicOptions :: forall parsedFlags.
DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
commandBasicOptions = [DarcsOptDescr DarcsFlag]
opts1
                               , commandAdvancedOptions :: forall parsedFlags.
DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = [DarcsOptDescr DarcsFlag]
opts2 } =
    ( [DarcsOptDescr DarcsFlag]
opts1 [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
++ OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions
    , OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool -> Bool -> Verbosity -> Bool -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool -> Bool -> Verbosity -> Bool -> Any)
forall a. DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)
anyVerbosity [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
++ [DarcsOptDescr DarcsFlag]
opts2 [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
++ OptSpec DarcsOptDescr DarcsFlag Any (UseCache -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UseCache -> Any)
PrimDarcsOption UseCache
useCache [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
++ OptSpec DarcsOptDescr DarcsFlag Any (HooksConfig -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (HooksConfig -> Any)
forall a. DarcsOption a (HooksConfig -> a)
hooks )
commandAlloptions SuperCommand { } = (OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe StdCmdAction -> Any)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions, [])

--  Obtain options suitable as input to System.Console.Getopt, including the
--  --disable option (which is not listed explicitly in the DarcsCommand
--  definitions).
commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]
commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]
commandOptions cwd :: AbsolutePath
cwd = (DarcsOptDescr DarcsFlag -> OptDescr DarcsFlag)
-> [DarcsOptDescr DarcsFlag] -> [OptDescr DarcsFlag]
forall a b. (a -> b) -> [a] -> [b]
map (AbsolutePath -> DarcsOptDescr DarcsFlag -> OptDescr DarcsFlag
forall f. AbsolutePath -> DarcsOptDescr f -> OptDescr f
optDescr AbsolutePath
cwd) ([DarcsOptDescr DarcsFlag] -> [OptDescr DarcsFlag])
-> (DarcsCommand pf -> [DarcsOptDescr DarcsFlag])
-> DarcsCommand pf
-> [OptDescr DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DarcsOptDescr DarcsFlag]
 -> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag])
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
-> [DarcsOptDescr DarcsFlag]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
(++) (([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
 -> [DarcsOptDescr DarcsFlag])
-> (DarcsCommand pf
    -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag]))
-> DarcsCommand pf
-> [DarcsOptDescr DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand pf
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
forall pf.
DarcsCommand pf
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions

nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults _ _ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return

getSubcommands :: DarcsCommand pf -> [CommandControl]
getSubcommands :: DarcsCommand pf -> [CommandControl]
getSubcommands c :: DarcsCommand pf
c@(SuperCommand {}) = String -> CommandControl
commandGroup "Subcommands:" CommandControl -> [CommandControl] -> [CommandControl]
forall a. a -> [a] -> [a]
: DarcsCommand pf -> [CommandControl]
forall parsedFlags. DarcsCommand parsedFlags -> [CommandControl]
commandSubCommands DarcsCommand pf
c
getSubcommands _ = []

commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias :: String
-> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias n :: String
n msuper :: Maybe (DarcsCommand pf)
msuper c :: DarcsCommand pf
c =
    DarcsCommand pf
c { commandName :: String
commandName = String
n
      , commandDescription :: String
commandDescription = "Alias for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'."
      , commandHelp :: String
commandHelp = "The `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' command is an alias for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "`"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'.\n"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandHelp DarcsCommand pf
c
      }
  where
    cmdName :: String
cmdName = [String] -> String
unwords ([String] -> String)
-> ([DarcsCommand pf] -> [String]) -> [DarcsCommand pf] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DarcsCommand pf -> String) -> [DarcsCommand pf] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName ([DarcsCommand pf] -> [String])
-> ([DarcsCommand pf] -> [DarcsCommand pf])
-> [DarcsCommand pf]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DarcsCommand pf] -> [DarcsCommand pf])
-> (DarcsCommand pf -> [DarcsCommand pf] -> [DarcsCommand pf])
-> Maybe (DarcsCommand pf)
-> [DarcsCommand pf]
-> [DarcsCommand pf]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [DarcsCommand pf] -> [DarcsCommand pf]
forall a. a -> a
id (:) Maybe (DarcsCommand pf)
msuper ([DarcsCommand pf] -> String) -> [DarcsCommand pf] -> String
forall a b. (a -> b) -> a -> b
$ [ DarcsCommand pf
c ]

commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf
commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf
commandStub n :: String
n h :: String
h d :: String
d c :: DarcsCommand pf
c = DarcsCommand pf
c { commandName :: String
commandName = String
n
                        , commandHelp :: String
commandHelp = String
h
                        , commandDescription :: String
commandDescription = String
d
                        , commandCommand :: (AbsolutePath, AbsolutePath) -> pf -> [String] -> IO ()
commandCommand = \_ _ _ -> String -> IO ()
putStr String
h
                        }

superName :: Maybe (DarcsCommand pf) -> String
superName :: Maybe (DarcsCommand pf) -> String
superName Nothing  = ""
superName (Just x :: DarcsCommand pf
x) = DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "

data CommandArgs where
    CommandOnly :: DarcsCommand parsedFlags -> CommandArgs
    SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs
    SuperCommandSub :: DarcsCommand parsedFlags1 ->  DarcsCommand parsedFlags2 -> CommandArgs

-- Parses a darcs command line with potentially abbreviated commands
disambiguateCommands :: [CommandControl] -> String -> [String]
                     -> Either String (CommandArgs, [String])
disambiguateCommands :: [CommandControl]
-> String -> [String] -> Either String (CommandArgs, [String])
disambiguateCommands allcs :: [CommandControl]
allcs cmd :: String
cmd args :: [String]
args = do
    WrappedCommand c :: DarcsCommand parsedFlags
c <- String -> [CommandControl] -> Either String WrappedCommand
extract String
cmd [CommandControl]
allcs
    case (DarcsCommand parsedFlags -> [CommandControl]
forall parsedFlags. DarcsCommand parsedFlags -> [CommandControl]
getSubcommands DarcsCommand parsedFlags
c, [String]
args) of
        ([], _) -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand parsedFlags -> CommandArgs
forall parsedFlags. DarcsCommand parsedFlags -> CommandArgs
CommandOnly DarcsCommand parsedFlags
c, [String]
args)
        (_, []) -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand parsedFlags -> CommandArgs
forall parsedFlags. DarcsCommand parsedFlags -> CommandArgs
SuperCommandOnly DarcsCommand parsedFlags
c, [String]
args)
        (subcs :: [CommandControl]
subcs, a :: String
a : as :: [String]
as) -> case String -> [CommandControl] -> Either String WrappedCommand
extract String
a [CommandControl]
subcs of
                               Left _ -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand parsedFlags -> CommandArgs
forall parsedFlags. DarcsCommand parsedFlags -> CommandArgs
SuperCommandOnly DarcsCommand parsedFlags
c, [String]
args)
                               Right (WrappedCommand sc :: DarcsCommand parsedFlags
sc) -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand parsedFlags -> DarcsCommand parsedFlags -> CommandArgs
forall parsedFlags1 parsedFlags2.
DarcsCommand parsedFlags1
-> DarcsCommand parsedFlags2 -> CommandArgs
SuperCommandSub DarcsCommand parsedFlags
c DarcsCommand parsedFlags
sc, [String]
as)

extract :: String -> [CommandControl] -> Either String WrappedCommand
extract :: String -> [CommandControl] -> Either String WrappedCommand
extract cmd :: String
cmd cs :: [CommandControl]
cs = case [WrappedCommand]
potentials of
    []  -> String -> Either String WrappedCommand
forall a b. a -> Either a b
Left (String -> Either String WrappedCommand)
-> String -> Either String WrappedCommand
forall a b. (a -> b) -> a -> b
$ "No such command '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'\n"
    [c :: WrappedCommand
c] -> WrappedCommand -> Either String WrappedCommand
forall a b. b -> Either a b
Right WrappedCommand
c
    cs' :: [WrappedCommand]
cs' -> String -> Either String WrappedCommand
forall a b. a -> Either a b
Left (String -> Either String WrappedCommand)
-> String -> Either String WrappedCommand
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ "Ambiguous command..."
                          , ""
                          , "The command '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' could mean one of:"
                          , [String] -> String
unwords ([String] -> String)
-> ([WrappedCommand] -> [String]) -> [WrappedCommand] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([WrappedCommand] -> [String]) -> [WrappedCommand] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WrappedCommand -> String) -> [WrappedCommand] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map WrappedCommand -> String
wrappedCommandName ([WrappedCommand] -> String) -> [WrappedCommand] -> String
forall a b. (a -> b) -> a -> b
$ [WrappedCommand]
cs'
                          ]
  where
    potentials :: [WrappedCommand]
potentials = [WrappedCommand
c | WrappedCommand
c <- [CommandControl] -> [WrappedCommand]
extractCommands [CommandControl]
cs, String
cmd String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` WrappedCommand -> String
wrappedCommandName WrappedCommand
c]
                 [WrappedCommand] -> [WrappedCommand] -> [WrappedCommand]
forall a. [a] -> [a] -> [a]
++ [WrappedCommand
h | WrappedCommand
h <- [CommandControl] -> [WrappedCommand]
extractHiddenCommands [CommandControl]
cs, String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== WrappedCommand -> String
wrappedCommandName WrappedCommand
h]

putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose flags :: [DarcsFlag]
flags = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
verbose [DarcsFlag]
flags) (IO () -> IO ()) -> (Doc -> IO ()) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters

putInfo :: [DarcsFlag] -> Doc -> IO ()
putInfo :: [DarcsFlag] -> Doc -> IO ()
putInfo flags :: [DarcsFlag]
flags = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DarcsFlag] -> Bool
quiet [DarcsFlag]
flags) (IO () -> IO ()) -> (Doc -> IO ()) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters

putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning flags :: [DarcsFlag]
flags = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DarcsFlag] -> Bool
quiet [DarcsFlag]
flags) (IO () -> IO ()) -> (Doc -> IO ()) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Doc -> IO ()
hPutDocLn Handle
stderr

putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
putVerboseWarning flags :: [DarcsFlag]
flags = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
verbose [DarcsFlag]
flags) (IO () -> IO ()) -> (Doc -> IO ()) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Doc -> IO ()
hPutDocLn Handle
stderr

abortRun :: [DarcsFlag] -> Doc -> IO ()
abortRun :: [DarcsFlag] -> Doc -> IO ()
abortRun flags :: [DarcsFlag]
flags msg :: Doc
msg = if (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a DryRun)
-> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
dryRun [DarcsFlag]
flags DryRun -> DryRun -> Bool
forall a. Eq a => a -> a -> Bool
== DryRun
YesDryRun
                        then [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
flags (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "NOTE:" Doc -> Doc -> Doc
<+> Doc
msg
                        else Doc -> IO ()
forall a. Doc -> a
errorDoc Doc
msg

-- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with
-- info about the given patches, for use in post-hooks.
setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree)
                   => FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches :: FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches ps :: FL (PatchInfoAnd rt p) wX wY
ps = do
    let k :: String
k = "Defining set of chosen patches"
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ("setEnvDarcsPatches:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: FL (PatchInfoAnd rt p) wX wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PatchInfoAnd rt p) wX wY
ps)
    String -> IO ()
beginTedious String
k
    String -> Int -> IO ()
tediousSize String
k 3
    String -> String -> IO ()
finishedOneIO String
k "DARCS_PATCHES"
    String -> String -> IO ()
setEnvCautiously "DARCS_PATCHES" (Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
Darcs.Patch.summary FL (PatchInfoAnd rt p) wX wY
ps)
    String -> String -> IO ()
finishedOneIO String
k "DARCS_PATCHES_XML"
    String -> String -> IO ()
setEnvCautiously "DARCS_PATCHES_XML" (String -> IO ()) -> (Doc -> String) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
renderString (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> Doc
text "<patches>" Doc -> Doc -> Doc
$$
        [Doc] -> Doc
vcat ((forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc)
-> FL (PatchInfoAnd rt p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (PatchInfo -> Doc
toXml (PatchInfo -> Doc)
-> (PatchInfoAnd rt p wW wZ -> PatchInfo)
-> PatchInfoAnd rt p wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info) FL (PatchInfoAnd rt p) wX wY
ps) Doc -> Doc -> Doc
$$
        String -> Doc
text "</patches>"
    String -> String -> IO ()
finishedOneIO String
k "DARCS_FILES"
    String -> String -> IO ()
setEnvCautiously "DARCS_FILES" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (FL (PatchInfoAnd rt p) wX wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PatchInfoAnd rt p) wX wY
ps)
    String -> IO ()
endTedious String
k

-- | Set the DARCS_FILES environment variable to the files touched by the
-- given patch, one per line, for use in post-hooks.
setEnvDarcsFiles :: (PatchInspect p) => p wX wY -> IO ()
setEnvDarcsFiles :: p wX wY -> IO ()
setEnvDarcsFiles ps :: p wX wY
ps =
    String -> String -> IO ()
setEnvCautiously "DARCS_FILES" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (p wX wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles p wX wY
ps)

-- | Set some environment variable to the given value, unless said value is
-- longer than 10K characters, in which case do nothing.
setEnvCautiously :: String -> String -> IO ()
setEnvCautiously :: String -> String -> IO ()
setEnvCautiously e :: String
e v :: String
v
    | Int -> String -> Bool
forall a. Int -> [a] -> Bool
toobig (10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1024) String
v = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise =
        String -> String -> IO ()
setEnv String
e String
v IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\_ -> String -> String -> IO ()
setEnv String
e (ByteString -> String
decodeLocale (String -> ByteString
packStringToUTF8 String
v)))
  where
    -- note: not using (length v) because we want to be more lazy than that
    toobig :: Int -> [a] -> Bool
    toobig :: Int -> [a] -> Bool
toobig 0 _ = Bool
True
    toobig _ [] = Bool
False
    toobig n :: Int
n (_ : xs :: [a]
xs) = Int -> [a] -> Bool
forall a. Int -> [a] -> Bool
toobig (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [a]
xs

defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo fs :: [DarcsFlag]
fs = RemoteRepos -> AbsolutePath -> [String] -> IO [String]
defaultrepo (PrimDarcsOption RemoteRepos
remoteRepos PrimDarcsOption RemoteRepos -> [DarcsFlag] -> RemoteRepos
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs)

amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
amInHashedRepository fs :: [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.amInHashedRepository (PrimDarcsOption WorkRepo
workRepo PrimDarcsOption WorkRepo -> [DarcsFlag] -> WorkRepo
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs)

amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository fs :: [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.amInRepository (PrimDarcsOption WorkRepo
workRepo PrimDarcsOption WorkRepo -> [DarcsFlag] -> WorkRepo
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs)

amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository fs :: [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.amNotInRepository (PrimDarcsOption WorkRepo
workRepo PrimDarcsOption WorkRepo -> [DarcsFlag] -> WorkRepo
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs)

findRepository :: [DarcsFlag] -> IO (Either String ())
findRepository :: [DarcsFlag] -> IO (Either String ())
findRepository fs :: [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.findRepository (PrimDarcsOption WorkRepo
workRepo PrimDarcsOption WorkRepo -> [DarcsFlag] -> WorkRepo
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs)