wip

Current status:

* building again, but several commands are commented out
* still need to implement global options, file matching options, etc

CmdLine/GitAnnex.hs

@@ -15,7 +15,7 @@ import Command
 import Utility.Env
 import Annex.Ssh
 
-import qualified Command.Help
+--import qualified Command.Help
 import qualified Command.Add
 import qualified Command.Unannex
 import qualified Command.Drop
@@ -25,7 +25,7 @@ import qualified Command.Get
 import qualified Command.Fsck
 import qualified Command.LookupKey
 import qualified Command.ContentLocation
-import qualified Command.ExamineKey
+--import qualified Command.ExamineKey
 import qualified Command.FromKey
 import qualified Command.RegisterUrl
 import qualified Command.SetKey
@@ -56,15 +56,15 @@ import qualified Command.AddUnused
 import qualified Command.Unlock
 import qualified Command.Lock
 import qualified Command.PreCommit
-import qualified Command.Find
-import qualified Command.FindRef
-import qualified Command.Whereis
+--import qualified Command.Find
+--import qualified Command.FindRef
+--import qualified Command.Whereis
 --import qualified Command.List
 import qualified Command.Log
 import qualified Command.Merge
 import qualified Command.ResolveMerge
-import qualified Command.Info
-import qualified Command.Status
+--import qualified Command.Info
+--import qualified Command.Status
 import qualified Command.Migrate
 import qualified Command.Uninit
 import qualified Command.Reinit
@@ -95,7 +95,7 @@ import qualified Command.Upgrade
 import qualified Command.Forget
 import qualified Command.Proxy
 import qualified Command.DiffDriver
-import qualified Command.Undo
+--import qualified Command.Undo
 import qualified Command.Version
 #ifdef WITH_ASSISTANT
 import qualified Command.Watch
@@ -119,8 +119,8 @@ import System.Remote.Monitoring
 
 cmds :: [Command]
 cmds = 
-	[ Command.Help.cmd
-	, Command.Add.cmd
+--	[ Command.Help.cmd
+	[ Command.Add.cmd
 	, Command.Get.cmd
 	, Command.Drop.cmd
 	, Command.Move.cmd
@@ -160,7 +160,7 @@ cmds =
 --	, Command.Vicfg.cmd
 	, Command.LookupKey.cmd
 	, Command.ContentLocation.cmd
-	, Command.ExamineKey.cmd
+--	, Command.ExamineKey.cmd
 	, Command.FromKey.cmd
 	, Command.RegisterUrl.cmd
 	, Command.SetKey.cmd
@@ -183,15 +183,15 @@ cmds =
 --	, Command.Unused.cmd
 --	, Command.DropUnused.cmd
 	, Command.AddUnused.cmd
-	, Command.Find.cmd
-	, Command.FindRef.cmd
-	, Command.Whereis.cmd
+--	, Command.Find.cmd
+--	, Command.FindRef.cmd
+--	, Command.Whereis.cmd
 --	, Command.List.cmd
 	, Command.Log.cmd
 	, Command.Merge.cmd
 	, Command.ResolveMerge.cmd
-	, Command.Info.cmd
-	, Command.Status.cmd
+--	, Command.Info.cmd
+--	, Command.Status.cmd
 	, Command.Migrate.cmd
 	, Command.Map.cmd
 	, Command.Direct.cmd
@@ -200,7 +200,7 @@ cmds =
 	, Command.Forget.cmd
 	, Command.Proxy.cmd
 	, Command.DiffDriver.cmd
-	, Command.Undo.cmd
+--	, Command.Undo.cmd
 	, Command.Version.cmd
 #ifdef WITH_ASSISTANT
 	, Command.Watch.cmd

CmdLine/GitAnnex/Options.hs

@@ -99,11 +99,7 @@ parseKeyOptions allowincomplete = if allowincomplete
 			)
 	else base
   where
-	base =
-		flag' WantAllKeys
-			( long "all" <> short 'A'
-			<> help "operate on all versions of all files"
-			)
+	base = parseAllOption
 		<|> flag' WantUnusedKeys
 			( long "unused" <> short 'U'
 			<> help "operate on files found by last run of git-annex unused"
@@ -113,6 +109,12 @@ parseKeyOptions allowincomplete = if allowincomplete
 			<> help "operate on specified key"
 			))
 
+parseAllOption :: Parser KeyOptions
+parseAllOption = flag' WantAllKeys
+	( long "all" <> short 'A'
+	<> help "operate on all versions of all files"
+	)
+
 parseKey :: Monad m => String -> m Key
 parseKey = maybe (fail "invalid key") return . file2key
 
@@ -121,13 +123,13 @@ annexedMatchingOptions :: [Option]
 annexedMatchingOptions = concat
 	[ nonWorkTreeMatchingOptions'
 	, fileMatchingOptions'
-	, combiningOptions
-	, [timeLimitOption]
+	-- , combiningOptions
+	-- , [timeLimitOption]
 	]
 
 -- Matching options that don't need to examine work tree files.
 nonWorkTreeMatchingOptions :: [Option]
-nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' ++ combiningOptions
+nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' -- ++ combiningOptions
 
 nonWorkTreeMatchingOptions' :: [Option]
 nonWorkTreeMatchingOptions' = 
@@ -153,7 +155,7 @@ nonWorkTreeMatchingOptions' =
 
 -- Options to match files which may not yet be annexed.
 fileMatchingOptions :: [Option]
-fileMatchingOptions = fileMatchingOptions' ++ combiningOptions
+fileMatchingOptions = fileMatchingOptions' -- ++ combiningOptions
 
 fileMatchingOptions' :: [Option]
 fileMatchingOptions' =
@@ -167,37 +169,37 @@ fileMatchingOptions' =
 		"match files smaller than a size"
 	]
 
-combiningOptions :: [Option]
-combiningOptions =
-	[ longopt "not" "negate next option"
-	, longopt "and" "both previous and next option must match"
-	, longopt "or" "either previous or next option must match"
-	, shortopt "(" "open group of options"
-	, shortopt ")" "close group of options"
-	]
+parseCombiningOptions :: Parser [GlobalSetter]
+parseCombiningOptions = 
+	many $ longopt "not" "negate next option"
+		<|> longopt "and" "both previous and next option must match"
+		<|> longopt "or" "either previous or next option must match"
+		<|> shortopt '(' "open group of options"
+		<|> shortopt ')' "close group of options"
   where
-	longopt o = Option [] [o] $ NoArg $ Limit.addToken o
-	shortopt o = Option o [] $ NoArg $ Limit.addToken o
+	longopt o h = globalOpt (Limit.addToken o) $ switch
+		( long o <> help h )
+	shortopt o h = globalOpt (Limit.addToken [o]) $ switch
+		( short o <> help h)
 
-jsonOption :: Option
-jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
-	"enable JSON output"
+parseJsonOption :: Parser GlobalSetter
+parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch
+	( long "json" <> short 'j'
+	<> help "enable JSON output"
+	)
 
-jobsOption :: Option
-jobsOption = Option ['J'] ["jobs"] (ReqArg set paramNumber)
-	"enable concurrent jobs"
-  where
-	set s = case readish s of
-		Nothing -> error "Bad --jobs number"
-		Just n -> Annex.setOutput (ParallelOutput n)
+parseJobsOption :: Parser GlobalSetter
+parseJobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ 
+	option auto
+		( long "jobs" <> short 'J' <> metavar paramNumber
+		<> help "enable concurrent jobs"
+		)
 
-timeLimitOption :: Option
-timeLimitOption = Option ['T'] ["time-limit"]
-	(ReqArg Limit.addTimeLimit paramTime)
-	"stop after the specified amount of time"
-
-autoOption :: Option
-autoOption = flagOption ['a'] "auto" "automatic mode"
+parseTimeLimitOption :: Parser GlobalSetter
+parseTimeLimitOption = globalSetter Limit.addTimeLimit $ strOption
+	( long "time-limit" <> short 'T' <> metavar paramTime
+	<> help "stop after the specified amount of time"
+	)
 
 parseAutoOption :: Parser Bool
 parseAutoOption = switch

CmdLine/GitAnnexShell.hs

@@ -73,9 +73,6 @@ options = commonOptions ++
 	unexpected expected s = error $
 		"expected repository UUID " ++ expected ++ " but found " ++ s
 
-header :: String
-header = "git-annex-shell [-c] command [parameters ...] [option ...]"
-
 run :: [String] -> IO ()
 run [] = failure
 -- skip leading -c options, passed by eg, ssh
@@ -142,14 +139,16 @@ parseFields = map (separate (== '='))
 {- Only allow known fields to be set, ignore others.
  - Make sure that field values make sense. -}
 checkField :: (String, String) -> Bool
-checkField (field, value)
-	| field == fieldName remoteUUID = fieldCheck remoteUUID value
-	| field == fieldName associatedFile = fieldCheck associatedFile value
-	| field == fieldName direct = fieldCheck direct value
+checkField (field, val)
+	| field == fieldName remoteUUID = fieldCheck remoteUUID val
+	| field == fieldName associatedFile = fieldCheck associatedFile val
+	| field == fieldName direct = fieldCheck direct val
 	| otherwise = False
 
 failure :: IO ()
-failure = error $ "bad parameters\n\n" ++ usage header cmds
+failure = error $ "bad parameters\n\n" ++ usage h cmds
+  where
+	h = "git-annex-shell [-c] command [parameters ...] [option ...]"
 
 checkNotLimited :: IO ()
 checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"

Command/Drop.hs

@@ -24,7 +24,7 @@ import qualified Data.Set as S
 
 cmd :: Command
 cmd = command "drop" SectionCommon
-	"indicate content of files not currently wanted"
+	"remove content of files from repository"
 	paramPaths (seek <$$> optParser)
 
 data DropOptions = DropOptions

Command/Sync.hs

@@ -52,26 +52,32 @@ import Control.Concurrent.MVar
 import qualified Data.Map as M
 
 cmd :: Command
-cmd = withOptions syncOptions $
-	command "sync" SectionCommon 
-		"synchronize local repository with remotes"
-		(paramRepeating paramRemote) (withParams seek)
+cmd = command "sync" SectionCommon 
+	"synchronize local repository with remotes"
+	(paramRepeating paramRemote) (seek <$$> optParser)
 
-syncOptions :: [Option]
-syncOptions =
-	[ contentOption
-	, messageOption
-	, allOption
-	]
+data SyncOptions  = SyncOptions
+	{ syncWith :: CmdParams
+	, contentOption :: Bool
+	, messageOption :: Maybe String
+	, keyOptions :: Maybe KeyOptions
+	}
 
-contentOption :: Option
-contentOption = flagOption [] "content" "also transfer file contents"
+optParser :: CmdParamsDesc -> Parser SyncOptions
+optParser desc = SyncOptions
+	<$> cmdParams desc
+	<*> switch
+		( long "content"
+		<> help "also transfer file contents"
+		)
+	<*> optional (strOption
+		( long "message" <> short 'm' <> metavar "MSG"
+		<> help "commit message"
+		))
+	<*> optional parseAllOption
 
-messageOption :: Option
-messageOption = fieldOption ['m'] "message" "MSG" "specify commit message"
-
-seek :: CmdParams -> CommandSeek
-seek rs = do
+seek :: SyncOptions -> CommandSeek
+seek o = do
 	prepMerge
 
 	-- There may not be a branch checked out until after the commit,
@@ -90,20 +96,20 @@ seek rs = do
 		)
 	let withbranch a = a =<< getbranch
 
-	remotes <- syncRemotes rs
+	remotes <- syncRemotes (syncWith o)
 	let gitremotes = filter Remote.gitSyncableRemote remotes
 	let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes
 
 	-- Syncing involves many actions, any of which can independently
 	-- fail, without preventing the others from running.
 	seekActions $ return $ concat
-		[ [ commit ]
+		[ [ commit o ]
 		, [ withbranch mergeLocal ]
 		, map (withbranch . pullRemote) gitremotes
 		,  [ mergeAnnex ]
 		]
-	whenM (Annex.getFlag $ optionName contentOption) $
-		whenM (seekSyncContent dataremotes) $
+	when (contentOption o) $
+		whenM (seekSyncContent o dataremotes) $
 			-- Transferring content can take a while,
 			-- and other changes can be pushed to the git-annex
 			-- branch on the remotes in the meantime, so pull
@@ -151,15 +157,14 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
 	
 	fastest = fromMaybe [] . headMaybe . Remote.byCost
 
-commit :: CommandStart
-commit = ifM (annexAutoCommit <$> Annex.getGitConfig)
+commit :: SyncOptions -> CommandStart
+commit o = ifM (annexAutoCommit <$> Annex.getGitConfig)
 	( go
 	, stop
 	)
   where
 	go = next $ next $ do
-		commitmessage <- maybe commitMsg return
-			=<< Annex.getField (optionName messageOption)
+		commitmessage <- maybe commitMsg return (messageOption o)
 		showStart "commit" ""
 		Annex.Branch.commit "update"
 		ifM isDirect
@@ -372,14 +377,16 @@ newer remote b = do
  -
  - If any file movements were generated, returns true.
  -}
-seekSyncContent :: [Remote] -> Annex Bool
-seekSyncContent rs = do
+seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool
+seekSyncContent o rs = do
 	mvar <- liftIO newEmptyMVar
-	bloom <- ifM (Annex.getFlag "all")
-		( Just <$> genBloomFilter (seekworktree mvar [])
-		, seekworktree mvar [] (const noop) >> pure Nothing
-		)
-	withKeyOptions' False (seekkeys mvar bloom) (const noop) []
+	bloom <- case keyOptions o of
+		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])
+		_ -> seekworktree mvar [] (const noop) >> pure Nothing
+	withKeyOptions' (keyOptions o) False
+		(seekkeys mvar bloom) 
+		(const noop)
+		[]
 	liftIO $ not <$> isEmptyMVar mvar
   where
 	seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=

Command/Unused.hs

@@ -57,13 +57,13 @@ start = do
 	!refspec <- maybe cfgrefspec (either error id . parseRefSpec)
 		<$> Annex.getField (optionName refSpecOption)
 	from <- Annex.getField (optionName unusedFromOption)
-	let (name, action) = case from of
+	let (name, perform) = case from of
 		Nothing -> (".", checkUnused refspec)
 		Just "." -> (".", checkUnused refspec)
 		Just "here" -> (".", checkUnused refspec)
 		Just n -> (n, checkRemoteUnused n refspec)
 	showStart "unused" name
-	next action
+	next perform
 
 checkUnused :: RefSpec -> CommandPerform
 checkUnused refspec = chain 0
@@ -127,11 +127,11 @@ unusedMsg u = unusedMsg' u
 	["Some annexed data is no longer used by any files:"]
 	[dropMsg Nothing]
 unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String
-unusedMsg' u header trailer = unlines $
-	header ++
+unusedMsg' u mheader mtrailer = unlines $
+	mheader ++
 	table u ++
 	["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
-	trailer
+	mtrailer
 
 remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
 remoteUnusedMsg r u = unusedMsg' u

Command/Whereis.hs

@@ -21,6 +21,14 @@ cmd = noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions)
 		"lists repositories that have file content"
 		paramPaths (withParams seek)
 
+data WhereisOptions = WhereisOptions
+	{ whereisFiles :: CmdParams
+	, jsonOption :: GlobalSetter
+	, keyOptions :: Maybe KeyOptions
+	}
+
+-- TODO: annexedMatchingOptions
+
 seek :: CmdParams -> CommandSeek
 seek ps = do
 	m <- remoteMap id

Types/DeferredParse.hs

@@ -12,6 +12,8 @@ module Types.DeferredParse where
 import Annex
 import Common
 
+import Options.Applicative.Types
+
 -- 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
 -- value before using getParsed repeatedly.
@@ -31,3 +33,18 @@ instance DeferredParseClass (DeferredParse a) where
 instance DeferredParseClass (Maybe (DeferredParse a)) where
 	finishParse Nothing = pure Nothing
 	finishParse (Just v) = Just <$> finishParse v
+
+instance DeferredParseClass [DeferredParse a] where
+	finishParse v = mapM finishParse v
+
+-- Use when the Annex action modifies Annex state.
+type GlobalSetter = DeferredParse ()
+
+globalOpt :: Annex () -> Parser Bool -> Parser GlobalSetter
+globalOpt setter parser = go <$> parser
+  where
+	go False = ReadyParse ()
+	go True = DeferredParse setter
+
+globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter
+globalSetter setter parser = DeferredParse . setter <$> parser

doc/git-annex-drop.mdwn

@@ -1,6 +1,6 @@
 # NAME
 
-git-annex drop - indicate content of files not currently wanted
+git-annex drop - remove content of files from repository
 
 # SYNOPSIS