support cmdnorepo actions, also using getopt-applicative there

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)
+		let norepoparser = fromMaybe (throw norepo) . cmdnorepo
-		error "TODO"
+		(_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
+{- Parses command line, selecting one of the commands from the list. -}
- - seek action for the command. -}
+parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v)
-parseCmd :: CmdParams -> [Command] -> O.ParserResult (Command, CommandSeek)
+parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs
-parseCmd allargs allcmds = 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.

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

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 
+	Command [] commonChecks False False name paramdesc 
-		section desc (mkparser 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 :: (String -> O.Parser (IO ())) -> Command -> Command
-noRepo a c = c { cmdnorepo = Just a }
+noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) }
 
 {- Adds options to a command. -}
 withOptions :: [Option] -> Command -> Command

Command/Assistant.hs

@@ -20,10 +20,11 @@ import Assistant.Install
 import System.Environment
 
 cmd :: Command
-cmd = noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $
+cmd = dontCheck repoExists $ withOptions options $ notBareRepo $
-	notBareRepo $ command "assistant" SectionCommon
+	noRepo (withParams checkNoRepoOpts) $
-		"automatically sync changes"
+		command "assistant" SectionCommon
-		paramNothing (withParams seek)
+			"automatically sync changes"
+			paramNothing (withParams seek)
 
 options :: [Option]
 options =

Command/Help.hs

@@ -22,9 +22,12 @@ import qualified Command.Fsck
 import System.Console.GetOpt
 
 cmd :: Command
-cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+cmd = noCommit $ dontCheck repoExists $
-	command "help" SectionCommon "display help"
+	noRepo (parseparams startNoRepo) $ 
-		"COMMAND" (withParams seek)
+		command "help" SectionCommon "display help"
+			"COMMAND" (parseparams seek)
+  where
+	parseparams = withParams
 
 seek :: CmdParams -> CommandSeek
 seek = withWords start

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

Command/Version.hs

@@ -18,10 +18,12 @@ import qualified Remote
 import qualified Backend
 
 cmd :: Command
-cmd = withOptions [rawOption] $
+cmd = withOptions [rawOption] $ dontCheck repoExists $ noCommit $ 
-	noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+	noRepo (parseparams startNoRepo) $ 
-	command "version" SectionQuery "show version info"
+		command "version" SectionQuery "show version info"
-		paramNothing (withParams seek)
+			paramNothing (parseparams seek)
+  where
+	parseparams = withParams
 
 rawOption :: Option
 rawOption = flagOption [] "raw" "output only program version"

Command/WebApp.hs

@@ -39,9 +39,10 @@ import System.Environment (getArgs)
 
 cmd :: Command
 cmd = withOptions [listenOption] $
-	noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
+	noCommit $ dontCheck repoExists $ notBareRepo $
-	command "webapp" SectionCommon "launch webapp"
+	noRepo (withParams startNoRepo) $
-		paramNothing (withParams seek)
+		command "webapp" SectionCommon "launch webapp"
+			paramNothing (withParams seek)
 
 listenOption :: Option
 listenOption = fieldOption [] "listen" paramAddress

Command/XMPPGit.hs

@@ -12,9 +12,12 @@ import Command
 import Assistant.XMPP.Git
 
 cmd :: Command
-cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $
+cmd = noCommit $ dontCheck repoExists $
-	command "xmppgit" SectionPlumbing "git to XMPP relay"
+	noRepo (parseparams startNoRepo) $ 
-		paramNothing (withParams seek)
+		command "xmppgit" SectionPlumbing "git to XMPP relay"
+			paramNothing (parseparams seek)
+  where
+	parseparams = withParams
 
 seek :: CmdParams -> CommandSeek
 seek = withWords start

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