refactor in preparation for adding a git-annex-shell command

CmdLine.hs

@@ -1,11 +1,16 @@
-{- git-annex command line
+{- git-annex command line parsing
  -
  - Copyright 2010 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module CmdLine (parseCmd) where
+module CmdLine (
+	parseCmd,
+	Option,
+	storeOptBool,
+	storeOptString,
+) where
 
 import System.Console.GetOpt
 import Control.Monad (when)
@@ -13,116 +18,41 @@ import Control.Monad.State (liftIO)
 
 import qualified Annex
 import Types
-
 import Command
-import qualified Command.Add
-import qualified Command.Unannex
-import qualified Command.Drop
-import qualified Command.Move
-import qualified Command.Copy
-import qualified Command.Get
-import qualified Command.FromKey
-import qualified Command.DropKey
-import qualified Command.SetKey
-import qualified Command.Fix
-import qualified Command.Init
-import qualified Command.Fsck
-import qualified Command.Unused
-import qualified Command.DropUnused
-import qualified Command.Unlock
-import qualified Command.Lock
-import qualified Command.PreCommit
-import qualified Command.Find
-import qualified Command.Uninit
-import qualified Command.Trust
-import qualified Command.Untrust
 
-cmds :: [Command]
+{- Each dashed command-line option results in generation of an action
-cmds =
+ - in the Annex monad that performs the necessary setting.
-	[ Command.Add.command
+ -}
-	, Command "get" path		Command.Get.seek
+type Option = OptDescr (Annex ())
-		"make content of annexed files available"
+
-	, Command "drop" path	Command.Drop.seek
+storeOptBool :: FlagName -> Bool -> Annex ()
-		"indicate content of files not currently wanted"
+storeOptBool name val = Annex.flagChange name $ FlagBool val
-	, Command "move" path	Command.Move.seek
+storeOptString :: FlagName -> String -> Annex ()
-		"move content of files to/from another repository"
+storeOptString name val = Annex.flagChange name $ FlagString val
-	, Command "copy" path	Command.Copy.seek
+
-		"copy content of files to/from another repository"
+{- Parses command line, stores configure flags, and returns a 
-	, Command "unlock" path	Command.Unlock.seek
+ - list of actions to be run in the Annex monad. -}
-		"unlock files for modification"
+parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex [Annex Bool]
-	, Command "edit" path	Command.Unlock.seek
+parseCmd argv header cmds options = do
-		"same as unlock"
+	(flags, params) <- liftIO $ getopt
-	, Command "lock" path	Command.Lock.seek
+	when (null params) $ error usagemsg
-		"undo unlock command"
+	case lookupCmd (head params) of
-	, Command "init" desc	Command.Init.seek
+		[] -> error usagemsg
-		"initialize git-annex with repository description"
+		[command] -> do
-	, Command "unannex" path	Command.Unannex.seek
+			_ <- sequence flags
-		"undo accidential add command"
+			prepCmd command (drop 1 params)
-	, Command "uninit" path	Command.Uninit.seek
+		_ -> error "internal error: multiple matching commands"
-		"de-initialize git-annex and clean out repository"
-	, Command "pre-commit" path	Command.PreCommit.seek
-		"run by git pre-commit hook"
-	, Command "trust" remote	Command.Trust.seek
-		"trust a repository"
-	, Command "untrust" remote	Command.Untrust.seek
-		"do not trust a repository"
-	, Command "fromkey" key	Command.FromKey.seek
-		"adds a file using a specific key"
-	, Command "dropkey"	key	Command.DropKey.seek
-		"drops annexed content for specified keys"
-	, Command "setkey" key	Command.SetKey.seek
-		"sets annexed content for a key using a temp file"
-	, Command "fix" path		Command.Fix.seek
-		"fix up symlinks to point to annexed content"
-	, Command "fsck" maybepath	Command.Fsck.seek
-		"check for problems"
-	, Command "unused" nothing	Command.Unused.seek
-		"look for unused file content"
-	, Command "dropunused" number Command.DropUnused.seek
-		"drop unused file content"
-	, Command "find" maybepath	Command.Find.seek
-		"lists available files"
-	]
 	where
-		path = "PATH ..."
+		getopt = case getOpt Permute options argv of
-		maybepath = "[PATH ...]"
+			(flags, params, []) -> return (flags, params)
-		key = "KEY ..."
+			(_, _, errs) -> ioError (userError (concat errs ++ usagemsg))
-		desc = "DESCRIPTION"
+		lookupCmd cmd = filter (\c -> cmd  == cmdname c) cmds
-		number = "NUMBER ..."
+		usagemsg = usage header cmds options
-		remote = "REMOTE ..."
-		nothing = ""
 
--- Each dashed command-line option results in generation of an action
+{- Usage message with lists of commands and options. -}
--- in the Annex monad that performs the necessary setting.
+usage :: String -> [Command] -> [Option] -> String
-options :: [OptDescr (Annex ())]
+usage header cmds options =
-options = [
+	usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
-	    Option ['f'] ["force"] (NoArg (storebool "force" True))
-		"allow actions that may lose annexed data"
-	  , Option ['q'] ["quiet"] (NoArg (storebool "quiet" True))
-		"avoid verbose output"
-	  , Option ['v'] ["verbose"] (NoArg (storebool "quiet" False))
-		"allow verbose output"
-	  , Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME")
-		"specify default key-value backend to use"
-	  , Option ['k'] ["key"] (ReqArg (storestring "key") "KEY")
-		"specify a key to use"
-	  , Option ['t'] ["to"] (ReqArg (storestring "torepository") "REPOSITORY")
-		"specify to where to transfer content"
-	  , Option ['f'] ["from"] (ReqArg (storestring "fromrepository") "REPOSITORY")
-		"specify from where to transfer content"
-	  , Option ['x'] ["exclude"] (ReqArg (storestring "exclude") "GLOB")
-		"skip files matching the glob pattern"
-	  ]
-	where
-		storebool n b = Annex.flagChange n $ FlagBool b
-		storestring n s = Annex.flagChange n $ FlagString s
-
-header :: String
-header = "Usage: git-annex subcommand [option ..]"
-
-{- Usage message with lists of options and subcommands. -}
-usage :: String
-usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 	where
 		cmddescs = unlines $ map (indent . showcmd) cmds
 		showcmd c =
@@ -133,21 +63,3 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 			cmddesc c
 		indent l = "  " ++ l
 		pad n s = replicate (n - length s) ' '
-
-{- Parses command line, stores configure flags, and returns a 
- - list of actions to be run in the Annex monad. -}
-parseCmd :: [String] -> Annex [Annex Bool]
-parseCmd argv = do
-	(flags, params) <- liftIO $ getopt
-	when (null params) $ error usage
-	case lookupCmd (head params) of
-		[] -> error usage
-		[command] -> do
-			_ <- sequence flags
-			prepCmd command (drop 1 params)
-		_ -> error "internal error: multiple matching commands"
-	where
-		getopt = case getOpt Permute options argv of
-			(flags, params, []) -> return (flags, params)
-			(_, _, errs) -> ioError (userError (concat errs ++ usage))
-		lookupCmd cmd = filter (\c -> cmd  == cmdname c) cmds

Command.hs

@@ -205,18 +205,24 @@ notSymlink f = do
 	s <- liftIO $ getSymbolicLinkStatus f
 	return $ not $ isSymbolicLink s
 
-{- descriptions of params used in usage message -}
+{- Descriptions of params used in usage messages. -}
+paramRepeating :: String -> String
+paramRepeating s = s ++ " ..."
+paramOptional :: String -> String
+paramOptional s = "[" ++ s ++ "]"
 paramPath :: String
-paramPath = "PATH ..."
+paramPath = "PATH"
-paramMaybePath :: String
-paramMaybePath = "[PATH ...]"
 paramKey :: String
-paramKey = "KEY ..."
+paramKey = "KEY"
 paramDesc :: String
 paramDesc = "DESCRIPTION"
 paramNumber :: String
-paramNumber = "NUMBER ..."
+paramNumber = "NUMBER"
 paramRemote :: String
-paramRemote = "REMOTE ..."
+paramRemote = "REMOTE"
+paramGlob :: String
+paramGlob = "GLOB"
+paramName :: String
+paramName = "NAME"
 paramNothing :: String
 paramNothing = ""

Command/Add.hs

@@ -18,8 +18,8 @@ import Types
 import Core
 import Messages
 
-command :: Command
+command :: [Command]
-command = Command "add" paramPath seek "add files to annex"
+command = [Command "add" paramPath seek "add files to annex"]
 
 {- Add acts on both files not checked into git yet, and unlocked files. -}
 seek :: [CommandSeek]

Command/Copy.hs

@@ -10,6 +10,10 @@ module Command.Copy where
 import Command
 import qualified Command.Move
 
+command :: [Command]
+command = [Command "copy" paramPath seek
+	"copy content of files to/from another repository"]
+
 -- A copy is just a move that does not delete the source file.
 seek :: [CommandSeek]
 seek = [withFilesInGit $ Command.Move.start False]

Command/Drop.hs

@@ -17,6 +17,10 @@ import Core
 import Messages
 import Utility
 
+command :: [Command]
+command = [Command "drop" paramPath seek
+	"indicate content of files not currently wanted"]
+
 seek :: [CommandSeek]
 seek = [withAttrFilesInGit "annex.numcopies" start]
 

Command/DropKey.hs

@@ -15,6 +15,10 @@ import Types
 import Core
 import Messages
 
+command :: [Command]
+command = [Command "dropkey" (paramRepeating paramKey) seek
+	"drops annexed content for specified keys"] 
+
 seek :: [CommandSeek]
 seek = [withKeys start]
 

Command/DropUnused.hs

@@ -18,6 +18,10 @@ import qualified Annex
 import qualified Command.Drop
 import Backend
 
+command :: [Command]
+command = [Command "dropunused" (paramRepeating paramNumber) seek
+	"drop unused file content"]
+
 seek :: [CommandSeek]
 seek = [withStrings start]
 

Command/Find.hs

@@ -13,6 +13,10 @@ import Control.Monad.State (liftIO)
 import Command
 import Core
 
+command :: [Command]
+command = [Command "find" (paramOptional $ paramRepeating paramPath) seek
+	"lists available files"]
+
 seek :: [CommandSeek]
 seek = [withDefault "." withFilesInGit start]
 

Command/Fix.hs

@@ -17,6 +17,10 @@ import Utility
 import Core
 import Messages
 
+command :: [Command]
+command = [Command "fix" paramPath seek
+	"fix up symlinks to point to annexed content"]
+
 seek :: [CommandSeek]
 seek = [withFilesInGit start]
 

Command/FromKey.hs

@@ -20,6 +20,10 @@ import Types
 import Core
 import Messages
 
+command :: [Command]
+command = [Command "fromkey" (paramRepeating paramKey) seek
+	"adds a file using a specific key"]
+
 seek :: [CommandSeek]
 seek = [withFilesMissing start]
 

Command/Fsck.hs

@@ -13,6 +13,10 @@ import Types
 import Messages
 import Utility
 
+command :: [Command]
+command = [Command "fsck" (paramOptional $ paramRepeating paramPath) seek
+	"check for problems"]
+
 seek :: [CommandSeek]
 seek = [withAll (withAttrFilesInGit "annex.numcopies") start]
 

Command/Get.hs

@@ -13,6 +13,10 @@ import Types
 import Core
 import Messages
 
+command :: [Command]
+command = [Command "get" paramPath seek
+		"make content of annexed files available"]
+
 seek :: [CommandSeek]
 seek = [withFilesInGit start]
 

Command/Init.hs

@@ -20,6 +20,10 @@ import Messages
 import Locations
 import Types
 	
+command :: [Command]
+command = [Command "init" paramDesc seek
+		"initialize git-annex with repository description"]
+
 seek :: [CommandSeek]
 seek = [withString start]
 

Command/Lock.hs

@@ -15,6 +15,9 @@ import Messages
 import qualified Annex
 import qualified GitRepo as Git
 	
+command :: [Command]
+command = [Command "lock" paramPath seek "undo unlock command"]
+
 seek :: [CommandSeek]
 seek = [withFilesUnlocked start]
 

Command/Move.hs

@@ -21,6 +21,10 @@ import qualified Remotes
 import UUID
 import Messages
 	
+command :: [Command]
+command = [Command "move" paramPath seek
+	"move content of files to/from another repository"]
+
 seek :: [CommandSeek]
 seek = [withFilesInGit $ start True]
 

Command/PreCommit.hs

@@ -15,6 +15,9 @@ import qualified GitRepo as Git
 import qualified Command.Add
 import qualified Command.Fix
 
+command :: [Command]
+command = [Command "pre-commit" paramPath seek "run by git pre-commit hook"]
+
 {- The pre-commit hook needs to fix symlinks to all files being committed.
  - And, it needs to inject unlocked files into the annex. -}
 seek :: [CommandSeek]

Command/SetKey.hs

@@ -19,6 +19,10 @@ import Types
 import Core
 import Messages
 
+command :: [Command]
+command = [Command "setkey" (paramRepeating paramKey) seek
+	"sets annexed content for a key using a temp file"]
+
 seek :: [CommandSeek]
 seek = [withTempFile start]
 

Command/Trust.hs

@@ -17,6 +17,10 @@ import qualified Remotes
 import UUID
 import Messages
 
+command :: [Command]
+command = [Command "trust" (paramRepeating paramRemote) seek
+	"trust a repository"]
+
 seek :: [CommandSeek]
 seek = [withString start]
 

Command/Unannex.hs

@@ -20,6 +20,9 @@ import Core
 import qualified GitRepo as Git
 import Messages
 
+command :: [Command]
+command = [Command "unannex" paramPath seek "undo accidential add command"]
+
 seek :: [CommandSeek]
 seek = [withFilesInGit start]
 

Command/Uninit.hs

@@ -20,6 +20,10 @@ import qualified Annex
 import qualified Command.Unannex
 import qualified Command.Init
 
+command :: [Command]
+command = [Command "uninit" paramPath seek 
+        "de-initialize git-annex and clean out repository"]
+
 seek :: [CommandSeek]
 seek = [withAll withFilesInGit Command.Unannex.start, withNothing start]
 

Command/Unlock.hs

@@ -18,6 +18,12 @@ import Locations
 import Core
 import CopyFile
 
+command :: [Command]
+command =
+	[ Command "unlock" paramPath seek "unlock files for modification"
+	, Command "edit" paramPath seek "same as unlock"
+	]
+
 seek :: [CommandSeek]
 seek = [withFilesInGit start]
 

Command/Untrust.hs

@@ -17,6 +17,10 @@ import qualified Remotes
 import UUID
 import Messages
 
+command :: [Command]
+command = [Command "untrust" (paramRepeating paramRemote) seek
+	"do not trust a repository"]
+
 seek :: [CommandSeek]
 seek = [withString start]
 

Command/Unused.hs

@@ -17,6 +17,9 @@ import Messages
 import Locations
 import qualified Annex
 
+command :: [Command]
+command = [Command "unused" paramNothing seek "look for unused file content"]
+
 seek :: [CommandSeek]
 seek = [withNothing start]
 

git-annex.hs

@@ -6,6 +6,7 @@
  -}
 
 import System.Environment
+import System.Console.GetOpt
 
 import qualified Annex
 import Core
@@ -14,10 +15,81 @@ import CmdLine
 import qualified GitRepo as Git
 import BackendList
 
+import Command
+import qualified Command.Add
+import qualified Command.Unannex
+import qualified Command.Drop
+import qualified Command.Move
+import qualified Command.Copy
+import qualified Command.Get
+import qualified Command.FromKey
+import qualified Command.DropKey
+import qualified Command.SetKey
+import qualified Command.Fix
+import qualified Command.Init
+import qualified Command.Fsck
+import qualified Command.Unused
+import qualified Command.DropUnused
+import qualified Command.Unlock
+import qualified Command.Lock
+import qualified Command.PreCommit
+import qualified Command.Find
+import qualified Command.Uninit
+import qualified Command.Trust
+import qualified Command.Untrust
+
+cmds :: [Command]
+cmds = concat
+	[ Command.Add.command
+	, Command.Get.command
+	, Command.Drop.command
+	, Command.Move.command
+	, Command.Copy.command
+	, Command.Unlock.command
+	, Command.Lock.command
+	, Command.Init.command
+	, Command.Unannex.command
+	, Command.Uninit.command
+	, Command.PreCommit.command
+	, Command.Trust.command
+	, Command.Untrust.command
+	, Command.FromKey.command
+	, Command.DropKey.command
+	, Command.SetKey.command
+	, Command.Fix.command
+	, Command.Fsck.command
+	, Command.Unused.command
+	, Command.DropUnused.command
+	, Command.Find.command
+	]
+
+options :: [Option]
+options = [
+	    Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
+		"allow actions that may lose annexed data"
+	  , Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
+		"avoid verbose output"
+	  , Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
+		"allow verbose output"
+	  , Option ['b'] ["backend"] (ReqArg (storeOptString "backend") paramName)
+		"specify default key-value backend to use"
+	  , Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
+		"specify a key to use"
+	  , Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
+		"specify to where to transfer content"
+	  , Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
+		"specify from where to transfer content"
+	  , Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
+		"skip files matching the glob pattern"
+	  ]
+
+header :: String
+header = "Usage: git-annex subcommand [option ..]"
+
 main :: IO ()
 main = do
 	args <- getArgs
 	gitrepo <- Git.repoFromCwd
 	state <- Annex.new gitrepo allBackends
-	(actions, state') <- Annex.run state $ parseCmd args
+	(actions, state') <- Annex.run state $ parseCmd args header cmds options
 	tryRun state' $ [startup, upgrade] ++ actions