fix inversion of control in CommandSeek (no behavior changes)

I've been disliking how the command seek actions were written for some
time, with their inversion of control and ugly workarounds.

The last straw to fix it was sync --content, which didn't fit the
Annex [CommandStart] interface well at all. I have not yet made it take
advantage of the changed interface though.

The crucial change, and probably why I didn't do it this way from the
beginning, is to make each CommandStart action be run with exceptions
caught, and if it fails, increment a failure counter in annex state.
So I finally remove the very first code I wrote for git-annex, which
was before I had exception handling in the Annex monad, and so ran outside
that monad, passing state explicitly as it ran each CommandStart action.

This was a real slog from 1 to 5 am.

Test suite passes.

Memory usage is lower than before, sometimes by a couple of megabytes, and
remains constant, even when running in a large repo, and even when
repeatedly failing and incrementing the error counter. So no accidental
laziness space leaks.

Wall clock speed is identical, even in large repos.

This commit was sponsored by an anonymous bitcoiner.

Annex.hs

@@ -109,6 +109,7 @@ data AnnexState = AnnexState
 	, cleanup :: M.Map String (Annex ())
 	, inodeschanged :: Maybe Bool
 	, useragent :: Maybe String
+	, errcounter :: Integer
 	}
 
 newState :: GitConfig -> Git.Repo -> AnnexState
@@ -143,6 +144,7 @@ newState c r = AnnexState
 	, cleanup = M.empty
 	, inodeschanged = Nothing
 	, useragent = Nothing
+	, errcounter = 0
 	}
 
 {- Makes an Annex state object for the specified git repo.

Annex/Drop.hs

@@ -92,7 +92,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
 
 	checkdrop fs n@(have, numcopies, _untrusted) u a =
 		ifM (allM (wantDrop True u . Just) fs)
-			( ifM (safely $ doCommand $ a (Just numcopies))
+			( ifM (safely $ callCommand $ a (Just numcopies))
 				( do
 					liftIO $ debugM "drop" $ unwords
 						[ "dropped"

CmdLine.hs

@@ -23,7 +23,6 @@ import System.Posix.Signals
 
 import Common.Annex
 import qualified Annex
-import qualified Annex.Queue
 import qualified Git
 import qualified Git.AutoCorrect
 import Annex.Content
@@ -41,7 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 		Left e -> maybe (throw e) (\a -> a params) (cmdnorepo cmd)
 		Right g -> do
 			state <- Annex.new g
-			(actions, state') <- Annex.run state $ do
+			Annex.eval state $ do
 				checkEnvironment
 				checkfuzzy
 				forM_ fields $ uncurry Annex.setField
@@ -50,8 +49,9 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 				sequence_ flags
 				whenM (annexDebug <$> Annex.getGitConfig) $
 					liftIO enableDebugOutput
-				prepCommand cmd params
+				startup
-		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd]
+				performCommand cmd params
+				shutdown $ cmdnocommit cmd
   where
 	err msg = msg ++ "\n\n" ++ usage header allcmds
 	cmd = Prelude.head cmds
@@ -92,44 +92,19 @@ getOptCmd argv cmd commonoptions = check $
 		, commandUsage cmd
 		]
 
-{- Runs a list of Annex actions. Catches IO errors and continues
- - (but explicitly thrown errors terminate the whole command).
- -}
-tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
-tryRun = tryRun' 0
-tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
-tryRun' errnum _ cmd []
-	| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
-	| otherwise = noop
-tryRun' errnum state cmd (a:as) = do
-	r <- run
-	handle $! r
-  where
-	run = tryIO $ 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 = do
-		let errnum' = if success then errnum else errnum + 1
-		(tryRun' $! errnum') s cmd as
-	showerr err = Annex.eval state $ do
-		showErr err
-		showEndFail
-
 {- Actions to perform each time ran. -}
-startup :: Annex Bool
+startup :: Annex ()
-startup = liftIO $ do
+startup =
 #ifndef mingw32_HOST_OS
-	void $ installHandler sigINT Default Nothing
+	liftIO $ void $ installHandler sigINT Default Nothing
+#else
+	return ()
 #endif
-	return True
 
 {- Cleanup actions. -}
-shutdown :: Bool -> Annex Bool
+shutdown :: Bool -> Annex ()
 shutdown nocommit = do
 	saveState nocommit
 	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
 	liftIO reapZombies -- zombies from long-running git processes
 	sshCleanup -- ssh connection caching
-	return True

Command.hs

@@ -1,10 +1,12 @@
 {- git-annex command infrastructure
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
+
 module Command (
 	command,
 	noRepo,
@@ -14,8 +16,7 @@ module Command (
 	next,
 	stop,
 	stopUnless,
-	prepCommand,
+	runCommand,
-	doCommand,
 	whenAnnexed,
 	ifAnnexed,
 	isBareRepo,
@@ -35,12 +36,13 @@ import Types.Option as ReExported
 import Seek as ReExported
 import Checks as ReExported
 import Usage as ReExported
+import RunCommand as ReExported
 import Logs.Trust
 import Config
 import Annex.CheckAttr
 
 {- Generates a normal command -}
-command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command
+command :: String -> String -> CommandSeek -> CommandSection -> String -> Command
 command = Command [] Nothing commonChecks False False
 
 {- Indicates that a command doesn't need to commit any changes to
@@ -74,25 +76,6 @@ stop = return Nothing
 stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
 stopUnless c a = ifM c ( a , stop )
 
-{- 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
-	mapM_ 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 skip perform
-	perform = stage $ maybe failure cleanup
-	cleanup = stage $ status
-	stage = (=<<)
-	skip = return True
-	failure = showEndFail >> return False
-	status r = showEndResult r >> return r
-
 {- Modifies an action to only act on files that are already annexed,
  - and passes the key and backend on to it. -}
 whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)

Command/Add.hs

@@ -41,18 +41,18 @@ def = [notBareRepo $ command "add" paramPaths seek SectionCommon
 {- Add acts on both files not checked into git yet, and unlocked files.
  -
  - In direct mode, it acts on any files that have changed. -}
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ go withFilesNotInGit
+	matcher <- largeFilesMatcher
-	, whenNotDirect $ go withFilesUnlocked
+	let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
-	, whenDirect $ go withFilesMaybeModified
+		( start file
-	]
+		, stop
-  where
+		)
-  	go a = withValue largeFilesMatcher $ \matcher ->
+	go withFilesNotInGit
-		a $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force)
+	ifM isDirect
-			( start file
+		( go withFilesMaybeModified
-			, stop
+		, go withFilesUnlocked
-			)
+		)
 
 {- The add subcommand annexes a file, generating a key for it using a
  - backend, and then moving it into the annex directory and setting up

Command/AddUnused.hs

@@ -18,8 +18,8 @@ def :: [Command]
 def = [notDirect $ command "addunused" (paramRepeating paramNumRange)
 	seek SectionMaintenance "add back unused files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withUnusedMaps start]
+seek = withUnusedMaps start
 
 start :: UnusedMaps -> Int -> CommandStart
 start = startUnused "addunused" perform

Command/AddUrl.hs

@@ -47,11 +47,12 @@ pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to us
 relaxedOption :: Option
 relaxedOption = Option.flag [] "relaxed" "skip size check"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField fileOption return $ \f ->
+seek ps = do
-	withFlag relaxedOption $ \relaxed ->
+	f <- getOptionField fileOption return
-	withField pathdepthOption (return . maybe Nothing readish) $ \d ->
+	relaxed <- getOptionFlag relaxedOption
-	withStrings $ start relaxed f d]
+	d <- getOptionField pathdepthOption (return . maybe Nothing readish)
+	withStrings (start relaxed f d) ps
 
 start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
 start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s

Command/Assistant.hs

@@ -37,12 +37,13 @@ autoStartOption = Option.flag [] "autostart" "start in known repositories"
 startDelayOption :: Option
 startDelayOption = Option.field [] "startdelay" paramNumber "delay before running startup scan"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFlag Command.Watch.stopOption $ \stopdaemon ->
+seek ps = do
-	withFlag Command.Watch.foregroundOption $ \foreground ->
+	stopdaemon <- getOptionFlag Command.Watch.stopOption
-	withFlag autoStartOption $ \autostart ->
+	foreground <- getOptionFlag Command.Watch.foregroundOption
-	withField startDelayOption (pure . maybe Nothing parseDuration) $ \startdelay -> 
+	autostart <- getOptionFlag autoStartOption
-	withNothing $ start foreground stopdaemon autostart startdelay]
+	startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration)
+	withNothing (start foreground stopdaemon autostart startdelay) ps
 
 start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
 start foreground stopdaemon autostart startdelay

Command/Commit.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "commit" paramNothing seek
 	SectionPlumbing "commits any staged changes to the git-annex branch"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = next $ next $ do

Command/ConfigList.hs

@@ -17,8 +17,8 @@ def :: [Command]
 def = [noCommit $ command "configlist" paramNothing seek
 	SectionPlumbing "outputs relevant git configuration"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Copy.hs

@@ -18,13 +18,14 @@ def :: [Command]
 def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
 	SectionCommon "copy content of files to/from another repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (Command.Move.startKey to from False) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from
+	 	(Command.Move.startKey to from False)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from)
+		ps
 
 {- A copy is just a move that does not delete the source file.
  - However, --auto mode avoids unnecessary copies, and avoids getting or

Command/Dead.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [command "dead" (paramRepeating paramRemote) seek
 	SectionSetup "hide a lost repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/Describe.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "describe" (paramPair paramRemote paramDesc) seek
 	SectionSetup "change description of a repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (name:description) = do

Command/Direct.hs

@@ -23,8 +23,8 @@ def = [notBareRepo $ noDaemonRunning $
 	command "direct" paramNothing seek
 		SectionSetup "switch repository to direct mode"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = ifM isDirect ( stop , next perform )

Command/Drop.hs

@@ -27,9 +27,10 @@ def = [withOptions [fromOption] $ command "drop" paramPaths seek
 fromOption :: Option
 fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField fromOption Remote.byNameWithUUID $ \from ->
+seek ps = do
-	withFilesInGit $ whenAnnexed $ start from]
+	from <- getOptionField fromOption Remote.byNameWithUUID
+	withFilesInGit (whenAnnexed $ start from) ps
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = checkDropAuto from file key $ \numcopies ->

Command/DropKey.hs

@@ -18,8 +18,8 @@ def :: [Command]
 def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
 	SectionPlumbing "drops annexed content for specified keys"] 
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = stopUnless (inAnnex key) $ do

Command/DropUnused.hs

@@ -21,8 +21,8 @@ def = [withOptions [Command.Drop.fromOption] $
 	command "dropunused" (paramRepeating paramNumRange)
 		seek SectionMaintenance "drop unused file content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withUnusedMaps start]
+seek = withUnusedMaps start
 
 start :: UnusedMaps -> Int -> CommandStart
 start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation)

Command/EnableRemote.hs

@@ -20,8 +20,8 @@ def = [command "enableremote"
 	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
 	seek SectionSetup "enables use of an existing special remote"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start [] = unknownNameError "Specify the name of the special remote to enable."

Command/ExamineKey.hs

@@ -10,7 +10,7 @@ module Command.ExamineKey where
 import Common.Annex
 import Command
 import qualified Utility.Format
-import Command.Find (formatOption, withFormat, showFormatted, keyVars)
+import Command.Find (formatOption, getFormat, showFormatted, keyVars)
 import Types.Key
 import GitAnnex.Options
 
@@ -19,8 +19,10 @@ def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
 	command "examinekey" (paramRepeating paramKey) seek
 	SectionPlumbing "prints information from a key"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFormat $ \f -> withKeys $ start f]
+seek ps = do
+	format <- getFormat
+	withKeys (start format) ps
 
 start :: Maybe Utility.Format.Format -> Key -> CommandStart
 start format key = do

Command/Find.hs

@@ -27,8 +27,8 @@ def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOpti
 formatOption :: Option
 formatOption = Option.field [] "format" paramFormat "control format of output"
 
-withFormat :: (Maybe Utility.Format.Format -> CommandSeek) -> CommandSeek
+getFormat :: Annex (Maybe Utility.Format.Format)
-withFormat = withField formatOption $ return . fmap Utility.Format.gen
+getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen
 
 print0Option :: Option
 print0Option = Option.Option [] ["print0"] (Option.NoArg set)
@@ -36,8 +36,10 @@ print0Option = Option.Option [] ["print0"] (Option.NoArg set)
   where
 	set = Annex.setField (Option.name formatOption) "${file}\0"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFormat $ \f -> withFilesInGit $ whenAnnexed $ start f]
+seek ps = do
+	format <- getFormat
+	withFilesInGit (whenAnnexed $ start format) ps
 
 start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
 start format file (key, _) = do

Command/Fix.hs

@@ -24,8 +24,8 @@ def :: [Command]
 def = [notDirect $ noCommit $ command "fix" paramPaths seek
 	SectionMaintenance "fix up symlinks to point to annexed content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 {- Fixes the symlink to an annexed file. -}
 start :: FilePath -> (Key, Backend) -> CommandStart

Command/Forget.hs

@@ -26,9 +26,10 @@ forgetOptions = [dropDeadOption]
 dropDeadOption :: Option
 dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFlag dropDeadOption $ \dropdead ->
+seek ps = do
-	withNothing $ start dropdead]
+	dropdead <- getOptionFlag dropDeadOption
+	withNothing (start dropdead) ps
 
 start :: Bool -> CommandStart
 start dropdead = do

Command/FromKey.hs

@@ -20,8 +20,8 @@ def = [notDirect $ notBareRepo $
 	command "fromkey" (paramPair paramKey paramPath) seek
 		SectionPlumbing "adds a file using a specific key"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (keyname:file:[]) = do

Command/Fsck.hs

@@ -70,16 +70,17 @@ fsckOptions =
 	, incrementalScheduleOption
 	] ++ keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withIncremental $ \i ->
+	i <- getIncremental
-	  withKeyOptions (startKey i) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start from i
+		(startKey i)
-	]
+		(withFilesInGit $ whenAnnexed $ start from i)
+		ps
 
-withIncremental :: (Incremental -> CommandSeek) -> CommandSeek
+getIncremental :: Annex Incremental
-withIncremental = withValue $ do
+getIncremental = do
 	i <- maybe (return False) (checkschedule . parseDuration)
 		=<< Annex.getField (Option.name incrementalScheduleOption)
 	starti <- Annex.getFlag (Option.name startIncrementalOption)

Command/FuzzTest.hs

@@ -25,8 +25,8 @@ def :: [Command]
 def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing
 	"generates fuzz test files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/GCryptSetup.hs

@@ -18,8 +18,8 @@ def = [dontCheck repoExists $ noCommit $
 	command "gcryptsetup" paramValue seek
 		SectionPlumbing "sets up gcrypt repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withStrings start]
+seek = withStrings start
 
 start :: String -> CommandStart
 start gcryptid = next $ next $ do

Command/Get.hs

@@ -24,12 +24,13 @@ def = [withOptions getOptions $ command "get" paramPaths seek
 getOptions :: [Option]
 getOptions = fromOption : keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKeys from) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start from
+		(startKeys from)
-	]
+		(withFilesInGit $ whenAnnexed $ start from)
+		ps
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = start' expensivecheck from key (Just file)

Command/Group.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [command "group" (paramPair paramRemote paramDesc) seek
 	SectionSetup "add a repository to a group"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (name:g:[]) = do

Command/Help.hs

@@ -26,8 +26,8 @@ def :: [Command]
 def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
 	command "help" paramNothing seek SectionQuery "display help"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start params = do

Command/Import.hs

@@ -61,8 +61,10 @@ getDuplicateMode = gen
 	gen False False False True = SkipDuplicates
 	gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode]
+seek ps = do
+	mode <- getDuplicateMode
+	withPathContents (start mode) ps
 
 start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart
 start mode (srcfile, destfile) =

Command/ImportFeed.hs

@@ -41,11 +41,12 @@ def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
 templateOption :: Option
 templateOption = Option.field [] "template" paramFormat "template for filenames"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField templateOption return $ \tmpl ->
+seek ps = do
-	withFlag relaxedOption $ \relaxed ->
+	tmpl <- getOptionField templateOption return
-	withValue (getCache tmpl) $ \cache ->
+	relaxed <- getOptionFlag relaxedOption
-	withStrings $ start relaxed cache]
+	cache <- getCache tmpl
+	withStrings (start relaxed cache) ps
 
 start :: Bool -> Cache -> URLString -> CommandStart
 start relaxed cache url = do

Command/InAnnex.hs

@@ -15,8 +15,8 @@ def :: [Command]
 def = [noCommit $ command "inannex" (paramRepeating paramKey) seek
 	SectionPlumbing "checks if keys are present in the annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = inAnnexSafe key >>= dispatch

Command/Indirect.hs

@@ -31,8 +31,8 @@ def = [notBareRepo $ noDaemonRunning $
 	command "indirect" paramNothing seek
 		SectionSetup "switch repository to indirect mode"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = ifM isDirect

Command/Info.hs

@@ -75,8 +75,8 @@ def = [noCommit $ withOptions [jsonOption] $
 	command "info" paramPaths seek SectionQuery
 	"shows general information about the annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [FilePath] -> CommandStart
 start [] = do

Command/Init.hs

@@ -15,8 +15,8 @@ def :: [Command]
 def = [dontCheck repoExists $
 	command "init" paramDesc seek SectionSetup "initialize git-annex"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/InitRemote.hs

@@ -24,8 +24,8 @@ def = [command "initremote"
 	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
 	seek SectionSetup "creates a special (non-git) remote"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start [] = error "Specify a name for the remote."

Command/List.hs

@@ -31,11 +31,11 @@ def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
 allrepos :: Option
 allrepos = Option.flag [] "allrepos" "show all repositories, not only remotes"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withValue getList $ withWords . startHeader
+	list <- getList
-	, withValue getList $ withFilesInGit . whenAnnexed . start
+	printHeader list
-	]
+	withFilesInGit (whenAnnexed $ start list) ps
 
 getList :: Annex [(UUID, RemoteName, TrustLevel)]
 getList = ifM (Annex.getFlag $ Option.name allrepos)
@@ -58,10 +58,8 @@ getList = ifM (Annex.getFlag $ Option.name allrepos)
 		return $ sortBy (comparing snd3) $
 			filter (\t -> thd3 t /= DeadTrusted) rs3
 
-startHeader :: [(UUID, RemoteName, TrustLevel)] -> [String] -> CommandStart
+printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
-startHeader l _ = do
+printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
-	liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
-	stop
 
 start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart
 start l file (key, _) = do

Command/Lock.hs

@@ -16,8 +16,10 @@ def :: [Command]
 def = [notDirect $ command "lock" paramPaths seek SectionCommon
 	"undo unlock command"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]
+seek ps = do
+	withFilesUnlocked start ps
+	withFilesUnlockedToBeCommitted start ps
 
 start :: FilePath -> CommandStart
 start file = do

Command/Log.hs

@@ -53,12 +53,13 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++
 gourceOption :: Option
 gourceOption = Option.flag [] "gource" "format output for gource"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withValue Remote.uuidDescriptions $ \m ->
+seek ps = do
-	withValue (liftIO getCurrentTimeZone) $ \zone ->
+	m <- Remote.uuidDescriptions
-	withValue (concat <$> mapM getoption passthruOptions) $ \os ->
+	zone <- liftIO getCurrentTimeZone
-	withFlag gourceOption $ \gource ->
+	os <- concat <$> mapM getoption passthruOptions
-	withFilesInGit $ whenAnnexed $ start m zone os gource]
+	gource <- getOptionFlag gourceOption
+	withFilesInGit (whenAnnexed $ start m zone os gource) ps
   where
 	getoption o = maybe [] (use o) <$>
 		Annex.getField (Option.name o)

Command/LookupKey.hs

@@ -17,8 +17,8 @@ def = [notBareRepo $ noCommit $ noMessages $
 	command "lookupkey" (paramRepeating paramFile) seek
 		SectionPlumbing "looks up key used for file"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withStrings start]
+seek = withStrings start
 
 start :: String -> CommandStart
 start file = do

Command/Map.hs

@@ -31,8 +31,8 @@ def = [dontCheck repoExists $
 	command "map" paramNothing seek SectionQuery
 		"generate map of repositories"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Merge.hs

@@ -17,11 +17,10 @@ def :: [Command]
 def = [command "merge" paramNothing seek SectionMaintenance
 	"automatically merge changes from remotes"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withNothing mergeBranch
+	withNothing mergeBranch ps
-	, withNothing mergeSynced
+	withNothing mergeSynced ps
-	]
 
 mergeBranch :: CommandStart
 mergeBranch = do

Command/Migrate.hs

@@ -22,8 +22,8 @@ def = [notDirect $
 	command "migrate" paramPaths seek
 		SectionUtility "switch data to different backend"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 start :: FilePath -> (Key, Backend) -> CommandStart
 start file (key, oldbackend) = do

Command/Mirror.hs

@@ -22,13 +22,14 @@ def = [withOptions (fromToOptions ++ keyOptions) $
 	command "mirror" paramPaths seek
 		SectionCommon "mirror content of files to/from another repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKey Nothing to from Nothing) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from
+		(startKey Nothing to from Nothing)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from)
+		ps
 
 start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start to from file (key, _backend) = do

Command/Move.hs

@@ -26,13 +26,14 @@ def = [withOptions moveOptions $ command "move" paramPaths seek
 moveOptions :: [Option]
 moveOptions = fromToOptions ++ keyOptions
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withField toOption Remote.byNameWithUUID $ \to ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	  withField fromOption Remote.byNameWithUUID $ \from ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-	  withKeyOptions (startKey to from True) $
+	withKeyOptions
-	  withFilesInGit $ whenAnnexed $ start to from True
+		(startKey to from True)
-	]
+		(withFilesInGit $ whenAnnexed $ start to from True)
+		ps
 
 start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
 start to from move file (key, _) = start' to from move (Just file) key

Command/PreCommit.hs

@@ -9,6 +9,7 @@ module Command.PreCommit where
 
 import Common.Annex
 import Command
+import Config
 import qualified Command.Add
 import qualified Command.Fix
 import Annex.Direct
@@ -17,19 +18,20 @@ def :: [Command]
 def = [command "pre-commit" paramPaths seek SectionPlumbing
 	"run by git pre-commit hook"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek =
+seek ps = ifM isDirect
-	-- fix symlinks to files being committed
-	[ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed Command.Fix.start
-	-- inject unlocked files into the annex
-	, whenNotDirect $ withFilesUnlockedToBeCommitted startIndirect
 	-- update direct mode mappings for committed files
-	, whenDirect $ withWords startDirect
+	( withWords startDirect ps
-	]
+	, do
+		-- fix symlinks to files being committed
+		withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps
+		-- inject unlocked files into the annex
+		withFilesUnlockedToBeCommitted startIndirect ps
+	)
 
 startIndirect :: FilePath -> CommandStart
 startIndirect file = next $ do
-	unlessM (doCommand $ Command.Add.start file) $
+	unlessM (callCommand $ Command.Add.start file) $
 		error $ "failed to add " ++ file ++ "; canceling commit"
 	next $ return True
 

Command/ReKey.hs

@@ -22,8 +22,8 @@ def = [notDirect $ command "rekey"
 	(paramOptional $ paramRepeating $ paramPair paramPath paramKey)
 	seek SectionPlumbing "change keys used for files"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withPairs start]
+seek = withPairs start
 
 start :: (FilePath, String) -> CommandStart
 start (file, keyname) = ifAnnexed file go stop

Command/RecvKey.hs

@@ -26,8 +26,8 @@ def :: [Command]
 def = [noCommit $ command "recvkey" paramKey seek
 	SectionPlumbing "runs rsync in server mode to receive content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)

Command/Reinject.hs

@@ -17,8 +17,8 @@ def :: [Command]
 def = [command "reinject" (paramPair "SRC" "DEST") seek
 	SectionUtility "sets content of annexed file"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [FilePath] -> CommandStart
 start (src:dest:[])

Command/Repair.hs

@@ -20,8 +20,8 @@ def :: [Command]
 def = [noCommit $ dontCheck repoExists $
 	command "repair" paramNothing seek SectionMaintenance "recover broken git repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = next $ next $ runRepair =<< Annex.getState Annex.force

Command/RmUrl.hs

@@ -16,8 +16,8 @@ def = [notBareRepo $
 	command "rmurl" (paramPair paramFile paramUrl) seek
 		SectionCommon "record file is not available at url"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withPairs start]
+seek = withPairs start
 
 start :: (FilePath, String) -> CommandStart
 start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do

Command/Schedule.hs

@@ -21,8 +21,8 @@ def :: [Command]
 def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek
 	SectionSetup "get or set scheduled jobs"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start = parse

Command/Semitrust.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "semitrust" (paramRepeating paramRemote) seek
 	SectionSetup "return repository to default trust level"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/SendKey.hs

@@ -20,8 +20,8 @@ def :: [Command]
 def = [noCommit $ command "sendkey" paramKey seek
 	SectionPlumbing "runs rsync in server mode to send content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withKeys start]
+seek = withKeys start
 
 start :: Key -> CommandStart
 start key = do

Command/Status.hs

@@ -22,10 +22,8 @@ def = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $
 	command "status" paramPaths seek SectionCommon
 		"show the working tree status"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek = withWords start
-	[ withWords start
-	]
 
 start :: [FilePath] -> CommandStart
 start [] = do

Command/Sync.hs

@@ -47,7 +47,7 @@ import Control.Concurrent.MVar
 def :: [Command]
 def = [withOptions syncOptions $
 	command "sync" (paramOptional (paramRepeating paramRemote))
-	[seek] SectionCommon "synchronize local repository with remotes"]
+	seek SectionCommon "synchronize local repository with remotes"]
 
 syncOptions :: [Option]
 syncOptions = [ contentOption ]
@@ -55,7 +55,6 @@ syncOptions = [ contentOption ]
 contentOption :: Option
 contentOption = Option.flag [] "content" "also transfer file contents"
 
--- syncing involves several operations, any of which can independently fail
 seek :: CommandSeek
 seek rs = do
 	prepMerge
@@ -78,20 +77,16 @@ seek rs = do
 	remotes <- syncRemotes rs
 	let gitremotes = filter Remote.gitSyncableRemote remotes
 
-	synccontent <- ifM (Annex.getFlag $ Option.name contentOption)
+	-- Syncing involves many actions, any of which can independently
-		( withFilesInGit (whenAnnexed $ syncContent remotes) []
+	-- fail, without preventing the others from running.
-		, return []
+	seekActions $ return [ commit ]
-		)
+	seekActions $ return [ withbranch mergeLocal ]
-	
+	seekActions $ return $ map (withbranch . pullRemote) gitremotes
-	return $ concat
+	seekActions $ return [ mergeAnnex ]
-		[ [ commit ]
+	whenM (Annex.getFlag $ Option.name contentOption) $
-		, [ withbranch mergeLocal ]
+		withFilesInGit (whenAnnexed $ syncContent remotes) []
-		, map (withbranch . pullRemote) gitremotes
+	seekActions $ return $ [ withbranch pushLocal ]
-		, [ mergeAnnex ]
+	seekActions $ return $ map (withbranch . pushRemote) gitremotes
-		, synccontent
-		, [ withbranch pushLocal ]
-		, map (withbranch . pushRemote) gitremotes
-		]
 
 {- Merging may delete the current directory, so go to the top
  - of the repo. This also means that sync always acts on all files in the

Command/Test.hs

@@ -16,8 +16,8 @@ def = [ noRepo startIO $ dontCheck repoExists $
 	command "test" paramNothing seek SectionPlumbing
 		"run built-in test suite"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 {- We don't actually run the test suite here because of a dependency loop.
  - The main program notices when the command is test and runs it; this

Command/TransferInfo.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing
 	"updates sender on number of bytes of content received"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 {- Security:
  - 

Command/TransferKey.hs

@@ -28,11 +28,12 @@ transferKeyOptions = fileOption : fromToOptions
 fileOption :: Option
 fileOption = Option.field [] "file" paramFile "the associated file"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField toOption Remote.byNameWithUUID $ \to ->
+seek ps = do
-	withField fromOption Remote.byNameWithUUID $ \from ->
+	to <- getOptionField toOption Remote.byNameWithUUID
-	withField fileOption return $ \file ->
+	from <- getOptionField fromOption Remote.byNameWithUUID
-		withKeys $ start to from file]
+	file <- getOptionField fileOption return
+	withKeys (start to from file) ps
 
 start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart
 start to from file key =

Command/TransferKeys.hs

@@ -25,8 +25,8 @@ def :: [Command]
 def = [command "transferkeys" paramNothing seek
 	SectionPlumbing "transfers keys"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = withHandles $ \(readh, writeh) -> do

Command/Trust.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "trust" (paramRepeating paramRemote) seek
 	SectionSetup "trust a repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/Unannex.hs

@@ -23,8 +23,8 @@ def :: [Command]
 def = [command "unannex" paramPaths seek SectionUtility
 		"undo accidential add command"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 start :: FilePath -> (Key, Backend) -> CommandStart
 start file (key, _) = stopUnless (inAnnex key) $ do

Command/Ungroup.hs

@@ -19,8 +19,8 @@ def :: [Command]
 def = [command "ungroup" (paramPair paramRemote paramDesc) seek
 	SectionSetup "remove a repository from a group"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start (name:g:[]) = do

Command/Uninit.hs

@@ -34,12 +34,11 @@ check = do
 	revhead = inRepo $ Git.Command.pipeReadStrict
 		[Params "rev-parse --abbrev-ref HEAD"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = 
+seek ps = do
-	[ withFilesNotInGit $ whenAnnexed startCheckIncomplete
+	withFilesNotInGit (whenAnnexed startCheckIncomplete) ps
-	, withFilesInGit $ whenAnnexed Command.Unannex.start
+	withFilesInGit (whenAnnexed Command.Unannex.start) ps
-	, withNothing start
+	finish
-	]
 
 {- git annex symlinks that are not checked into git could be left by an
  - interrupted add. -}
@@ -50,8 +49,8 @@ startCheckIncomplete file _ = error $ unlines
 	, "Not continuing with uninit; either delete or git annex add the file and retry."
 	]
 
-start :: CommandStart
+finish :: Annex ()
-start = next $ next $ do
+finish = do
 	annexdir <- fromRepo gitAnnexDir
 	annexobjectdir <- fromRepo gitAnnexObjectDir
 	leftovers <- removeUnannexed =<< getKeysPresent

Command/Unlock.hs

@@ -20,8 +20,8 @@ def =
   where
 	c n = notDirect . command n paramPaths seek SectionCommon
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFilesInGit $ whenAnnexed start]
+seek = withFilesInGit $ whenAnnexed start
 
 {- The unlock subcommand replaces the symlink with a copy of the file's
  - content. -}

Command/Untrust.hs

@@ -16,8 +16,8 @@ def :: [Command]
 def = [command "untrust" (paramRepeating paramRemote) seek
 	SectionSetup "do not trust a repository"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start ws = do

Command/Unused.hs

@@ -45,8 +45,8 @@ def = [withOptions [fromOption] $ command "unused" paramNothing seek
 fromOption :: Option
 fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 {- Finds unused content in the annex. -} 
 start :: CommandStart
@@ -326,14 +326,14 @@ data UnusedMaps = UnusedMaps
 	, unusedTmpMap :: UnusedMap
 	}
 
-{- Read unused logs once, and pass the maps to each start action. -}
 withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek
 withUnusedMaps a params = do
 	unused <- readUnusedLog ""
 	unusedbad <- readUnusedLog "bad"
 	unusedtmp <- readUnusedLog "tmp"
 	let m = unused `M.union` unusedbad `M.union` unusedtmp
-	return $ map (a $ UnusedMaps unused unusedbad unusedtmp) $
+	let unusedmaps = UnusedMaps unused unusedbad unusedtmp
+	seekActions $ return $ map (a unusedmaps) $
 		concatMap (unusedSpec m) params
 
 unusedSpec :: UnusedMap -> String -> [Int]
@@ -349,8 +349,8 @@ unusedSpec m spec
 		_ -> badspec
 	badspec = error $ "Expected number or range, not \"" ++ spec ++ "\""
 
-{- Start action for unused content. Finds the number in the maps, and
+{- Seek action for unused content. Finds the number in the maps, and
- - calls either of 3 actions, depending on the type of unused file. -}
+ - calls one of 3 actions, depending on the type of unused file. -}
 startUnused :: String
 	-> (Key -> CommandPerform)
 	-> (Key -> CommandPerform) 

Command/Upgrade.hs

@@ -16,8 +16,8 @@ def = [dontCheck repoExists $ -- because an old version may not seem to exist
 	command "upgrade" paramNothing seek
 		SectionMaintenance "upgrade repository layout"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Version.hs

@@ -21,8 +21,8 @@ def :: [Command]
 def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
 	command "version" paramNothing seek SectionQuery "show version info"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Vicfg.hs

@@ -30,8 +30,8 @@ def :: [Command]
 def = [command "vicfg" paramNothing seek
 	SectionSetup "edit git-annex's configuration"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withNothing start]
+seek = withNothing start
 
 start :: CommandStart
 start = do

Command/Wanted.hs

@@ -20,8 +20,8 @@ def :: [Command]
 def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek
 	SectionSetup "get or set preferred content expression"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start = parse

Command/Watch.hs

@@ -17,10 +17,11 @@ def :: [Command]
 def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ 
 	command "watch" paramNothing seek SectionCommon "watch for changes"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withFlag stopOption $ \stopdaemon -> 
+seek ps = do
-	withFlag foregroundOption $ \foreground ->
+	stopdaemon <- getOptionFlag stopOption
-	withNothing $ start False foreground stopdaemon Nothing]
+	foreground <- getOptionFlag foregroundOption
+	withNothing (start False foreground stopdaemon Nothing) ps
 
 foregroundOption :: Option
 foregroundOption = Option.flag [] "foreground" "do not daemonize"

Command/WebApp.hs

@@ -48,9 +48,10 @@ listenOption :: Option
 listenOption = Option.field [] "listen" paramAddress
 	"accept connections to this address"
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withField listenOption return $ \listenhost ->
+seek ps = do
-	withNothing $ start listenhost]
+	listenhost <- getOptionField listenOption return
+	withNothing (start listenhost) ps
 
 start :: Maybe HostName -> CommandStart
 start = start' True
@@ -107,7 +108,7 @@ startNoRepo _ = do
 		(d:_) -> do
 			setCurrentDirectory d
 			state <- Annex.new =<< Git.CurrentRepo.get
-			void $ Annex.eval state $ doCommand $
+			void $ Annex.eval state $ callCommand $
 				start' False listenhost
 
 {- Run the webapp without a repository, which prompts the user, makes one,

Command/Whereis.hs

@@ -20,9 +20,10 @@ def = [noCommit $ withOptions [jsonOption] $
 	command "whereis" paramPaths seek SectionQuery
 		"lists repositories that have file content"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withValue (remoteMap id) $ \m ->
+seek ps = do
-	withFilesInGit $ whenAnnexed $ start m]
+	m <- remoteMap id
+	withFilesInGit (whenAnnexed $ start m) ps
 
 start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
 start remotemap file (key, _) = do

Command/XMPPGit.hs

@@ -16,8 +16,8 @@ def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
 	command "xmppgit" paramNothing seek
 		SectionPlumbing "git to XMPP relay"]
 
-seek :: [CommandSeek]
+seek :: CommandSeek
-seek = [withWords start]
+seek = withWords start
 
 start :: [String] -> CommandStart
 start _ = do

GitAnnexShell.hs

@@ -104,7 +104,7 @@ builtin cmd dir params = do
 		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
   where
 	addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k
-	newcmd opts c = c { cmdseek = map (addrsyncopts opts) (cmdseek c) }
+	newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) }
 
 external :: [String] -> IO ()
 external params = do

RunCommand.hs

@@ -0,0 +1,64 @@
+{- git-annex running commands
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module RunCommand where
+
+import Common.Annex
+import qualified Annex
+import Types.Command
+import qualified Annex.Queue
+import Annex.Exception
+
+{- Runs a command, starting with the check stage, and then
+ - the seek stage. Finishes by printing the number of commandActions that
+ - failed. -}
+performCommand :: Command -> CmdParams -> Annex ()
+performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = do
+	mapM_ runCheck c
+	Annex.changeState $ \s -> s { Annex.errcounter = 0 }
+	seek params
+	showerrcount =<< Annex.getState Annex.errcounter
+  where
+	showerrcount 0 = noop
+	showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"
+
+{- Runs one of the actions needed to perform a command.
+ - Individual actions can fail without stopping the whole command,
+ - including by throwing IO errors (but other errors terminate the whole
+ - command).
+ - 
+ - This should only be run in the seek stage. -}
+commandAction :: CommandStart -> Annex ()
+commandAction a = handle =<< tryAnnexIO go
+  where
+	go = do
+		Annex.Queue.flushWhenFull
+		callCommand a
+	handle (Right True) = noop
+	handle (Right False) = incerr
+	handle (Left err) = do
+		showErr err
+		showEndFail
+		incerr
+	incerr = Annex.changeState $ \s -> 
+		let ! c = Annex.errcounter s + 1 
+		    ! s' = s { Annex.errcounter = c }
+		in s'
+
+{- Runs a single command action through the start, perform and cleanup stages -}
+callCommand :: CommandStart -> CommandCleanup
+callCommand = start
+  where
+	start   = stage $ maybe skip perform
+	perform = stage $ maybe failure cleanup
+	cleanup = stage $ status
+	stage = (=<<)
+	skip = return True
+	failure = showEndFail >> return False
+	status r = showEndResult r >> return r

Seek.hs

@@ -4,7 +4,7 @@
  - the values a user passes to a command, and prepare actions operating
  - on them.
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -23,23 +23,14 @@ import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
 import qualified Limit
 import qualified Option
-import Config
 import Logs.Location
 import Logs.Unused
 import Annex.CatFile
-
+import RunCommand
-seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
-seekHelper a params = do
-	ll <- inRepo $ \g ->
-		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
-	{- Show warnings only for files/directories that do not exist. -}
-	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
-		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
-			fileNotFound p
-	return $ concat ll
 
 withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
-withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params
+withFilesInGit a params = seekActions $ prepFiltered a $
+	seekHelper LsFiles.inRepo params
 
 withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek
 withFilesNotInGit a params = do
@@ -47,7 +38,8 @@ withFilesNotInGit a params = do
 	files <- filter (not . dotfile) <$>
 		seekunless (null ps && not (null params)) ps
 	dotfiles <- seekunless (null dotps) dotps
-	prepFiltered a $ return $ concat $ segmentPaths params (files++dotfiles)
+	seekActions $ prepFiltered a $
+		return $ concat $ segmentPaths params (files++dotfiles)
   where
 	(dotps, ps) = partition dotfile params
 	seekunless True _ = return []
@@ -57,7 +49,8 @@ withFilesNotInGit a params = do
 		liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g
 
 withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
-withPathContents a params = map a . concat <$> liftIO (mapM get params)
+withPathContents a params = seekActions $ 
+	map a . concat <$> liftIO (mapM get params)
   where
 	get p = ifM (isDirectory <$> getFileStatus p)
 		( map (\f -> (f, makeRelative (parentDir p) f))
@@ -66,20 +59,20 @@ withPathContents a params = map a . concat <$> liftIO (mapM get params)
 		)
 
 withWords :: ([String] -> CommandStart) -> CommandSeek
-withWords a params = return [a params]
+withWords a params = seekActions $ return [a params]
 
 withStrings :: (String -> CommandStart) -> CommandSeek
-withStrings a params = return $ map a params
+withStrings a params = seekActions $ return $ map a params
 
 withPairs :: ((String, String) -> CommandStart) -> CommandSeek
-withPairs a params = return $ map a $ pairs [] params
+withPairs a params = seekActions $ return $ map a $ pairs [] params
   where
 	pairs c [] = reverse c
 	pairs c (x:y:xs) = pairs ((x,y):c) xs
 	pairs _ _ = error "expected pairs"
 
 withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
-withFilesToBeCommitted a params = prepFiltered a $
+withFilesToBeCommitted a params = seekActions $ prepFiltered a $
 	seekHelper LsFiles.stagedNotDeleted params
 
 withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek
@@ -94,7 +87,8 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
  - not some other sort of symlink.
  -}
 withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek
-withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles
+withFilesUnlocked' typechanged a params = seekActions $
+	prepFiltered a unlockedfiles
   where
   	check f = liftIO (notSymlink f) <&&> 
 		(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
@@ -102,32 +96,25 @@ withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles
 
 {- Finds files that may be modified. -}
 withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek
-withFilesMaybeModified a params =
+withFilesMaybeModified a params = seekActions $
 	prepFiltered a $ seekHelper LsFiles.modified params
 
 withKeys :: (Key -> CommandStart) -> CommandSeek
-withKeys a params = return $ map (a . parse) params
+withKeys a params = seekActions $ return $ map (a . parse) params
   where
 	parse p = fromMaybe (error "bad key") $ file2key p
 
-withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek
+{- Gets the value of a field options, which is fed into
-withValue v a params = do
+ - a conversion function.
-	r <- v
-	a r params
-
-{- Modifies a seek action using the value of a field option, which is fed into
- - a conversion function, and then is passed into the seek action.
- - This ensures that the conversion function only runs once.
  -}
-withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek
+getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a
-withField option converter = withValue $
+getOptionField option converter = converter <=< Annex.getField $ Option.name option
-	converter <=< Annex.getField $ Option.name option
 
-withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek
+getOptionFlag :: Option -> Annex Bool
-withFlag option = withValue $ Annex.getFlag (Option.name option)
+getOptionFlag option = Annex.getFlag (Option.name option)
 
 withNothing :: CommandStart -> CommandSeek
-withNothing a [] = return [a]
+withNothing a [] = seekActions $ return [a]
 withNothing _ _ = error "This command takes no parameters."
 
 {- If --all is specified, or in a bare repo, runs an action on all
@@ -159,7 +146,7 @@ withKeyOptions keyop fallbackop params = do
 		unless (null params) $
 			error "Cannot mix --all or --unused with file names."
 		matcher <- Limit.getMatcher
-		map (process matcher) <$> a
+		seekActions $ map (process matcher) <$> a
 	process matcher k = ifM (matcher $ MatchingKey k)
 		( keyop k , return Nothing)
 
@@ -171,11 +158,20 @@ prepFiltered a fs = do
 	process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f)
 		( a f , return Nothing )
 
+seekActions :: Annex [CommandStart] -> Annex ()
+seekActions gen = do
+	as <- gen
+	mapM_ commandAction as
+
+seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
+seekHelper a params = do
+	ll <- inRepo $ \g ->
+		runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
+	{- Show warnings only for files/directories that do not exist. -}
+	forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
+		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
+			fileNotFound p
+	return $ concat ll
+
 notSymlink :: FilePath -> IO Bool
 notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
-
-whenNotDirect :: CommandSeek -> CommandSeek
-whenNotDirect a params = ifM isDirect ( return [] , a params )
-
-whenDirect :: CommandSeek -> CommandSeek
-whenDirect a params = ifM isDirect ( a params, return [] )

Types/Command.hs

@@ -18,9 +18,9 @@ import Types
 data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
 {- b. The seek stage takes the parameters passed to the command,
  -    looks through the repo to find the ones that are relevant
- -    to that command (ie, new files to add), and generates
+ -    to that command (ie, new files to add), and runs commandAction
- -    a list of start stage actions. -}
+ -    to handle all necessary actions. -}
-type CommandSeek = [String] -> Annex [CommandStart]
+type CommandSeek = [String] -> Annex ()
 {- c. The start stage is run before anything is printed about the
  -    command, is passed some input, and can early abort it
  -    if the input does not make sense. It should run quickly and
@@ -42,7 +42,7 @@ data Command = Command
 	, cmdnomessages :: Bool      -- don't output normal messages
 	, cmdname :: String
 	, cmdparamdesc :: String     -- description of params for usage
-	, cmdseek :: [CommandSeek]   -- seek stage
+	, cmdseek :: CommandSeek
 	, cmdsection :: CommandSection
 	, cmddesc :: String          -- description of command for usage
 	}