per-command options

Finally commands can define their own options.

Moved --format and --print0 to be options only of find.

CmdLine.hs

@@ -29,7 +29,7 @@ type Flags = [Annex ()]
 
 {- Runs the passed command line. -}
 dispatch :: Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
-dispatch args cmds options header getgitrepo = do
+dispatch args cmds commonoptions header getgitrepo = do
 	setupConsole
 	r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
 	case r of
@@ -41,37 +41,26 @@ dispatch args cmds options header getgitrepo = do
 				prepCommand cmd params
 			tryRun state' cmd $ [startup] ++ actions ++ [shutdown]
 	where
-		(flags, cmd, params) = parseCmd args cmds options header
+		(flags, cmd, params) = parseCmd args cmds commonoptions header
 
 {- Parses command line, and returns actions to run to configure flags,
  - the Command being run, and the remaining parameters for the command. -} 
 parseCmd :: Params -> [Command] -> [Option] -> String -> (Flags, Command, Params)
-parseCmd argv cmds options header = check $ getOpt Permute options argv
+parseCmd argv cmds commonoptions header
+	| name == Nothing = err "missing command"
+	| null matches = err $ "unknown command " ++ fromJust name
+	| otherwise = check $ getOpt Permute (commonoptions ++ cmdoptions cmd) args
 	where
-		check (_, [], []) = err "missing command"
-		check (flags, name:rest, [])
-			| null matches = err $ "unknown command " ++ name
-			| otherwise = (flags, Prelude.head matches, rest)
-			where
-				matches = filter (\c -> name == cmdname c) cmds
+		(name, args) = findname argv []
+		findname [] c = (Nothing, reverse c)
+		findname (a:as) c
+			| "-" `isPrefixOf` a = findname as (a:c)
+			| otherwise = (Just a, reverse c ++ as)
+		matches = filter (\c -> name == Just (cmdname c)) cmds
+		cmd = Prelude.head matches
+		check (flags, rest, []) = (flags, cmd, rest)
 		check (_, _, errs) = err $ concat errs
-		err msg = error $ msg ++ "\n\n" ++ usage header cmds options
-
-{- Usage message with lists of commands and options. -}
-usage :: String -> [Command] -> [Option] -> String
-usage header cmds options = usageInfo top options ++ commands
-	where
-		top = header ++ "\n\nOptions:"
-		commands = "\nCommands:\n" ++ cmddescs
-		cmddescs = unlines $ map (indent . showcmd) cmds
-		showcmd c =
-			cmdname c ++
-			pad (longest cmdname + 1) (cmdname c) ++
-			cmdparamdesc c ++
-			pad (longest cmdparamdesc + 2) (cmdparamdesc c) ++
-			cmddesc c
-		pad n s = replicate (n - length s) ' '
-		longest f = foldl max 0 $ map (length . f) cmds
+		err msg = error $ msg ++ "\n\n" ++ usage header cmds commonoptions
 
 {- Runs a list of Annex actions. Catches IO errors and continues
  - (but explicitly thrown errors terminate the whole command).

Command.hs

@@ -8,6 +8,7 @@
 module Command (
 	command,
 	noRepo,
+	withOptions,
 	next,
 	stop,
 	stopUnless,
@@ -26,22 +27,28 @@ import qualified Backend
 import qualified Annex
 import qualified Git
 import Types.Command as ReExported
+import Types.Option as ReExported
 import Seek as ReExported
 import Checks as ReExported
 import Options as ReExported
+import Usage as ReExported
 import Logs.Trust
 import Logs.Location
 import Config
 
 {- Generates a normal command -}
 command :: String -> String -> [CommandSeek] -> String -> Command
-command = Command Nothing commonChecks
+command = Command [] Nothing commonChecks
 
 {- Adds a fallback action to a command, that will be run if it's used
  - outside a git repository. -}
 noRepo :: IO () -> Command -> Command
 noRepo a c = c { cmdnorepo = Just a }
 
+{- Adds options to a command. -}
+withOptions :: [Option] -> Command -> Command
+withOptions o c = c { cmdoptions = o }
+
 {- For start and perform stages to indicate what step to run next. -}
 next :: a -> Annex (Maybe a)
 next a = return $ Just a

Command/Find.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -19,7 +19,12 @@ import Utility.DataUnits
 import Types.Key
 
 def :: [Command]
-def = [command "find" paramPaths seek "lists available files"]
+def = [withOptions [formatOption, print0Option] $
+	command "find" paramPaths seek "lists available files"]
+
+print0Option :: Option
+print0Option = Option [] ["print0"] (NoArg $ setFormat "${file}\0")
+	"terminate output with null"
 
 seek :: [CommandSeek]
 seek = [withFilesInGit $ whenAnnexed start]

Command/Status.hs

@@ -144,9 +144,9 @@ bad_data_size = staleSize "bad keys size" gitAnnexBadDir
 
 backend_usage :: Stat
 backend_usage = stat "backend usage" $ nojson $
-	usage <$> cachedKeysReferenced <*> cachedKeysPresent
+	calc <$> cachedKeysReferenced <*> cachedKeysPresent
 	where
-		usage a b = pp "" $ reverse . sort $ map swap $ splits $ S.toList $ S.union a b
+		calc a b = pp "" $ reverse . sort $ map swap $ splits $ S.toList $ S.union a b
 		splits :: [Key] -> [(String, Integer)]
 		splits ks = M.toList $ M.fromListWith (+) $ map tcount ks
 		tcount k = (keyBackendName k, 1)

GitAnnex.hs

@@ -18,7 +18,6 @@ import Types.TrustLevel
 import qualified Annex
 import qualified Remote
 import qualified Limit
-import qualified Utility.Format
 
 import qualified Command.Add
 import qualified Command.Unannex
@@ -109,10 +108,6 @@ options = commonOptions ++
 		"override trust setting to untrusted"
 	, Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE")
 		"override git configuration setting"
-	, Option [] ["print0"] (NoArg setprint0)
-		"terminate output with null"
-	, Option [] ["format"] (ReqArg setformat paramFormat)
-		"control format of output"
 	, Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob)
 		"skip files matching the glob pattern"
 	, Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob)
@@ -128,8 +123,6 @@ options = commonOptions ++
 		setto v = Annex.changeState $ \s -> s { Annex.toremote = Just v }
 		setfrom v = Annex.changeState $ \s -> s { Annex.fromremote = Just v }
 		setnumcopies v = Annex.changeState $ \s -> s {Annex.forcenumcopies = readMaybe v }
-		setformat v = Annex.changeState $ \s -> s { Annex.format = Just $ Utility.Format.gen v }
-		setprint0 = setformat "${file}\0"
 		setgitconfig :: String -> Annex ()
 		setgitconfig v = do
 			newg <- inRepo $ Git.Config.store v

Options.hs

@@ -5,7 +5,15 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Options where
+module Options (
+	commonOptions,
+	matcherOptions,
+	formatOption,
+	setFormat,
+	ArgDescr(..),
+	Option,
+	OptDescr(..),
+) where
 
 import System.Console.GetOpt
 import System.Log.Logger
@@ -13,11 +21,9 @@ import System.Log.Logger
 import Common.Annex
 import qualified Annex
 import Limit
-
-{- Each dashed command-line option results in generation of an action
- - in the Annex monad that performs the necessary setting.
- -}
-type Option = OptDescr (Annex ())
+import Types.Option
+import Usage
+import qualified Utility.Format
 
 commonOptions :: [Option]
 commonOptions =
@@ -59,38 +65,10 @@ matcherOptions =
 		longopt o = Option [] [o] $ NoArg $ addToken o
 		shortopt o = Option o [] $ NoArg $ addToken o
 
-{- Descriptions of params used in usage messages. -}
-paramPaths :: String
-paramPaths = paramOptional $ paramRepeating paramPath -- most often used
-paramPath :: String
-paramPath = "PATH"
-paramKey :: String
-paramKey = "KEY"
-paramDesc :: String
-paramDesc = "DESC"
-paramUrl :: String
-paramUrl = "URL"
-paramNumber :: String
-paramNumber = "NUMBER"
-paramRemote :: String
-paramRemote = "REMOTE"
-paramGlob :: String
-paramGlob = "GLOB"
-paramName :: String
-paramName = "NAME"
-paramUUID :: String
-paramUUID = "UUID"
-paramType :: String
-paramType = "TYPE"
-paramFormat :: String
-paramFormat = "FORMAT"
-paramKeyValue :: String
-paramKeyValue = "K=V"
-paramNothing :: String
-paramNothing = ""
-paramRepeating :: String -> String
-paramRepeating s = s ++ " ..."
-paramOptional :: String -> String
-paramOptional s = "[" ++ s ++ "]"
-paramPair :: String -> String -> String
-paramPair a b = a ++ " " ++ b
+formatOption :: Option
+formatOption = Option [] ["format"] (ReqArg setFormat paramFormat)
+		"control format of output"
+
+setFormat :: String -> Annex ()
+setFormat v = Annex.changeState $ \s ->
+	s { Annex.format = Just $ Utility.Format.gen v }

Types/Command.hs

@@ -8,6 +8,7 @@
 module Types.Command where
 
 import Types
+import Types.Option
 
 {- A command runs in these stages.
  -
@@ -32,13 +33,14 @@ type CommandPerform = Annex (Maybe CommandCleanup)
 type CommandCleanup = Annex Bool
 
 {- A command is defined by specifying these things. -}
-data Command = Command {
-	cmdnorepo :: Maybe (IO ()), -- an action to run when not in a repo
-	cmdcheck :: [CommandCheck], -- check stage
-	cmdname :: String,
-	cmdparamdesc :: String,     -- description of params for usage
-	cmdseek :: [CommandSeek],   -- seek stage
-	cmddesc :: String           -- description of command for usage
+data Command = Command
+	{ cmdoptions :: [Option]     -- command-specific options
+	, cmdnorepo :: Maybe (IO ()) -- an action to run when not in a repo
+	, cmdcheck :: [CommandCheck] -- check stage
+	, cmdname :: String
+	, cmdparamdesc :: String     -- description of params for usage
+	, cmdseek :: [CommandSeek]   -- seek stage
+	, cmddesc :: String          -- description of command for usage
 	}
 
 {- CommandCheck functions can be compared using their unique id. -}

Types/Option.hs

@@ -0,0 +1,17 @@
+{- git-annex command options
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Option where
+
+import System.Console.GetOpt
+
+import Annex
+
+{- Each dashed command-line option results in generation of an action
+ - in the Annex monad that performs the necessary setting.
+ -}
+type Option = OptDescr (Annex ())

Usage.hs

@@ -0,0 +1,84 @@
+{- git-annex usage messages
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Usage where
+
+import System.Console.GetOpt
+
+import Types.Command
+import Types.Option
+
+{- Usage message with lists of commands and options. -}
+usage :: String -> [Command] -> [Option] -> String
+usage header cmds commonoptions = unlines $ 
+	[ header
+	, ""
+	, "Options:"
+	] ++ optlines ++
+	[ ""
+	, "Commands:"
+	, ""
+	] ++ cmdlines
+	where
+		-- To get consistent indentation of options, generate the
+		-- usage for all options at once. A command's options will
+		-- be displayed after the command.
+		alloptlines = filter (not . null) $
+			lines $ usageInfo "" $
+				concatMap cmdoptions cmds ++ commonoptions
+		(cmdlines, optlines) = go cmds alloptlines []
+		go [] os ls = (ls, os)
+		go (c:cs) os ls = go cs os' (ls++(l:o))
+			where
+				(o, os') = splitAt (length $ cmdoptions c) os
+				l = concat 
+					[ cmdname c
+					, namepad (cmdname c)
+					, cmdparamdesc c
+					, descpad (cmdparamdesc c)
+					, cmddesc c
+					]
+		pad n s = replicate (n - length s) ' '
+		namepad = pad $ longest cmdname + 1
+		descpad = pad $ longest cmdparamdesc + 2
+		longest f = foldl max 0 $ map (length . f) cmds
+
+{- Descriptions of params used in usage messages. -}
+paramPaths :: String
+paramPaths = paramOptional $ paramRepeating paramPath -- most often used
+paramPath :: String
+paramPath = "PATH"
+paramKey :: String
+paramKey = "KEY"
+paramDesc :: String
+paramDesc = "DESC"
+paramUrl :: String
+paramUrl = "URL"
+paramNumber :: String
+paramNumber = "NUMBER"
+paramRemote :: String
+paramRemote = "REMOTE"
+paramGlob :: String
+paramGlob = "GLOB"
+paramName :: String
+paramName = "NAME"
+paramUUID :: String
+paramUUID = "UUID"
+paramType :: String
+paramType = "TYPE"
+paramFormat :: String
+paramFormat = "FORMAT"
+paramKeyValue :: String
+paramKeyValue = "K=V"
+paramNothing :: String
+paramNothing = ""
+paramRepeating :: String -> String
+paramRepeating s = s ++ " ..."
+paramOptional :: String -> String
+paramOptional s = "[" ++ s ++ "]"
+paramPair :: String -> String -> String
+paramPair a b = a ++ " " ++ b