cleanup

Checks.hs

@@ -31,9 +31,6 @@ toOpt = CommandCheck 2 $ do
 	v <- Annex.getState Annex.toremote
 	unless (v == Nothing) $ error "cannot use --to with this command"
 
-checkCommand :: Command -> Annex ()
-checkCommand Command { cmdcheck = c } = sequence_ $ map runCheck c
-
 dontCheck :: CommandCheck -> Command -> Command
 dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
 

CmdLine.hs

@@ -21,45 +21,41 @@ import qualified Git
 import Annex.Content
 import Command
 
+type Params = [String]
+type Flags = [Annex ()]
+
 {- Runs the passed command line. -}
-dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
+dispatch :: Params -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
 dispatch args cmds options header gitrepo = do
 	setupConsole
 	state <- Annex.new gitrepo
-	((cmd, actions), state') <- Annex.run state $ parseCmd args header cmds options
+	(actions, state') <- Annex.run state $ do
+		sequence_ flags
+		prepCommand cmd params
 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown]
-
-{- Parses command line, stores configure flags, and returns a 
- - list of actions to be run in the Annex monad and the Command
- - being run. -}
-parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex (Command, [Annex Bool])
-parseCmd argv header cmds options = do
-	(flags, params) <- liftIO getopt
-	when (null params) $ error $ "missing command" ++ usagemsg
-	let (c:rest) = params
-	case lookupCmd c of
-		[] -> error $ "unknown command " ++ c ++ " " ++ usagemsg
-		[cmd] -> do
-			_ <- sequence flags
-			checkCommand cmd
-			as <- prepCommand cmd rest
-			return (cmd, as)
-		_ -> error $ "internal error: multiple matching commands for " ++ c
 	where
-		getopt = case getOpt Permute options argv of
-			(flags, params, []) ->
-				return (flags, params)
-			(_, _, errs) ->
-				ioError (userError (concat errs ++ usagemsg))
-		lookupCmd cmd = filter (\c -> cmd  == cmdname c) cmds
-		usagemsg = "\n\n" ++ usage header cmds options
+		(flags, cmd, params) = parseCmd args cmds options 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
+	where
+		check (_, [], []) = err "missing command"
+		check (flags, name:rest, [])
+			| null matches = err $ "unknown command " ++ name
+			| otherwise = (flags, head matches, rest)
+			where
+				matches = filter (\c -> name == cmdname c) cmds
+		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 (header ++ "\n\nOptions:") options ++
-		"\nCommands:\n" ++ cmddescs
+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 ++
@@ -73,23 +69,23 @@ usage header cmds options =
 {- Runs a list of Annex actions. Catches IO errors and continues
  - (but explicitly thrown errors terminate the whole command).
  -}
-tryRun :: Annex.AnnexState -> Command -> [Annex Bool] -> IO ()
+tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
 tryRun = tryRun' 0
-tryRun' :: Integer -> Annex.AnnexState -> Command -> [Annex Bool] -> IO ()
-tryRun' errnum state cmd (a:as) = do
-	result <- try $ Annex.run state $ do
-		Annex.Queue.flushWhenFull
-		a
-	case result of
-		Left err -> do
-			Annex.eval state $ do
-				showErr err
-				showEndFail
-			tryRun' (errnum + 1) state cmd as
-		Right (True,state') -> tryRun' errnum state' cmd as
-		Right (False,state') -> tryRun' (errnum + 1) state' cmd as
-tryRun' errnum _ cmd [] = when (errnum > 0) $
-		error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
+tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
+tryRun' errnum _ cmd []
+	| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
+	| otherwise = return ()
+tryRun' errnum state cmd (a:as) = run >>= handle
+	where
+		run = try $ Annex.run state $ do
+			Annex.Queue.flushWhenFull
+			a
+		handle (Left err) = showerr err >> cont False state
+		handle (Right (success, state')) = cont success state'
+		cont success s = tryRun' (if success then errnum else errnum + 1) s cmd as
+		showerr err = Annex.eval state $ do
+			showErr err
+			showEndFail
 
 {- Actions to perform each time ran. -}
 startup :: Annex Bool

Command.hs

@@ -46,25 +46,24 @@ next a = return $ Just a
 stop :: Annex (Maybe a)
 stop = return Nothing
 
-{- Prepares a list of actions to run to perform a command, based on
- - the parameters passed to it. -}
-prepCommand :: Command -> [String] -> Annex [Annex Bool]
-prepCommand cmd ps = return . map doCommand =<< seekCommand cmd ps
-
-{- Runs a command through the seek stage. -}
-seekCommand :: Command -> [String] -> Annex [CommandStart]
-seekCommand Command { cmdseek = seek } ps = concat <$> mapM (\s -> s ps) seek
+{- Prepares to run a command via the check and seek stages, returning a
+ - list of actions to perform to run the command. -}
+prepCommand :: Command -> [String] -> Annex [CommandCleanup]
+prepCommand Command { cmdseek = seek, cmdcheck = c } params = do
+	sequence_ $ map runCheck c
+	map doCommand . concat <$> mapM (\s -> s params) seek
 
 {- Runs a command through the start, perform and cleanup stages -}
 doCommand :: CommandStart -> CommandCleanup
 doCommand = start
 	where
-		start   = stage $ maybe success perform
+		start   = stage $ maybe skip perform
 		perform = stage $ maybe failure cleanup
-		cleanup = stage $ \r -> showEndResult r >> return r
+		cleanup = stage $ status
 		stage = (=<<)
-		success = return True
+		skip = return True
 		failure = showEndFail >> return False
+		status r = showEndResult r >> return r
 
 notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
 notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file