diff options
| -rw-r--r-- | CmdLine.hs | 4 | ||||
| -rw-r--r-- | CmdLine/GitAnnex.hs | 2 | ||||
| -rw-r--r-- | CmdLine/GitAnnex/Options.hs | 72 | ||||
| -rw-r--r-- | CmdLine/GitAnnexShell.hs | 11 | ||||
| -rw-r--r-- | CmdLine/Option.hs | 68 | ||||
| -rw-r--r-- | Types/DeferredParse.hs | 13 |
6 files changed, 102 insertions, 68 deletions
diff --git a/CmdLine.hs b/CmdLine.hs index 5114bc984..7d90a25ce 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -33,8 +33,8 @@ import Command import Types.Messages {- Runs the passed command line. -} -dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () -dispatch fuzzyok allargs allcmds commonoptions fields getgitrepo progname progdesc = do +dispatch :: Bool -> CmdParams -> [Command] -> Parser GlobalSetter -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do setupConsole go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) where diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 2e9bc537f..32a4b8b10 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -227,7 +227,7 @@ run args = do #endif go envmodes where - go [] = dispatch True args cmds gitAnnexOptions [] Git.CurrentRepo.get + go [] = dispatch True args cmds gitAnnexGlobalOptions [] Git.CurrentRepo.get "git-annex" "manage files with git, without checking their contents in" go ((v, a):rest) = maybe (go rest) a =<< getEnv v diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 4ec7bc875..8bc96a14d 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -19,6 +19,7 @@ import Types.Messages import Types.Key import Types.Command import Types.DeferredParse +import Types.DesktopNotify import qualified Annex import qualified Remote import qualified Limit @@ -26,34 +27,55 @@ import qualified Limit.Wanted import CmdLine.Option import CmdLine.Usage --- Options that are accepted by all git-annex sub-commands, +-- Global options that are accepted by all git-annex sub-commands, -- although not always used. -gitAnnexOptions :: [Option] -gitAnnexOptions = commonOptions ++ - [ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber) - "override default number of copies" - , Option [] ["trust"] (trustArg Trusted) - "override trust setting" - , Option [] ["semitrust"] (trustArg SemiTrusted) - "override trust setting back to default" - , Option [] ["untrust"] (trustArg UnTrusted) - "override trust setting to untrusted" - , Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE") - "override git configuration setting" - , Option [] ["user-agent"] (ReqArg setuseragent paramName) - "override default User-Agent" - , Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) - "Trust Amazon Glacier inventory" +gitAnnexGlobalOptions :: Parser GlobalSetter +gitAnnexGlobalOptions = globalSetters + [ commonGlobalOptions + , globalSetter setnumcopies $ option auto + ( long "numcopies" <> short 'N' <> metavar paramNumber + <> help "override default number of copies" + ) + , globalSetter (Remote.forceTrust Trusted) $ strOption + ( long "trust" <> metavar paramRemote + <> help "override trust setting" + ) + , globalSetter (Remote.forceTrust SemiTrusted) $ strOption + ( long "semitrust" <> metavar paramRemote + <> help "override trust setting back to default" + ) + , globalSetter (Remote.forceTrust UnTrusted) $ strOption + ( long "untrust" <> metavar paramRemote + <> help "override trust setting to untrusted" + ) + , globalSetter setgitconfig $ strOption + ( long "config" <> short 'c' <> metavar "NAME=VALUE" + <> help "override git configuration setting" + ) + , globalSetter setuseragent $ strOption + ( long "user-agent" <> metavar paramName + <> help "override default User-Agent" + ) + , globalFlag (Annex.setFlag "trustglacier") + ( long "trust-glacier" + <> help "Trust Amazon Glacier inventory" + ) + , globalFlag (setdesktopnotify mkNotifyFinish) + ( long "notify-finish" + <> help "show desktop notification after transfer finishes" + ) + , globalFlag (setdesktopnotify mkNotifyStart) + ( long "notify-start" + <> help "show desktop notification after transfer completes" + ) ] where - trustArg t = ReqArg (Remote.forceTrust t) paramRemote - setnumcopies v = maybe noop - (\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }) - (readish v) + setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } setgitconfig v = inRepo (Git.Config.store v) >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo + setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p @@ -177,13 +199,11 @@ parseCombiningOptions = <|> shortopt '(' "open group of options" <|> shortopt ')' "close group of options" where - longopt o h = globalOpt (Limit.addToken o) $ switch - ( long o <> help h ) - shortopt o h = globalOpt (Limit.addToken [o]) $ switch - ( short o <> help h) + longopt o h = globalFlag (Limit.addToken o) ( long o <> help h ) + shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h) parseJsonOption :: Parser GlobalSetter -parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch +parseJsonOption = globalFlag (Annex.setOutput JSONOutput) ( long "json" <> short 'j' <> help "enable JSON output" ) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 386780add..5bc297a71 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -8,7 +8,6 @@ module CmdLine.GitAnnexShell where import System.Environment -import System.Console.GetOpt import Common.Annex import qualified Git.Construct @@ -54,9 +53,13 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly where adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } -options :: [OptDescr (Annex ())] -options = commonOptions ++ - [ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid" +options :: Parser GlobalSetter +options = globalSetters + [ commonGlobalOptions + , globalSetter checkUUID $ strOption + ( long "uuid" <> metavar paramUUID + <> help "local repository uuid" + ) ] where checkUUID expected = getUUID >>= check diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 0cda34ba1..9cb1d41d4 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -6,7 +6,7 @@ -} module CmdLine.Option ( - commonOptions, + commonGlobalOptions, flagOption, fieldOption, optionName, @@ -15,35 +15,46 @@ module CmdLine.Option ( OptDescr(..), ) where +import Options.Applicative import System.Console.GetOpt import Common.Annex +import CmdLine.Usage import qualified Annex import Types.Messages -import Types.DesktopNotify -import CmdLine.Usage +import Types.DeferredParse --- Options accepted by both git-annex and git-annex-shell sub-commands. -commonOptions :: [Option] -commonOptions = - [ Option [] ["force"] (NoArg (setforce True)) - "allow actions that may lose annexed data" - , Option ['F'] ["fast"] (NoArg (setfast True)) - "avoid slow operations" - , Option ['q'] ["quiet"] (NoArg (Annex.setOutput QuietOutput)) - "avoid verbose output" - , Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput)) - "allow verbose output (default)" - , Option ['d'] ["debug"] (NoArg setdebug) - "show debug messages" - , Option [] ["no-debug"] (NoArg unsetdebug) - "don't show debug messages" - , Option ['b'] ["backend"] (ReqArg setforcebackend paramName) - "specify key-value backend to use" - , Option [] ["notify-finish"] (NoArg (setdesktopnotify mkNotifyFinish)) - "show desktop notification after transfer finishes" - , Option [] ["notify-start"] (NoArg (setdesktopnotify mkNotifyStart)) - "show desktop notification after transfer completes" +-- Global options accepted by both git-annex and git-annex-shell sub-commands. +commonGlobalOptions :: Parser GlobalSetter +commonGlobalOptions = globalSetters + [ globalFlag (setforce True) + ( long "force" + <> help "allow actions that may lose annexed data" + ) + , globalFlag (setfast True) + ( long "fast" <> short 'F' + <> help "avoid slow operations" + ) + , globalFlag (Annex.setOutput QuietOutput) + ( long "quiet" <> short 'q' + <> help "avoid verbose output" + ) + , globalFlag (Annex.setOutput NormalOutput) + ( long "verbose" <> short 'v' + <> help "allow verbose output (default)" + ) + , globalFlag setdebug + ( long "debug" <> short 'd' + <> help "show debug messages" + ) + , globalFlag unsetdebug + ( long "no-debug" + <> help "don't show debug messages" + ) + , globalSetter setforcebackend $ strOption + ( long "backend" <> short 'b' <> metavar paramName + <> help "specify key-value backend to use" + ) ] where setforce v = Annex.changeState $ \s -> s { Annex.force = v } @@ -51,17 +62,16 @@ commonOptions = setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } - setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } {- An option that sets a flag. -} flagOption :: String -> String -> String -> Option -flagOption short opt description = - Option short [opt] (NoArg (Annex.setFlag opt)) description +flagOption shortv opt description = + Option shortv [opt] (NoArg (Annex.setFlag opt)) description {- An option that sets a field. -} fieldOption :: String -> String -> String -> String -> Option -fieldOption short opt paramdesc description = - Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description +fieldOption shortv opt paramdesc description = + Option shortv [opt] (ReqArg (Annex.setField opt) paramdesc) description {- The flag or field name used for an option. -} optionName :: Option -> String diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 4b5ee6d59..4c6e90175 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -12,7 +12,7 @@ module Types.DeferredParse where import Annex import Common -import Options.Applicative.Types +import Options.Applicative -- Some values cannot be fully parsed without performing an action. -- The action may be expensive, so it's best to call finishParse on such a @@ -40,11 +40,12 @@ instance DeferredParseClass [DeferredParse a] where -- Use when the Annex action modifies Annex state. type GlobalSetter = DeferredParse () -globalOpt :: Annex () -> Parser Bool -> Parser GlobalSetter -globalOpt setter parser = go <$> parser - where - go False = ReadyParse () - go True = DeferredParse setter +globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> Parser GlobalSetter +globalFlag setter = flag' (DeferredParse setter) globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter globalSetter setter parser = DeferredParse . setter <$> parser + +globalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter +globalSetters l = DeferredParse . sequence_ . map getParsed + <$> many (foldl1 (<|>) l) |