mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

convert global options (still not used)

Browse source
This commit is contained in:
Joey Hess 2015-07-10 00:55:53 -04:00
commit adb9fddfdd
6 changed files with 102 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

4
CmdLine.hs
View file

@ -33,8 +33,8 @@ import Command
import Types.Messages import Types.Messages
{- Runs the passed command line. -} {- Runs the passed command line. -}
dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () dispatch :: Bool -> CmdParams -> [Command] -> Parser GlobalSetter -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
dispatch fuzzyok allargs allcmds commonoptions fields getgitrepo progname progdesc = do dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do
setupConsole setupConsole
go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo))
where where

2
CmdLine/GitAnnex.hs
View file

@ -227,7 +227,7 @@ run args = do
#endif #endif
go envmodes go envmodes
where where
go [] = dispatch True args cmds gitAnnexOptions [] Git.CurrentRepo.get go [] = dispatch True args cmds gitAnnexGlobalOptions [] Git.CurrentRepo.get
"git-annex" "git-annex"
"manage files with git, without checking their contents in" "manage files with git, without checking their contents in"
go ((v, a):rest) = maybe (go rest) a =<< getEnv v go ((v, a):rest) = maybe (go rest) a =<< getEnv v

72
CmdLine/GitAnnex/Options.hs
View file

@ -19,6 +19,7 @@ import Types.Messages
import Types.Key import Types.Key
import Types.Command import Types.Command
import Types.DeferredParse import Types.DeferredParse
import Types.DesktopNotify
import qualified Annex import qualified Annex
import qualified Remote import qualified Remote
import qualified Limit import qualified Limit
@ -26,34 +27,55 @@ import qualified Limit.Wanted
import CmdLine.Option import CmdLine.Option
import CmdLine.Usage 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. -- although not always used.
gitAnnexOptions :: [Option] gitAnnexGlobalOptions :: Parser GlobalSetter
gitAnnexOptions = commonOptions ++ gitAnnexGlobalOptions = globalSetters
[ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber) [ commonGlobalOptions
"override default number of copies" , globalSetter setnumcopies $ option auto
, Option [] ["trust"] (trustArg Trusted) ( long "numcopies" <> short 'N' <> metavar paramNumber
"override trust setting" <> help "override default number of copies"
, Option [] ["semitrust"] (trustArg SemiTrusted) )
"override trust setting back to default" , globalSetter (Remote.forceTrust Trusted) $ strOption
, Option [] ["untrust"] (trustArg UnTrusted) ( long "trust" <> metavar paramRemote
"override trust setting to untrusted" <> help "override trust setting"
, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE") )
"override git configuration setting" , globalSetter (Remote.forceTrust SemiTrusted) $ strOption
, Option [] ["user-agent"] (ReqArg setuseragent paramName) ( long "semitrust" <> metavar paramRemote
"override default User-Agent" <> help "override trust setting back to default"
, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) )
"Trust Amazon Glacier inventory" , 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 where
trustArg t = ReqArg (Remote.forceTrust t) paramRemote setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }
setnumcopies v = maybe noop
(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n })
(readish v)
setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v }
setgitconfig v = inRepo (Git.Config.store v) setgitconfig v = inRepo (Git.Config.store v)
>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
>>= Annex.changeGitRepo >>= Annex.changeGitRepo
setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }
parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote)
parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p
@ -177,13 +199,11 @@ parseCombiningOptions =
<|> shortopt '(' "open group of options" <|> shortopt '(' "open group of options"
<|> shortopt ')' "close group of options" <|> shortopt ')' "close group of options"
where where
longopt o h = globalOpt (Limit.addToken o) $ switch longopt o h = globalFlag (Limit.addToken o) ( long o <> help h )
( long o <> help h ) shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h)
shortopt o h = globalOpt (Limit.addToken [o]) $ switch
( short o <> help h)
parseJsonOption :: Parser GlobalSetter parseJsonOption :: Parser GlobalSetter
parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch parseJsonOption = globalFlag (Annex.setOutput JSONOutput)
( long "json" <> short 'j' ( long "json" <> short 'j'
<> help "enable JSON output" <> help "enable JSON output"
) )

11
CmdLine/GitAnnexShell.hs
View file

@ -8,7 +8,6 @@
module CmdLine.GitAnnexShell where module CmdLine.GitAnnexShell where
import System.Environment import System.Environment
import System.Console.GetOpt
import Common.Annex import Common.Annex
import qualified Git.Construct import qualified Git.Construct
@ -54,9 +53,13 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
where where
adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
options :: [OptDescr (Annex ())] options :: Parser GlobalSetter
options = commonOptions ++ options = globalSetters
[ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid" [ commonGlobalOptions
, globalSetter checkUUID $ strOption
( long "uuid" <> metavar paramUUID
<> help "local repository uuid"
)
] ]
where where
checkUUID expected = getUUID >>= check checkUUID expected = getUUID >>= check

68
CmdLine/Option.hs
View file

@ -6,7 +6,7 @@
-} -}
module CmdLine.Option ( module CmdLine.Option (
commonOptions, commonGlobalOptions,
flagOption, flagOption,
fieldOption, fieldOption,
optionName, optionName,
@ -15,35 +15,46 @@ module CmdLine.Option (
OptDescr(..), OptDescr(..),
) where ) where
import Options.Applicative
import System.Console.GetOpt import System.Console.GetOpt
import Common.Annex import Common.Annex
import CmdLine.Usage
import qualified Annex import qualified Annex
import Types.Messages import Types.Messages
import Types.DesktopNotify import Types.DeferredParse
import CmdLine.Usage
-- Options accepted by both git-annex and git-annex-shell sub-commands. -- Global options accepted by both git-annex and git-annex-shell sub-commands.
commonOptions :: [Option] commonGlobalOptions :: Parser GlobalSetter
commonOptions = commonGlobalOptions = globalSetters
[ Option [] ["force"] (NoArg (setforce True)) [ globalFlag (setforce True)
"allow actions that may lose annexed data" ( long "force"
, Option ['F'] ["fast"] (NoArg (setfast True)) <> help "allow actions that may lose annexed data"
"avoid slow operations" )
, Option ['q'] ["quiet"] (NoArg (Annex.setOutput QuietOutput)) , globalFlag (setfast True)
"avoid verbose output" ( long "fast" <> short 'F'
, Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput)) <> help "avoid slow operations"
"allow verbose output (default)" )
, Option ['d'] ["debug"] (NoArg setdebug) , globalFlag (Annex.setOutput QuietOutput)
"show debug messages" ( long "quiet" <> short 'q'
, Option [] ["no-debug"] (NoArg unsetdebug) <> help "avoid verbose output"
"don't show debug messages" )
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName) , globalFlag (Annex.setOutput NormalOutput)
"specify key-value backend to use" ( long "verbose" <> short 'v'
, Option [] ["notify-finish"] (NoArg (setdesktopnotify mkNotifyFinish)) <> help "allow verbose output (default)"
"show desktop notification after transfer finishes" )
, Option [] ["notify-start"] (NoArg (setdesktopnotify mkNotifyStart)) , globalFlag setdebug
"show desktop notification after transfer completes" ( 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 where
setforce v = Annex.changeState $ \s -> s { Annex.force = v } setforce v = Annex.changeState $ \s -> s { Annex.force = v }
@ -51,17 +62,16 @@ commonOptions =
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True }
unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } 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. -} {- An option that sets a flag. -}
flagOption :: String -> String -> String -> Option flagOption :: String -> String -> String -> Option
flagOption short opt description = flagOption shortv opt description =
Option short [opt] (NoArg (Annex.setFlag opt)) description Option shortv [opt] (NoArg (Annex.setFlag opt)) description
{- An option that sets a field. -} {- An option that sets a field. -}
fieldOption :: String -> String -> String -> String -> Option fieldOption :: String -> String -> String -> String -> Option
fieldOption short opt paramdesc description = fieldOption shortv opt paramdesc description =
Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description Option shortv [opt] (ReqArg (Annex.setField opt) paramdesc) description
{- The flag or field name used for an option. -} {- The flag or field name used for an option. -}
optionName :: Option -> String optionName :: Option -> String

13
Types/DeferredParse.hs
View file

@ -12,7 +12,7 @@ module Types.DeferredParse where
import Annex import Annex
import Common import Common
import Options.Applicative.Types import Options.Applicative
-- Some values cannot be fully parsed without performing an action. -- 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 -- 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. -- Use when the Annex action modifies Annex state.
type GlobalSetter = DeferredParse () type GlobalSetter = DeferredParse ()
globalOpt :: Annex () -> Parser Bool -> Parser GlobalSetter globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> Parser GlobalSetter
globalOpt setter parser = go <$> parser globalFlag setter = flag' (DeferredParse setter)
where
go False = ReadyParse ()
go True = DeferredParse setter
globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter
globalSetter setter parser = DeferredParse . setter <$> parser globalSetter setter parser = DeferredParse . setter <$> parser
globalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter
globalSetters l = DeferredParse . sequence_ . map getParsed
<$> many (foldl1 (<|>) l)