{-# 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
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
data DarcsCommand parsedFlags =
DarcsCommand
{ DarcsCommand parsedFlags -> String
commandProgramName
, 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 ::
(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, [])
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
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
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
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
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)
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
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)