converted fsck's options to optparse-applicative

Global options and seeking and key options are still to be done.

CmdLine.hs

@@ -75,8 +75,13 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v)
 parseCmd allargs allcmds getparser = 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)
+	pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds)
+		( O.fullDesc
+		<> O.progDesc "hiya"
+		<> O.header "ook - aaa"
+		)
+	mkcommand c = O.command (cmdname c) $ O.info (mkparser c) 
+		(O.fullDesc <> O.progDesc (cmddesc c))
 	mkparser c = (,)
 		<$> pure c
 		<*> getparser c

Command.hs

@@ -1,6 +1,6 @@
 {- git-annex command infrastructure
  -
- - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -8,6 +8,8 @@
 module Command (
 	command,
 	withParams,
+	cmdParams,
+	finalOpt,
 	noRepo,
 	noCommit,
 	noMessages,
@@ -36,16 +38,24 @@ 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 :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
 command name section desc paramdesc mkparser =
 	Command [] commonChecks False False name 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)
+{- Simple option parser that takes all non-option params as-is. -}
+withParams :: (CmdParams -> v) -> CmdParamsDesc -> O.Parser v
+withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc
+
+{- Parser that accepts all non-option params. -}
+cmdParams :: CmdParamsDesc -> O.Parser CmdParams
+cmdParams paramdesc = O.many (O.argument O.str (O.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 :: O.Parser a -> O.Parser (Maybe a)
+finalOpt = lastMaybe <$$> O.many
 
 {- Indicates that a command doesn't need to commit any changes to
  - the git-annex branch. -}

Command/Fsck.hs

@@ -39,42 +39,56 @@ import qualified Database.Fsck as FsckDb
 
 import Data.Time.Clock.POSIX
 import System.Posix.Types (EpochTime)
+import Options.Applicative hiding (command)
 
 cmd :: Command
-cmd = withOptions fsckOptions $ 
-	command "fsck" SectionMaintenance "check for problems"
-		paramPaths (withParams seek)
+cmd = command "fsck" SectionMaintenance "check for problems"
+	paramPaths (seek <$$> optParser)
 
-fsckFromOption :: Option
-fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote"
+data FsckOptions = FsckOptions
+	{ fsckFiles :: CmdParams
+	, fsckFromOption :: Maybe String
+	, startIncrementalOption :: Bool
+	, moreIncrementalOption :: Bool
+	, incrementalScheduleOption :: Maybe Duration
+	}
 
-startIncrementalOption :: Option
-startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck"
+optParser :: CmdParamsDesc -> Parser FsckOptions
+optParser desc = FsckOptions
+	<$> cmdParams desc
+	<*> finalOpt (strOption 
+		( long "from"
+		<> short 'f'
+		<> metavar paramRemote
+		<> help "check remote"
+		))
+	<*> switch
+		( long "incremental"
+		<> short 'S'
+		<> help "start an incremental fsck"
+		)
+	<*> switch
+		( long "more"
+		<> short 'm'
+		<> help "continue an incremental fsck"
+		)
+	<*> finalOpt (option (str >>= parseDuration)
+		( long "incremental-schedule"
+		<> metavar paramTime
+		<> help "schedule incremental fscking"
+		))
 
-moreIncrementalOption :: Option
-moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck"
+-- TODO: keyOptions, annexedMatchingOptions
 
-incrementalScheduleOption :: Option
-incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime
-	"schedule incremental fscking"
-
-fsckOptions :: [Option]
-fsckOptions = 
-	[ fsckFromOption
-	, startIncrementalOption
-	, moreIncrementalOption
-	, incrementalScheduleOption
-	] ++ keyOptions ++ annexedMatchingOptions
-
-seek :: CmdParams -> CommandSeek
-seek ps = do
-	from <- getOptionField fsckFromOption Remote.byNameWithUUID
+seek :: FsckOptions -> CommandSeek
+seek o = do
+	from <- Remote.byNameWithUUID (fsckFromOption o)
 	u <- maybe getUUID (pure . Remote.uuid) from
-	i <- getIncremental u
+	i <- getIncremental u o
 	withKeyOptions False
 		(\k -> startKey i k =<< getNumCopies)
 		(withFilesInGit $ whenAnnexed $ start from i)
-		ps
+		(fsckFiles o)
 	withFsckDb i FsckDb.closeDb
 	void $ tryIO $ recordActivity Fsck u
 
@@ -498,13 +512,10 @@ getStartTime u = do
 
 data Incremental = StartIncremental FsckDb.FsckHandle | ContIncremental FsckDb.FsckHandle | NonIncremental
 
-getIncremental :: UUID -> Annex Incremental
-getIncremental u = do
-	i <- maybe (return False) (checkschedule . parseDuration)
-		=<< Annex.getField (optionName incrementalScheduleOption)
-	starti <- getOptionFlag startIncrementalOption
-	morei <- getOptionFlag moreIncrementalOption
-	case (i, starti, morei) of
+getIncremental :: UUID -> FsckOptions -> Annex Incremental
+getIncremental u  o = do
+	i <- maybe (return False) checkschedule (incrementalScheduleOption o)
+	case (i, startIncrementalOption o, moreIncrementalOption o) of
 		(False, False, False) -> return NonIncremental
 		(False, True, False) -> startIncremental
 		(False ,False, True) -> contIncremental
@@ -521,8 +532,7 @@ getIncremental u = do
 			)
 	contIncremental = ContIncremental <$> FsckDb.openDb u
 
-	checkschedule Nothing = error "bad --incremental-schedule value"
-	checkschedule (Just delta) = do
+	checkschedule delta = do
 		Annex.addCleanup FsckCleanup $ do
 			v <- getStartTime u
 			case v of

Types/Command.hs

@@ -43,7 +43,7 @@ data Command = Command
 	, cmdnocommit :: Bool        -- don't commit journalled state changes
 	, cmdnomessages :: Bool      -- don't output normal messages
 	, cmdname :: String
-	, cmdparamdesc :: String     -- description of params for usage
+	, cmdparamdesc :: CmdParamsDesc -- description of params for usage
 	, cmdsection :: CommandSection
 	, cmddesc :: String          -- description of command for usage
 	, cmdparser :: CommandParser -- command line parser
@@ -54,6 +54,8 @@ data Command = Command
  - are parsed. -}
 type CmdParams = [String]
 
+type CmdParamsDesc = String
+
 {- CommandCheck functions can be compared using their unique id. -}
 instance Eq CommandCheck where
 	a == b = idCheck a == idCheck b