wip

CmdLine/GitAnnex/Options.hs

@@ -1,4 +1,4 @@
-{- git-annex options
+{- git-annex command-line option parsing
  -
  - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
@@ -8,6 +8,7 @@
 module CmdLine.GitAnnex.Options where
 
 import System.Console.GetOpt
+import Options.Applicative
 
 import Common.Annex
 import qualified Git.Config
@@ -15,6 +16,8 @@ import Git.Types
 import Types.TrustLevel
 import Types.NumCopies
 import Types.Messages
+import Types.Key
+import Types.Command
 import qualified Annex
 import qualified Remote
 import qualified Limit
@@ -51,24 +54,50 @@ gitAnnexOptions = commonOptions ++
 		>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
 		>>= Annex.changeGitRepo
 
--- Options for matching on annexed keys, rather than work tree files.
-keyOptions :: [Option]
-keyOptions = [ allOption, unusedOption, keyOption]
+-- Options for acting on keys, rather than work tree files.
+data KeyOptions = KeyOptions
+	{ wantAllKeys :: Bool
+	, wantUnusedKeys :: Bool
+	, wantIncompleteKeys :: Bool
+	, wantSpecificKey :: Maybe Key
+	}
 
-allOption :: Option
-allOption = Option ['A'] ["all"] (NoArg (Annex.setFlag "all"))
-	"operate on all versions of all files"
+parseKeyOptions :: Bool -> Parser KeyOptions
+parseKeyOptions allowincomplete = KeyOptions
+	<$> parseAllKeysOption
+	<*> parseUnusedKeysOption
+	<*> (if allowincomplete then parseIncompleteOption else pure False)
+	<*> parseSpecificKeyOption
 
-unusedOption :: Option
-unusedOption = Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused"))
-	"operate on files found by last run of git-annex unused"
+parseAllKeysOption :: Parser Bool
+parseAllKeysOption = switch
+	( long "all"
+	<> short 'A'
+	<> help "operate on all versions of all files"
+	)
 
-keyOption :: Option
-keyOption = Option [] ["key"] (ReqArg (Annex.setField "key") paramKey)
-		"operate on specified key"
+parseUnusedKeysOption :: Parser Bool
+parseUnusedKeysOption = switch
+	( long "unused"
+	<> short 'U'
+	<> help "operate on files found by last run of git-annex unused"
+	)
 
-incompleteOption :: Option
-incompleteOption = flagOption [] "incomplete" "resume previous downloads"
+parseSpecificKeyOption :: Parser (Maybe Key)
+parseSpecificKeyOption = finalOpt $ option (str >>= parseKey)
+	( long "key"
+	<> help "operate on specified key"
+	<> metavar paramKey
+	)
+
+parseKey :: Monad m => String -> m Key
+parseKey = maybe (fail "invalid key") return . file2key
+
+parseIncompleteOption :: Parser Bool
+parseIncompleteOption = switch
+	( long "incomplete"
+	<> help "resume previous downloads"
+	)
 
 -- Options to match properties of annexed files.
 annexedMatchingOptions :: [Option]
@@ -161,3 +190,20 @@ timeLimitOption = Option ['T'] ["time-limit"]
 
 autoOption :: Option
 autoOption = flagOption ['a'] "auto" "automatic mode"
+
+parseAutoOption :: Parser Bool
+parseAutoOption = switch
+	( long "auto"
+	<> short 'a'
+	<> help "automatic mode"
+	)
+
+{- Parser that accepts all non-option params. -}
+cmdParams :: CmdParamsDesc -> Parser CmdParams
+cmdParams paramdesc = many (argument str (metavar paramdesc))
+
+{- Makes an option parser that is normally required be optional;
+ -  - its switch can be given zero or more times, and the last one
+ -   - given will be used. -}
+finalOpt :: Parser a -> Parser (Maybe a)
+finalOpt = lastMaybe <$$> many

CmdLine/Seek.hs

@@ -23,6 +23,7 @@ import qualified Git.LsTree as LsTree
 import Git.FilePath
 import qualified Limit
 import CmdLine.Option
+import CmdLine.GitAnnex.Options
 import CmdLine.Action
 import Logs.Location
 import Logs.Unused
@@ -171,40 +172,38 @@ withNothing _ _ = error "This command takes no parameters."
  -
  - Otherwise falls back to a regular CommandSeek action on
  - whatever params were passed. -}
-withKeyOptions :: Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
-withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do
+withKeyOptions :: KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
+withKeyOptions ko auto keyaction = withKeyOptions' ko auto $ \getkeys -> do
 	matcher <- Limit.getMatcher
 	seekActions $ map (process matcher) <$> getkeys
   where
 	process matcher k = ifM (matcher $ MatchingKey k)
-		( keyop k
+		( keyaction k
 		, return Nothing
 		)
 
-withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
-withKeyOptions' auto keyop fallbackop params = do
+withKeyOptions' :: KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
+withKeyOptions' ko auto keyaction fallbackaction params = do
 	bare <- fromRepo Git.repoIsLocalBare
-	allkeys <- Annex.getFlag "all"
-	unused <- Annex.getFlag "unused"
-	incomplete <- Annex.getFlag "incomplete"
-	specifickey <- Annex.getField "key"
+	let allkeys = wantAllKeys ko
+	let unused = wantUnusedKeys ko
+	let incomplete = wantIncompleteKeys ko
+	let specifickey = wantSpecificKey ko
 	when (auto && bare) $
 		error "Cannot use --auto in a bare repository"
 	case	(allkeys, unused, incomplete, null params, specifickey) of
 		(False  , False , False     , True       , Nothing)
 			| bare -> go auto loggedKeys
-			| otherwise -> fallbackop params
-		(False  , False , False     , _          , Nothing) -> fallbackop params
+			| otherwise -> fallbackaction params
+		(False  , False , False     , _          , Nothing) -> fallbackaction params
 		(True   , False , False     , True       , Nothing) -> go auto loggedKeys
 		(False  , True  , False     , True       , Nothing) -> go auto unusedKeys'
 		(False  , False , True      , True       , Nothing) -> go auto incompletekeys
-		(False  , False , False     , True       , Just ks) -> case file2key ks of
-			Nothing -> error "Invalid key"
-			Just k -> go auto $ return [k]
+		(False  , False , False     , True       , Just k) -> go auto $ return [k]
 		_ -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete"
   where
 	go True _ = error "Cannot use --auto with --all or --unused or --key or --incomplete"
-	go False getkeys = keyop getkeys
+	go False getkeys = keyaction getkeys
 	incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True
 
 prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]