diff options
-rw-r--r-- | CmdLine.hs | 45 | ||||
-rw-r--r-- | CmdLine/Usage.hs | 8 | ||||
-rw-r--r-- | Command.hs | 17 | ||||
-rw-r--r-- | Command/Assistant.hs | 9 | ||||
-rw-r--r-- | Command/Help.hs | 9 | ||||
-rw-r--r-- | Command/Test.hs | 6 | ||||
-rw-r--r-- | Command/Version.hs | 10 | ||||
-rw-r--r-- | Command/WebApp.hs | 7 | ||||
-rw-r--r-- | Command/XMPPGit.hs | 9 | ||||
-rw-r--r-- | Types/Command.hs | 2 |
10 files changed, 54 insertions, 68 deletions
diff --git a/CmdLine.hs b/CmdLine.hs index 2b9418d83..82c9b4289 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -45,7 +45,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do inRepo $ autocorrect . Just forM_ fields $ uncurry Annex.setField (cmd, seek) <- liftIO $ - O.handleParseResult (parseCmd (name:args) allcmds) + O.handleParseResult (parseCmd (name:args) allcmds cmdparser) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput -- TODO: propigate global options to annex state (how?) @@ -54,11 +54,12 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do startup performCommandAction cmd seek $ shutdown $ cmdnocommit cmd - go (Left e) = do + go (Left norepo) = do when fuzzy $ autocorrect =<< Git.Config.global - -- a <- O.handleParseResult (parseCmd (name:args) allcmds) - error "TODO" + let norepoparser = fromMaybe (throw norepo) . cmdnorepo + (_cmd, a) <- O.handleParseResult (parseCmd (name:args) allcmds norepoparser) + a autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds err msg = msg ++ "\n\n" ++ usage header allcmds @@ -69,44 +70,16 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do _ -> inputcmdname | otherwise = inputcmdname -#if 0 - case getOptCmd args cmd commonoptions of - Right (flags, params) -> go flags params - =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) - Left parseerr -> error parseerr - where - go flags params (Right g) = do - state <- Annex.new g - Annex.eval state $ do - checkEnvironment - when fuzzy $ - inRepo $ autocorrect . Just - forM_ fields $ uncurry Annex.setField - when (cmdnomessages cmd) $ - Annex.setOutput QuietOutput - sequence_ flags - whenM (annexDebug <$> Annex.getGitConfig) $ - liftIO enableDebugOutput - startup - performCommandAction cmd params $ - shutdown $ cmdnocommit cmd - go _flags params (Left e) = do - when fuzzy $ - autocorrect =<< Git.Config.global - maybe (throw e) (\a -> a params) (cmdnorepo cmd) - cmd = Prelude.head cmds -#endif -{- Parses command line and selects a command to run and gets the - - seek action for the command. -} -parseCmd :: CmdParams -> [Command] -> O.ParserResult (Command, CommandSeek) -parseCmd allargs allcmds = O.execParserPure (O.prefs O.idm) pinfo allargs +{- Parses command line, selecting one of the commands from the list. -} +parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) +parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) O.idm mkcommand c = O.command (cmdname c) (O.info (mkparser c) O.idm) mkparser c = (,) <$> pure c - <*> cmdparser c + <*> getparser c {- Parses command line params far enough to find the Command to run, and - returns the remaining params. diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index 58408762b..1355c4316 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -11,7 +11,6 @@ import Common.Annex import Types.Command import System.Console.GetOpt -import qualified Options.Applicative as O usageMessage :: String -> String usageMessage s = "Usage: " ++ s @@ -56,13 +55,6 @@ commandUsage cmd = unlines , "[option ...]" ] -{- Simple CommandParser generator, for when the CommandSeek wants all - - non-option parameters. -} -withParams :: (CmdParams -> CommandSeek) -> String -> CommandParser -withParams mkseek paramdesc = mkseek <$> O.many cmdparams - where - cmdparams = O.argument O.str (O.metavar paramdesc) - {- Descriptions of params used in usage messages. -} paramPaths :: String paramPaths = paramRepeating paramPath -- most often used diff --git a/Command.hs b/Command.hs index c1d788c79..ec8ffadd9 100644 --- a/Command.hs +++ b/Command.hs @@ -7,6 +7,7 @@ module Command ( command, + withParams, noRepo, noCommit, noMessages, @@ -32,11 +33,19 @@ import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported +import qualified Options.Applicative as O + {- Generates a normal Command -} command :: String -> CommandSection -> String -> String -> (String -> CommandParser) -> Command command name section desc paramdesc mkparser = - Command [] Nothing commonChecks False False name paramdesc - section desc (mkparser paramdesc) + Command [] commonChecks False False name paramdesc + section desc (mkparser paramdesc) Nothing + +{- Option parser that takes all non-option params as-is. -} +withParams :: (CmdParams -> v) -> String -> O.Parser v +withParams mkseek paramdesc = mkseek <$> O.many cmdparams + where + cmdparams = O.argument O.str (O.metavar paramdesc) {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} @@ -50,8 +59,8 @@ noMessages c = c { cmdnomessages = True } {- Adds a fallback action to a command, that will be run if it's used - outside a git repository. -} -noRepo :: (CmdParams -> IO ()) -> Command -> Command -noRepo a c = c { cmdnorepo = Just a } +noRepo :: (String -> O.Parser (IO ())) -> Command -> Command +noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } {- Adds options to a command. -} withOptions :: [Option] -> Command -> Command diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 51d5a46b2..08e96da07 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -20,10 +20,11 @@ import Assistant.Install import System.Environment cmd :: Command -cmd = noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ - notBareRepo $ command "assistant" SectionCommon - "automatically sync changes" - paramNothing (withParams seek) +cmd = dontCheck repoExists $ withOptions options $ notBareRepo $ + noRepo (withParams checkNoRepoOpts) $ + command "assistant" SectionCommon + "automatically sync changes" + paramNothing (withParams seek) options :: [Option] options = diff --git a/Command/Help.hs b/Command/Help.hs index 08873e2bb..17ed8cd0b 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -22,9 +22,12 @@ import qualified Command.Fsck import System.Console.GetOpt cmd :: Command -cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "help" SectionCommon "display help" - "COMMAND" (withParams seek) +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "help" SectionCommon "display help" + "COMMAND" (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Command/Test.hs b/Command/Test.hs index 6f9c23d2d..57a9b16d3 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -12,10 +12,12 @@ import Command import Messages cmd :: Command -cmd = noRepo startIO $ dontCheck repoExists $ +cmd = noRepo (parseparams startIO) $ dontCheck repoExists $ command "test" SectionTesting "run built-in test suite" - paramNothing (withParams seek) + paramNothing (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Command/Version.hs b/Command/Version.hs index 70aea8f2c..38c799675 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -18,10 +18,12 @@ import qualified Remote import qualified Backend cmd :: Command -cmd = withOptions [rawOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "version" SectionQuery "show version info" - paramNothing (withParams seek) +cmd = withOptions [rawOption] $ dontCheck repoExists $ noCommit $ + noRepo (parseparams startNoRepo) $ + command "version" SectionQuery "show version info" + paramNothing (parseparams seek) + where + parseparams = withParams rawOption :: Option rawOption = flagOption [] "raw" "output only program version" diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 2a639e489..2e41ebe7d 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -39,9 +39,10 @@ import System.Environment (getArgs) cmd :: Command cmd = withOptions [listenOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ - command "webapp" SectionCommon "launch webapp" - paramNothing (withParams seek) + noCommit $ dontCheck repoExists $ notBareRepo $ + noRepo (withParams startNoRepo) $ + command "webapp" SectionCommon "launch webapp" + paramNothing (withParams seek) listenOption :: Option listenOption = fieldOption [] "listen" paramAddress diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 7d7d99476..86d8dbc11 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -12,9 +12,12 @@ import Command import Assistant.XMPP.Git cmd :: Command -cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "xmppgit" SectionPlumbing "git to XMPP relay" - paramNothing (withParams seek) +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "xmppgit" SectionPlumbing "git to XMPP relay" + paramNothing (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Types/Command.hs b/Types/Command.hs index 4ab722035..99920e657 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -39,7 +39,6 @@ type CommandCleanup = Annex Bool {- A command is defined by specifying these things. -} data Command = Command { cmdoptions :: [Option] -- command-specific options - , cmdnorepo :: Maybe (CmdParams -> IO ()) -- an action to run when not in a repo , cmdcheck :: [CommandCheck] -- check stage , cmdnocommit :: Bool -- don't commit journalled state changes , cmdnomessages :: Bool -- don't output normal messages @@ -48,6 +47,7 @@ data Command = Command , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage , cmdparser :: CommandParser -- command line parser + , cmdnorepo :: Maybe (Parser (IO ())) -- used when not in a repo } {- Command-line parameters, after the command is selected and options |