--  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
    , commandOptions
    , commandAlloptions
    , withStdOpts
    , 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 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 ( defaultrepo )

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

import Darcs.UI.Flags ( DarcsFlag, remoteRepos, 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 :: String -> CommandControl
commandGroup = String -> CommandControl
GroupName

data CommandControl
  = CommandData DarcsCommand
  | HiddenCommand DarcsCommand
  | GroupName String

-- |A 'DarcsCommand' represents a command like add, record etc.
data DarcsCommand =
      DarcsCommand
          { DarcsCommand -> String
commandProgramName -- programs that use libdarcs can change the name here
          , DarcsCommand -> String
commandName :: String
          , DarcsCommand -> Doc
commandHelp :: Doc
          , DarcsCommand -> String
commandDescription :: String
          , DarcsCommand -> Int
commandExtraArgs :: Int
          , DarcsCommand -> [String]
commandExtraArgHelp :: [String]
          , DarcsCommand
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> 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 String ())
commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO [String]
commandCompleteArgs :: (AbsolutePath, AbsolutePath)
                                -> [DarcsFlag] -> [String] -> IO [String]
          , DarcsCommand
-> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]
                               -> IO [String]
          , DarcsCommand -> [DarcsOptDescr DarcsFlag]
commandBasicOptions :: [DarcsOptDescr DarcsFlag]
          , DarcsCommand -> [DarcsOptDescr DarcsFlag]
commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
          , DarcsCommand -> [DarcsFlag]
commandDefaults :: [DarcsFlag]
          , DarcsCommand -> [DarcsFlag] -> [String]
commandCheckOptions :: [DarcsFlag] -> [String]
          }
    | SuperCommand
          { commandProgramName
          , commandName :: String
          , commandHelp :: Doc
          , commandDescription :: String
          , commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , DarcsCommand -> [CommandControl]
commandSubCommands :: [CommandControl]
          }

withStdOpts :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
            -> DarcsOption (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
            -> DarcsOption a c
withStdOpts :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
withStdOpts DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
basicOpts DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
advancedOpts =
  DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
basicOpts DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Verbosity -> b)
     (Maybe StdCmdAction -> Verbosity -> b)
-> OptSpec DarcsOptDescr 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
  DarcsOptDescr
  DarcsFlag
  (Verbosity -> b)
  (Maybe StdCmdAction -> Verbosity -> b)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions OptSpec DarcsOptDescr DarcsFlag (Verbosity -> b) c
-> OptSpec DarcsOptDescr DarcsFlag b (Verbosity -> 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 (Verbosity -> b)
PrimDarcsOption Verbosity
verbosity OptSpec DarcsOptDescr DarcsFlag b c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> 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 -> Bool -> Bool -> Bool -> a) b
advancedOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  c
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (HooksConfig -> Bool -> Bool -> Bool -> 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 -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
PrimDarcsOption UseCache
useCache OptSpec
  DarcsOptDescr
  DarcsFlag
  (HooksConfig -> Bool -> Bool -> Bool -> a)
  c
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Bool -> Bool -> a)
     (HooksConfig -> Bool -> Bool -> Bool -> a)
-> OptSpec DarcsOptDescr DarcsFlag (Bool -> Bool -> Bool -> 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
  (Bool -> Bool -> Bool -> a)
  (HooksConfig -> Bool -> Bool -> Bool -> a)
forall a. DarcsOption a (HooksConfig -> a)
hooks OptSpec DarcsOptDescr DarcsFlag (Bool -> Bool -> Bool -> a) c
-> OptSpec DarcsOptDescr DarcsFlag a (Bool -> Bool -> Bool -> 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 (Bool -> Bool -> Bool -> a)
forall a. DarcsOption a (Bool -> Bool -> Bool -> a)
debugging

commandAlloptions :: DarcsCommand -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions :: DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand { commandBasicOptions :: DarcsCommand -> [DarcsOptDescr DarcsFlag]
commandBasicOptions = [DarcsOptDescr DarcsFlag]
opts1
                               , commandAdvancedOptions :: DarcsCommand -> [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 (Verbosity -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Verbosity -> Any)
PrimDarcsOption Verbosity
verbosity [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 [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag]
forall a. [a] -> [a] -> [a]
++ OptSpec DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Bool -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Bool -> Bool -> Bool -> Any)
forall a. DarcsOption a (Bool -> Bool -> Bool -> a)
debugging
    )
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 -> [OptDescr DarcsFlag]
commandOptions :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]
commandOptions 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 -> [String] -> IO [String]
nodefaults [DarcsFlag]
_ AbsolutePath
_ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return

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

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

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

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

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]
-> String -> [String] -> Either String (CommandArgs, [String])
disambiguateCommands [CommandControl]
allcs String
cmd [String]
args = do
    DarcsCommand
c <- String -> [CommandControl] -> Either String DarcsCommand
extract String
cmd [CommandControl]
allcs
    case (DarcsCommand -> [CommandControl]
getSubcommands DarcsCommand
c, [String]
args) of
        ([], [String]
_) -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand -> CommandArgs
CommandOnly DarcsCommand
c, [String]
args)
        ([CommandControl]
_, []) -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand -> CommandArgs
SuperCommandOnly DarcsCommand
c, [String]
args)
        ([CommandControl]
subcs, String
a : [String]
as) -> case String -> [CommandControl] -> Either String DarcsCommand
extract String
a [CommandControl]
subcs of
                               Left String
_ -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand -> CommandArgs
SuperCommandOnly DarcsCommand
c, [String]
args)
                               Right DarcsCommand
sc -> (CommandArgs, [String]) -> Either String (CommandArgs, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (DarcsCommand -> DarcsCommand -> CommandArgs
SuperCommandSub DarcsCommand
c DarcsCommand
sc, [String]
as)

extract :: String -> [CommandControl] -> Either String DarcsCommand
extract :: String -> [CommandControl] -> Either String DarcsCommand
extract String
cmd [CommandControl]
cs = case [DarcsCommand]
potentials of
    []  -> String -> Either String DarcsCommand
forall a b. a -> Either a b
Left (String -> Either String DarcsCommand)
-> String -> Either String DarcsCommand
forall a b. (a -> b) -> a -> b
$ String
"No such command '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
    [DarcsCommand
c] -> DarcsCommand -> Either String DarcsCommand
forall a b. b -> Either a b
Right DarcsCommand
c
    [DarcsCommand]
cs' -> String -> Either String DarcsCommand
forall a b. a -> Either a b
Left (String -> Either String DarcsCommand)
-> String -> Either String DarcsCommand
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"Ambiguous command..."
                          , String
""
                          , String
"The command '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' could mean one of:"
                          , [String] -> String
unwords ([String] -> String)
-> ([DarcsCommand] -> [String]) -> [DarcsCommand] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([DarcsCommand] -> [String]) -> [DarcsCommand] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DarcsCommand -> String) -> [DarcsCommand] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DarcsCommand -> String
commandName ([DarcsCommand] -> String) -> [DarcsCommand] -> String
forall a b. (a -> b) -> a -> b
$ [DarcsCommand]
cs'
                          ]
  where
    potentials :: [DarcsCommand]
potentials = [DarcsCommand
c | DarcsCommand
c <- [CommandControl] -> [DarcsCommand]
extractCommands [CommandControl]
cs, String
cmd String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` DarcsCommand -> String
commandName DarcsCommand
c]
                 [DarcsCommand] -> [DarcsCommand] -> [DarcsCommand]
forall a. [a] -> [a] -> [a]
++ [DarcsCommand
h | DarcsCommand
h <- [CommandControl] -> [DarcsCommand]
extractHiddenCommands [CommandControl]
cs, String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== DarcsCommand -> String
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] -> String -> IO ()
putFinished [DarcsFlag]
flags String
what =
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
flags (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Finished" Doc -> Doc -> Doc
<+> String -> Doc
text String
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 (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
$ Doc
"NOTE:" Doc -> Doc -> Doc
<+> Doc
msg
                        else String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
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 rt p) wX wY -> IO ()
setEnvDarcsPatches :: FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wX wY
ps = do
    let k :: String
k = String
"Defining set of chosen patches"
    let filepaths :: [String]
filepaths = (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath String
".") (FL (PatchInfoAnd rt p) wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles FL (PatchInfoAnd rt p) wX wY
ps)
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (String
"setEnvDarcsPatches:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
filepaths)
    String -> IO ()
beginTedious String
k
    String -> Int -> IO ()
tediousSize String
k Int
3
    String -> String -> IO ()
finishedOneIO String
k String
"DARCS_PATCHES"
    String -> String -> IO ()
setEnvCautiously String
"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
showWithSummary FL (PatchInfoAnd rt p) wX wY
ps)
    String -> String -> IO ()
finishedOneIO String
k String
"DARCS_PATCHES_XML"
    String -> String -> IO ()
setEnvCautiously String
"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 String
"<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)
-> (PatchInfoAndG rt (Named p) wW wZ -> PatchInfo)
-> PatchInfoAndG rt (Named p) wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG rt (Named p) wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info) FL (PatchInfoAnd rt p) wX wY
ps) Doc -> Doc -> Doc
$$
        String -> Doc
text String
"</patches>"
    String -> String -> IO ()
finishedOneIO String
k String
"DARCS_FILES"
    String -> String -> IO ()
setEnvCautiously String
"DARCS_FILES" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
filepaths
    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 p wX wY
ps = do
    let filepaths :: [String]
filepaths = (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath String
".") (p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wX wY
ps)
    String -> String -> IO ()
setEnvCautiously String
"DARCS_FILES" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
filepaths

-- | 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 String
e String
v
    | Int -> String -> Bool
forall a. Int -> [a] -> Bool
toobig (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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` (\IOError
_ -> 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 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

defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo [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 [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.amInHashedRepository ([DarcsFlag] -> WorkRepo
workRepo [DarcsFlag]
fs)

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

amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository [DarcsFlag]
fs =
  WorkRepo -> IO (Either String ())
R.amNotInRepository (WorkRepo -> (String -> WorkRepo) -> Maybe String -> WorkRepo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WorkRepo
WorkRepoCurrentDir String -> WorkRepo
WorkRepoDir (PrimDarcsOption (Maybe String)
newRepo PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
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 [DarcsFlag]
fs = WorkRepo -> IO (Either String ())
R.findRepository ([DarcsFlag] -> WorkRepo
workRepo [DarcsFlag]
fs)