--  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(..)
    , commandAlias
    , commandStub
    , withStdOpts
    , commandOptDescr
    , commandAlloptions
    , commandDefaults
    , commandCheckOptions
    , disambiguateCommands
    , CommandArgs(..)
    , getSubcommands
    , extractCommands
    , extractAllCommands
    , normalCommand
    , hiddenCommand
    , commandGroup
    , superName
    , nodefaults
    , putInfo
    , putVerbose
    , putWarning
    , putVerboseWarning
    , putFinished
    , abortRun
    , setEnvDarcsPatches
    , setEnvDarcsFiles
    , defaultRepo
    , amInHashedRepository
    , amInRepository
    , amNotInRepository
    , findRepository
    ) where

import Control.Monad ( when, unless )
import Data.List ( sort, isPrefixOf )
import Data.Maybe ( maybeToList )
import System.Console.GetOpt ( OptDescr )
import System.IO ( stderr )
import System.IO.Error ( catchIOError )
import System.Environment ( setEnv )

import Darcs.Prelude

import Darcs.Patch ( listTouchedFiles )
import Darcs.Patch ( RepoPatch )
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.Flags ( WorkRepo(..) )
import Darcs.Repository.Prefs ( getDefaultRepo )

import Darcs.UI.Options
    ( DarcsOptDescr
    , DarcsOption
    , OptMsg
    , defaultFlags
    , ocheck
    , odesc
    , optDescr
    , parseFlags
    , (?)
    , (^)
    )
import Darcs.UI.Options.All
    ( StdCmdAction, stdCmdActions, debugging, UseCache, useCache, HooksConfig, hooks
    , Verbosity(..), DryRun(..), dryRun, newRepo, verbosity, UseIndex, useIndex, yes
    )

import Darcs.UI.Flags ( DarcsFlag, workRepo, quiet, verbose )
import Darcs.UI.External ( viewDoc )
import Darcs.UI.PrintPatch ( showWithSummary )

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

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

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

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

normalCommand :: DarcsCommand -> CommandControl
normalCommand :: DarcsCommand -> CommandControl
normalCommand DarcsCommand
c = DarcsCommand -> CommandControl
CommandData DarcsCommand
c

hiddenCommand :: DarcsCommand -> CommandControl
hiddenCommand :: DarcsCommand -> CommandControl
hiddenCommand DarcsCommand
c = DarcsCommand -> CommandControl
HiddenCommand DarcsCommand
c

commandGroup :: String -> CommandControl
commandGroup :: [Char] -> CommandControl
commandGroup = [Char] -> CommandControl
GroupName

data CommandControl
  = CommandData DarcsCommand
  | HiddenCommand DarcsCommand
  | GroupName String

-- |A 'DarcsCommand' represents a command like add, record etc.
data DarcsCommand =
      DarcsCommand
          { DarcsCommand -> [Char]
commandProgramName -- programs that use libdarcs can change the name here
          , DarcsCommand -> [Char]
commandName :: String
          , DarcsCommand -> Doc
commandHelp :: Doc
          , DarcsCommand -> [Char]
commandDescription :: String
          , DarcsCommand -> Int
commandExtraArgs :: Int
          , DarcsCommand -> [[Char]]
commandExtraArgHelp :: [String]
          , DarcsCommand
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [[Char]] -> IO ()
commandCommand :: -- First 'AbsolutePath' is the repository path,
                              -- second one is the path where darcs was executed.
                              (AbsolutePath, AbsolutePath)
                           -> [DarcsFlag] -> [String] -> IO ()
          , DarcsCommand -> [DarcsFlag] -> IO (Either [Char] ())
commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [[Char]]
-> IO [[Char]]
commandCompleteArgs :: (AbsolutePath, AbsolutePath)
                                -> [DarcsFlag] -> [String] -> IO [String]
          , DarcsCommand
-> [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]
                               -> IO [String]
          , DarcsCommand -> CommandOptions
commandOptions :: CommandOptions
          }
    | SuperCommand
          { commandProgramName
          , commandName :: String
          , commandHelp :: Doc
          , commandDescription :: String
          , commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand -> [CommandControl]
commandSubCommands :: [CommandControl]
          }

data CommandOptions = CommandOptions
  { CommandOptions -> [DarcsOptDescr DarcsFlag]
coBasicOptions :: [DarcsOptDescr DarcsFlag]
  , CommandOptions -> [DarcsOptDescr DarcsFlag]
coAdvancedOptions :: [DarcsOptDescr DarcsFlag]
  , CommandOptions -> [DarcsFlag]
coDefaults :: [DarcsFlag]
  , CommandOptions -> [DarcsFlag] -> [OptMsg]
coCheckOptions :: [DarcsFlag] -> [OptMsg]
  }

-- | Construct 'CommandOptions' from the command specific basic and advanced
-- 'DarcsOption's
withStdOpts
  :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
  -> DarcsOption
      (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag]) b
  -> CommandOptions
withStdOpts :: forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
withStdOpts DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
bopts DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  b
aopts =
  CommandOptions
    { coBasicOptions :: [DarcsOptDescr DarcsFlag]
coBasicOptions = OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
bopts'
    , coAdvancedOptions :: [DarcsOptDescr DarcsFlag]
coAdvancedOptions = OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Verbosity -> b)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Verbosity -> b)
aopts'
    , coDefaults :: [DarcsFlag]
coDefaults = OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
opts
    , coCheckOptions :: [DarcsFlag] -> [OptMsg]
coCheckOptions = OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
-> [DarcsFlag] -> [OptMsg]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [OptMsg]
ocheck OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
opts
    }
  where
    aopts' :: OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Verbosity -> b)
aopts' = PrimOptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag b Verbosity
PrimDarcsOption Verbosity
verbosity PrimOptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag b Verbosity
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (Verbosity -> b)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  b
aopts OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (Verbosity -> b)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
PrimDarcsOption UseCache
useCache OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (Verbosity -> b)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
PrimDarcsOption UseIndex
useIndex OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (Bool -> Bool -> [DarcsFlag])
     (HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (Bool -> Bool -> [DarcsFlag])
     (Verbosity -> b)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (Bool -> Bool -> [DarcsFlag])
  (HooksConfig -> Bool -> Bool -> [DarcsFlag])
forall a. DarcsOption a (HooksConfig -> a)
hooks OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (Bool -> Bool -> [DarcsFlag])
  (Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     [DarcsFlag]
     (Bool -> Bool -> [DarcsFlag])
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     [DarcsFlag]
     (Verbosity -> b)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Bool -> Bool -> [DarcsFlag])
forall a. DarcsOption a (Bool -> Bool -> a)
debugging
    bopts' :: OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
bopts' = DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
bopts DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     (Verbosity -> b)
     (Maybe StdCmdAction -> Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  (Verbosity -> b)
  (Maybe StdCmdAction -> Verbosity -> b)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions
    opts :: OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
opts = OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
bopts' OptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag (Verbosity -> b) c
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath))
     DarcsFlag
     [DarcsFlag]
     (Verbosity -> b)
-> OptSpec
     (Compose OptDescr ((->) AbsolutePath)) DarcsFlag [DarcsFlag] c
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Verbosity -> b)
aopts'

-- | For the given 'DarcsCommand' check the given 'DarcsFlag's for
-- consistency
commandCheckOptions :: DarcsCommand -> [DarcsFlag] -> [OptMsg]
commandCheckOptions :: DarcsCommand -> [DarcsFlag] -> [OptMsg]
commandCheckOptions DarcsCommand {commandOptions :: DarcsCommand -> CommandOptions
commandOptions=CommandOptions
co} = CommandOptions -> [DarcsFlag] -> [OptMsg]
coCheckOptions CommandOptions
co
commandCheckOptions SuperCommand {} = OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  Any
  (Maybe StdCmdAction -> Any)
-> [DarcsFlag] -> [OptMsg]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [OptMsg]
ocheck OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  Any
  (Maybe StdCmdAction -> Any)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions

-- | Built-in default values for all 'DarcsFlag's supported by the given
-- command
commandDefaults :: DarcsCommand -> [DarcsFlag]
commandDefaults :: DarcsCommand -> [DarcsFlag]
commandDefaults DarcsCommand {commandOptions :: DarcsCommand -> CommandOptions
commandOptions=CommandOptions
co} = CommandOptions -> [DarcsFlag]
coDefaults CommandOptions
co
commandDefaults SuperCommand {} = OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Maybe StdCmdAction -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  [DarcsFlag]
  (Maybe StdCmdAction -> [DarcsFlag])
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions

-- | Option descriptions split into basic and advanced options
commandAlloptions :: DarcsCommand
                  -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions :: DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand {commandOptions :: DarcsCommand -> CommandOptions
commandOptions = CommandOptions
co} =
  (CommandOptions -> [DarcsOptDescr DarcsFlag]
coBasicOptions CommandOptions
co, CommandOptions -> [DarcsOptDescr DarcsFlag]
coAdvancedOptions CommandOptions
co)
commandAlloptions SuperCommand {} = (OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  Any
  (Maybe StdCmdAction -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  (Compose OptDescr ((->) AbsolutePath))
  DarcsFlag
  Any
  (Maybe StdCmdAction -> Any)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions, [])

-- | Option descriptions as required by 'System.Console.Getopt.getOpt',
-- i.e. resolved with the given 'AbsolutePath'.
commandOptDescr :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]
commandOptDescr :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]
commandOptDescr 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 -> [DarcsOptDescr DarcsFlag])
-> DarcsCommand
-> [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
    -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag]))
-> DarcsCommand
-> [DarcsOptDescr DarcsFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions

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

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

commandAlias :: String -> Maybe (DarcsCommand) -> DarcsCommand -> DarcsCommand
commandAlias :: [Char] -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias [Char]
alias Maybe DarcsCommand
msuper DarcsCommand
command =
  DarcsCommand
command
    { commandName = alias
    , commandDescription = "Alias for `" ++ prog ++ " " ++ cmdName ++ "'."
    , commandHelp =
        hsep
          [ "The"
          , "`" <> text prog <+> text alias <> "`"
          , "command is an alias for"
          , "`" <> text prog <+> text cmdName <> "`"
          ]
        $+$ "See description of `" <> text prog <+> text cmdName <> "` for details."
    }
  where
    prog :: [Char]
prog = DarcsCommand -> [Char]
commandProgramName DarcsCommand
command
    cmdName :: [Char]
cmdName = [[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> ([DarcsCommand] -> [[Char]]) -> [DarcsCommand] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DarcsCommand -> [Char]) -> [DarcsCommand] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DarcsCommand -> [Char]
commandName ([DarcsCommand] -> [[Char]])
-> ([DarcsCommand] -> [DarcsCommand]) -> [DarcsCommand] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DarcsCommand] -> [DarcsCommand])
-> (DarcsCommand -> [DarcsCommand] -> [DarcsCommand])
-> Maybe DarcsCommand
-> [DarcsCommand]
-> [DarcsCommand]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [DarcsCommand] -> [DarcsCommand]
forall a. a -> a
id (:) Maybe DarcsCommand
msuper ([DarcsCommand] -> [Char]) -> [DarcsCommand] -> [Char]
forall a b. (a -> b) -> a -> b
$ [DarcsCommand
command]

commandStub :: String -> Doc -> String -> DarcsCommand -> DarcsCommand
commandStub :: [Char] -> Doc -> [Char] -> DarcsCommand -> DarcsCommand
commandStub [Char]
n Doc
h [Char]
d command :: DarcsCommand
command@DarcsCommand {} =
  DarcsCommand
command
    { commandName = n
    , commandHelp = h
    , commandDescription = d
    , commandCommand = \(AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [[Char]]
_ -> Doc -> IO ()
viewDoc Doc
h
    }
commandStub [Char]
_ Doc
_ [Char]
_ SuperCommand {} =
  [Char] -> DarcsCommand
forall a. HasCallStack => [Char] -> a
error [Char]
"commandStub called with SuperCommand argument"

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

data CommandArgs
  = CommandOnly DarcsCommand
  | SuperCommandOnly DarcsCommand
  | SuperCommandSub DarcsCommand DarcsCommand

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

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

putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose [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 [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

putFinished :: [DarcsFlag] -> String -> IO ()
putFinished :: [DarcsFlag] -> [Char] -> IO ()
putFinished [DarcsFlag]
flags [Char]
what =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DryRun -> Bool
forall a. YesNo a => a -> Bool
yes (PrimOptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag a DryRun
PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
flags (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Finished" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
what Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."

putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning [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
. Doc -> IO ()
ePutDocLn

putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
putVerboseWarning [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 [DarcsFlag]
flags Doc
msg = if PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag a DryRun
PrimDarcsOption 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
$ Doc
"NOTE:" Doc -> Doc -> Doc
<+> Doc
msg
                        else [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString 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 => FL (PatchInfoAnd p) wX wY -> IO ()
setEnvDarcsPatches :: forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
FL (PatchInfoAnd p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd p) wX wY
ps = do
    let k :: [Char]
k = [Char]
"Defining set of chosen patches"
    let filepaths :: [[Char]]
filepaths = (AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> AnchoredPath -> [Char]
anchorPath [Char]
".") (FL (PatchInfoAnd p) wX wY -> [AnchoredPath]
forall wX wY. FL (PatchInfoAnd p) wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PatchInfoAnd p) wX wY
ps)
    [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([Char]
"setEnvDarcsPatches:" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
filepaths)
    [Char] -> IO ()
beginTedious [Char]
k
    [Char] -> Int -> IO ()
tediousSize [Char]
k Int
3
    [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k [Char]
"DARCS_PATCHES"
    [Char] -> [Char] -> IO ()
setEnvCautiously [Char]
"DARCS_PATCHES" (Doc -> [Char]
renderString (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
showWithSummary FL (PatchInfoAnd p) wX wY
ps)
    [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k [Char]
"DARCS_PATCHES_XML"
    [Char] -> [Char] -> IO ()
setEnvCautiously [Char]
"DARCS_PATCHES_XML" ([Char] -> IO ()) -> (Doc -> [Char]) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Char]
renderString (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> Doc
text [Char]
"<patches>" Doc -> Doc -> Doc
$$
        [Doc] -> Doc
vcat ((forall wW wZ. PatchInfoAnd p wW wZ -> Doc)
-> FL (PatchInfoAnd 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 p wW wZ -> PatchInfo)
-> PatchInfoAnd p wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info) FL (PatchInfoAnd p) wX wY
ps) Doc -> Doc -> Doc
$$
        [Char] -> Doc
text [Char]
"</patches>"
    [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k [Char]
"DARCS_FILES"
    [Char] -> [Char] -> IO ()
setEnvCautiously [Char]
"DARCS_FILES" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
filepaths
    [Char] -> IO ()
endTedious [Char]
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 :: forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setEnvDarcsFiles p wX wY
ps = do
    let filepaths :: [[Char]]
filepaths = (AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> AnchoredPath -> [Char]
anchorPath [Char]
".") (p wX wY -> [AnchoredPath]
forall wX wY. p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wX wY
ps)
    [Char] -> [Char] -> IO ()
setEnvCautiously [Char]
"DARCS_FILES" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
filepaths

-- | Set some environment variable to the given value, unless said value is
-- longer than 100K characters, in which case do nothing.
setEnvCautiously :: String -> String -> IO ()
setEnvCautiously :: [Char] -> [Char] -> IO ()
setEnvCautiously [Char]
e [Char]
v
    | Int -> [Char] -> Bool
forall a. Int -> [a] -> Bool
toobig (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024) [Char]
v =
        Handle -> Doc -> IO ()
hPutDocLn Handle
stderr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
          [Char]
"Warning: not setting env var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (would exceed 100K)"
    | Bool
otherwise =
        [Char] -> [Char] -> IO ()
setEnv [Char]
e [Char]
v IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
_ -> [Char] -> [Char] -> IO ()
setEnv [Char]
e (ByteString -> [Char]
decodeLocale ([Char] -> ByteString
packStringToUTF8 [Char]
v)))
  where
    -- note: not using (length v) because we want to be more lazy than that
    toobig :: Int -> [a] -> Bool
    toobig :: forall a. Int -> [a] -> Bool
toobig Int
0 [a]
_ = Bool
True
    toobig Int
_ [] = Bool
False
    toobig Int
n (a
_ : [a]
xs) = Int -> [a] -> Bool
forall a. Int -> [a] -> Bool
toobig (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs

-- | To use for commandArgdefaults field.
defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo :: [DarcsFlag] -> AbsolutePath -> [[Char]] -> IO [[Char]]
defaultRepo [DarcsFlag]
_ AbsolutePath
_ [] = Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Char] -> [[Char]]) -> IO (Maybe [Char]) -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe [Char])
getDefaultRepo
defaultRepo [DarcsFlag]
_ AbsolutePath
_ [[Char]]
args = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]]
args

amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
amInHashedRepository :: [DarcsFlag] -> IO (Either [Char] ())
amInHashedRepository [DarcsFlag]
fs = WorkRepo -> IO (Either [Char] ())
R.amInHashedRepository ([DarcsFlag] -> WorkRepo
workRepo [DarcsFlag]
fs)

amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository :: [DarcsFlag] -> IO (Either [Char] ())
amInRepository [DarcsFlag]
fs = WorkRepo -> IO (Either [Char] ())
R.amInRepository ([DarcsFlag] -> WorkRepo
workRepo [DarcsFlag]
fs)

amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository :: [DarcsFlag] -> IO (Either [Char] ())
amNotInRepository [DarcsFlag]
fs =
  WorkRepo -> IO (Either [Char] ())
R.amNotInRepository (WorkRepo -> ([Char] -> WorkRepo) -> Maybe [Char] -> WorkRepo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WorkRepo
WorkRepoCurrentDir [Char] -> WorkRepo
WorkRepoDir (PrimOptSpec
  (Compose OptDescr ((->) AbsolutePath)) DarcsFlag a (Maybe [Char])
PrimDarcsOption (Maybe [Char])
newRepo PrimDarcsOption (Maybe [Char]) -> [DarcsFlag] -> Maybe [Char]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
fs))

findRepository :: [DarcsFlag] -> IO (Either String ())
findRepository :: [DarcsFlag] -> IO (Either [Char] ())
findRepository [DarcsFlag]
fs = WorkRepo -> IO (Either [Char] ())
R.findRepository ([DarcsFlag] -> WorkRepo
workRepo [DarcsFlag]
fs)