Merge branch 'starting'

Annex.hs

@@ -142,7 +142,7 @@ data AnnexState = AnnexState
 	, tempurls :: M.Map Key URLString
 	, existinghooks :: M.Map Git.Hook.Hook Bool
 	, desktopnotify :: DesktopNotify
-	, workers :: WorkerPool AnnexState
+	, workers :: TMVar (WorkerPool AnnexState)
 	, activekeys :: TVar (M.Map Key ThreadId)
 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
 	, keysdbhandle :: Maybe Keys.DbHandle
@@ -155,6 +155,7 @@ newState :: GitConfig -> Git.Repo -> IO AnnexState
 newState c r = do
 	emptyactiveremotes <- newMVar M.empty
 	emptyactivekeys <- newTVarIO M.empty
+	emptyworkerpool <- newTMVarIO UnallocatedWorkerPool
 	o <- newMessageState
 	sc <- newTMVarIO False
 	return $ AnnexState
@@ -199,7 +200,7 @@ newState c r = do
 		, tempurls = M.empty
 		, existinghooks = M.empty
 		, desktopnotify = mempty
-		, workers = UnallocatedWorkerPool
+		, workers = emptyworkerpool
 		, activekeys = emptyactivekeys
 		, activeremotes = emptyactiveremotes
 		, keysdbhandle = Nothing

Annex/Concurrent.hs

@@ -11,7 +11,6 @@ import Annex
 import Annex.Common
 import Annex.Action
 import qualified Annex.Queue
-import Types.WorkerPool
 
 import qualified Data.Map as M
 
@@ -43,9 +42,8 @@ dupState :: Annex AnnexState
 dupState = do
 	st <- Annex.getState id
 	return $ st
-		{ Annex.workers = UnallocatedWorkerPool
 		-- each thread has its own repoqueue
-		, Annex.repoqueue = Nothing
+		{ Annex.repoqueue = Nothing
 		-- avoid sharing eg, open file handles
 		, Annex.catfilehandles = M.empty
 		, Annex.checkattrhandle = Nothing

Annex/Drop.hs

@@ -47,8 +47,8 @@ type Reason = String
  - In direct mode, all associated files are checked, and only if all
  - of them are unwanted are they dropped.
  -
- - The runner is used to run commands, and so can be either callCommand
- - or commandAction.
+ - The runner is used to run CommandStart sequentially, it's typically 
+ - callCommandAction.
  -}
 handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
 handleDropsFrom locs rs reason fromhere key afile preverified runner = do

Annex/Import.hs

@@ -326,11 +326,11 @@ downloadImport remote importtreeconfig importablecontents = do
 		(k:_) -> return $ Left $ Just (loc, k)
 		[] -> do
 			job <- liftIO $ newEmptyTMVarIO
-			let downloadaction = do
-				showStart ("import " ++ Remote.name remote) (fromImportLocation loc)
+			let ai = ActionItemOther (Just (fromImportLocation loc))
+			let downloadaction = starting ("import " ++ Remote.name remote) ai $ do
 				when oldversion $
 					showNote "old version"
-				next $ tryNonAsync (download cidmap db i) >>= \case
+				tryNonAsync (download cidmap db i) >>= \case
 					Left e -> next $ do
 						warning (show e)
 						liftIO $ atomically $

CHANGELOG

@@ -1,3 +1,12 @@
+git-annex (7.20190616) UNRELEASED; urgency=medium
+
+  * When running multiple concurrent actions, the cleanup phase is run
+    in a separate queue than the main action queue. This can make some
+    commands faster, because less time is spent on bookkeeping in
+    between each file transfer.
+
+ -- Joey Hess <id@joeyh.name>  Sat, 15 Jun 2019 12:38:25 -0400
+
 git-annex (7.20190615) upstream; urgency=medium
 
   * Fixed bug that caused git-annex to fail to add a file when another

CmdLine.hs

@@ -122,10 +122,8 @@ findCmd fuzzyok argv cmds
 
 prepRunCommand :: Command -> GlobalSetter -> Annex ()
 prepRunCommand cmd globalconfig = do
-	when (cmdnomessages cmd) $ do
+	when (cmdnomessages cmd) $
 		Annex.setOutput QuietOutput
-		Annex.changeState $ \s -> s 
-			{ Annex.output = (Annex.output s) { implicitMessages = False } }
 	getParsed globalconfig
 	whenM (annexDebug <$> Annex.getGitConfig) $
 		liftIO enableDebugOutput

CmdLine/Action.hs

@@ -1,11 +1,11 @@
-{- git-annex command-line actions
+{- git-annex command-line actions and concurrency
  -
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns #-}
 
 module CmdLine.Action where
 
@@ -22,9 +22,7 @@ import Remote.List
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Concurrent.STM
-import Control.Exception (throwIO)
 import GHC.Conc
-import Data.Either
 import qualified Data.Map.Strict as M
 import qualified System.Console.Regions as Regions
 
@@ -43,130 +41,219 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
 	showerrcount 0 = noop
 	showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed"
 
+commandActions :: [CommandStart] -> Annex ()
+commandActions = mapM_ commandAction
+
 {- Runs one of the actions needed to perform a command.
  - Individual actions can fail without stopping the whole command,
  - including by throwing non-async exceptions.
  - 
  - When concurrency is enabled, a thread is forked off to run the action
- - in the background, as soon as a free slot is available.
+ - in the background, as soon as a free worker slot is available.
  
  - This should only be run in the seek stage.
  -}
 commandAction :: CommandStart -> Annex ()
-commandAction a = Annex.getState Annex.concurrency >>= \case
-	NonConcurrent -> run
+commandAction start = Annex.getState Annex.concurrency >>= \case
+	NonConcurrent -> void $ includeCommandAction start
 	Concurrent n -> runconcurrent n
 	ConcurrentPerCpu -> runconcurrent =<< liftIO getNumProcessors
   where
-	run = void $ includeCommandAction a
-
 	runconcurrent n = do
-		ws <- liftIO . drainTo (n-1) =<< Annex.getState Annex.workers
-		(st, ws') <- case ws of
-			UnallocatedWorkerPool -> do
-				-- Generate the remote list now, to avoid
-				-- each thread generating it, which would
-				-- be more expensive and could cause
-				-- threads to contend over eg, calls to
-				-- setConfig.
-				_ <- remoteList
-				st <- dupState
-				return (st, allocateWorkerPool st (n-1))
-			WorkerPool l -> findFreeSlot l
-		w <- liftIO $ async $ snd <$> Annex.run st
-			(inOwnConsoleRegion (Annex.output st) run)
-		Annex.changeState $ \s -> s
-			{ Annex.workers = addWorkerPool ws' (Right w) }
+		tv <- Annex.getState Annex.workers
+		workerst <- waitWorkerSlot n (== PerformStage) tv
+		aid <- liftIO $ async $ snd <$> Annex.run workerst
+			(concurrentjob workerst)
+		liftIO $ atomically $ do
+			pool <- takeTMVar tv
+			let !pool' = addWorkerPool (ActiveWorker aid PerformStage) pool
+			putTMVar tv pool'
+		void $ liftIO $ forkIO $ do
+			-- accountCommandAction will usually catch
+			-- exceptions. Just in case, fall back to the
+			-- original workerst.
+			workerst' <- either (const workerst) id
+				<$> waitCatch aid
+			atomically $ do
+				pool <- takeTMVar tv
+				let !pool' = deactivateWorker pool aid workerst'
+				putTMVar tv pool'
+	
+	concurrentjob workerst = start >>= \case
+		Nothing -> noop
+		Just (startmsg, perform) ->
+			concurrentjob' workerst startmsg perform
+	
+	concurrentjob' workerst startmsg perform = case mkActionItem startmsg of
+		OnlyActionOn k _ -> ensureOnlyActionOn k $
+			-- If another job performed the same action while we
+			-- waited, there may be nothing left to do, so re-run
+			-- the start stage to see if it still wants to do
+			-- something.
+			start >>= \case
+				Just (startmsg', perform') ->
+					case mkActionItem startmsg' of
+						OnlyActionOn k' _ | k' /= k ->
+							concurrentjob' workerst startmsg' perform'
+						_ -> mkjob workerst startmsg' perform'
+				Nothing -> noop
+		_ -> mkjob workerst startmsg perform
+	
+	mkjob workerst startmsg perform = 
+		inOwnConsoleRegion (Annex.output workerst) $
+			void $ accountCommandAction startmsg $
+				performconcurrent startmsg perform
 
-commandActions :: [CommandStart] -> Annex ()
-commandActions = mapM_ commandAction
+	-- Like performCommandAction' but the worker thread's stage
+	-- is changed before starting the cleanup action.
+	performconcurrent startmsg perform = do
+		showStartMessage startmsg
+		perform >>= \case
+			Just cleanup -> do
+				changeStageTo CleanupStage
+				r <- cleanup
+				showEndMessage startmsg r
+				return r
+			Nothing -> do
+				showEndMessage startmsg False
+				return False
 
-{- Waits for any forked off command actions to finish.
- -
- - Merge together the cleanup actions of all the AnnexStates used by
- - threads, into the current Annex's state, so they'll run at shutdown.
- -
- - Also merge together the errcounters of the AnnexStates.
+-- | Wait until there's an idle worker in the pool, remove it from the
+-- pool, and return its state.
+--
+-- If the pool is unallocated, it will be allocated to the specified size.
+waitWorkerSlot :: Int -> (WorkerStage -> Bool) -> TMVar (WorkerPool Annex.AnnexState) -> Annex (Annex.AnnexState)
+waitWorkerSlot n wantstage tv =
+	join $ liftIO $ atomically $ waitWorkerSlot' wantstage tv >>= \case
+		Nothing -> return $ do
+			-- Generate the remote list now, to avoid
+			-- each thread generating it, which would
+			-- be more expensive and could cause
+			-- threads to contend over eg, calls to
+			-- setConfig.
+			_ <- remoteList
+			st <- dupState
+			liftIO $ atomically $ do
+				let (WorkerPool l) = allocateWorkerPool st (max n 1)
+				let (st', pool) = findidle st [] l
+				void $ swapTMVar tv pool
+				return st'
+		Just st -> return $ return st
+ where
+	findidle st _ [] = (st, WorkerPool [])
+	findidle _ c ((IdleWorker st stage):rest) 
+		| wantstage stage = (st, WorkerPool (c ++ rest))
+	findidle st c (w:rest) = findidle st (w:c) rest
+
+-- | STM action that waits until there's an idle worker in the worker pool.
+--
+-- If the worker pool is not already allocated, returns Nothing.
+waitWorkerSlot' :: (WorkerStage -> Bool) -> TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState))
+waitWorkerSlot' wantstage tv =
+	takeTMVar tv >>= \case
+		UnallocatedWorkerPool -> do
+			putTMVar tv UnallocatedWorkerPool 
+			return Nothing
+		WorkerPool l -> do
+			(st, pool') <- findidle [] l
+			putTMVar tv pool'
+			return $ Just st
+ where
+	findidle _ [] = retry
+	findidle c ((IdleWorker st stage):rest) 
+		| wantstage stage = return (st, WorkerPool (c ++ rest))
+	findidle c (w:rest) = findidle (w:c) rest
+
+{- Waits for all worker threads to finish and merges their AnnexStates
+ - back into the current Annex's state.
  -}
 finishCommandActions :: Annex ()
 finishCommandActions = do
-	ws <- Annex.getState Annex.workers
-	Annex.changeState $ \s -> s { Annex.workers = UnallocatedWorkerPool }
-	ws' <- liftIO $ drainTo 0 ws
-	forM_ (idleWorkers ws') mergeState
+	tv <- Annex.getState Annex.workers
+	pool <- liftIO $ atomically $
+		swapTMVar tv UnallocatedWorkerPool
+	case pool of
+		UnallocatedWorkerPool -> noop
+		WorkerPool l -> forM_ (mapMaybe workerAsync l) $ \aid ->
+			liftIO (waitCatch aid) >>= \case
+				Left _ -> noop
+				Right st -> mergeState st
 
-{- Wait for jobs from the WorkerPool to complete, until
- - the number of running jobs is not larger than the specified number.
+{- Changes the current thread's stage in the worker pool.
  -
- - If a job throws an exception, it is propigated, but first
- - all other jobs are waited for, to allow for a clean shutdown.
+ - The pool needs to continue to contain the same number of worker threads
+ - for each stage. So, an idle worker with the desired stage is found in 
+ - the pool (waiting if necessary for one to become idle), and the stages
+ - of it and the current thread are swapped.
  -}
-drainTo :: Int -> WorkerPool t -> IO (WorkerPool t)
-drainTo _ UnallocatedWorkerPool = pure UnallocatedWorkerPool
-drainTo sz (WorkerPool l)
-	| null as || sz >= length as = pure (WorkerPool l)
-	| otherwise = do
-		(done, ret) <- waitAnyCatch as
-		let as' = filter (/= done) as
-		case ret of
-			Left e -> do
-				void $ drainTo 0 $ WorkerPool $
-					map Left sts ++ map Right as'
-				throwIO e
-			Right st -> do
-				drainTo sz $ WorkerPool $
-					map Left (st:sts) ++ map Right as'
-  where
-	(sts, as) = partitionEithers l
-
-findFreeSlot :: [Worker Annex.AnnexState] -> Annex (Annex.AnnexState, WorkerPool Annex.AnnexState)
-findFreeSlot = go []
-  where
-	go c [] = do
-		st <- dupState
-		return (st, WorkerPool c)
-	go c (Left st:rest) = return (st, WorkerPool (c ++ rest))
-	go c (v:rest) = go (v:c) rest
+changeStageTo :: WorkerStage -> Annex ()
+changeStageTo newstage = do
+	mytid <- liftIO myThreadId
+	tv <- Annex.getState Annex.workers
+	liftIO $ atomically $ waitWorkerSlot' (== newstage) tv >>= \case
+		Just idlest -> do
+			pool <- takeTMVar tv
+			let pool' = case removeThreadIdWorkerPool mytid pool of
+				Just ((myaid, oldstage), p) ->
+					addWorkerPool (IdleWorker idlest oldstage) $
+						addWorkerPool (ActiveWorker myaid newstage) p
+				Nothing -> pool
+			putTMVar tv pool'
+		-- No worker pool is allocated, not running in concurrent
+		-- mode.
+		Nothing -> noop
 
 {- Like commandAction, but without the concurrency. -}
 includeCommandAction :: CommandStart -> CommandCleanup
-includeCommandAction a = account =<< tryNonAsync (callCommandAction a)
-  where
-	account (Right True) = return True
-	account (Right False) = incerr
-	account (Left err) = case fromException err of
+includeCommandAction start =
+	start >>= \case
+		Nothing -> return True
+		Just (startmsg, perform) -> do
+			showStartMessage startmsg
+			accountCommandAction startmsg $
+				performCommandAction' startmsg perform
+
+accountCommandAction :: StartMessage -> CommandCleanup -> CommandCleanup
+accountCommandAction startmsg cleanup = tryNonAsync cleanup >>= \case
+	Right True -> return True
+	Right False -> incerr
+	Left err -> case fromException err of
 		Just exitcode -> liftIO $ exitWith exitcode
 		Nothing -> do
 			toplevelWarning True (show err)
-			implicitMessage showEndFail
+			showEndMessage startmsg False
 			incerr
+  where
 	incerr = do
 		Annex.incError
 		return False
 
 {- Runs a single command action through the start, perform and cleanup
- - stages, without catching errors. Useful if one command wants to run
- - part of another command. -}
+ - stages, without catching errors and without incrementing error counter.
+ - Useful if one command wants to run part of another command. -}
 callCommandAction :: CommandStart -> CommandCleanup
 callCommandAction = fromMaybe True <$$> callCommandAction' 
 
 {- Like callCommandAction, but returns Nothing when the command did not
  - perform any action. -}
 callCommandAction' :: CommandStart -> Annex (Maybe Bool)
-callCommandAction' a = callCommandActionQuiet a >>= \case
-	Nothing -> return Nothing
-	Just r -> implicitMessage (showEndResult r) >> return (Just r)
+callCommandAction' start = 
+	start >>= \case
+		Nothing -> return Nothing
+		Just (startmsg, perform) -> do
+			showStartMessage startmsg
+			Just <$> performCommandAction' startmsg perform
 
-callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool)
-callCommandActionQuiet = start
-  where
-	start   = stage $ maybe skip perform
-	perform = stage $ maybe failure cleanup
-	cleanup = stage $ status
-	stage = (=<<)
-	skip = return Nothing
-	failure = return (Just False)
-	status = return . Just
+performCommandAction' :: StartMessage -> CommandPerform -> CommandCleanup
+performCommandAction' startmsg perform = 
+	perform >>= \case
+		Nothing -> do
+			showEndMessage startmsg False
+			return False
+		Just cleanup -> do
+			r <- cleanup
+			showEndMessage startmsg r
+			return r
 
 {- Do concurrent output when that has been requested. -}
 allowConcurrentOutput :: Annex a -> Annex a
@@ -214,18 +301,12 @@ allowConcurrentOutput a = do
 			liftIO $ setNumCapabilities n
 
 {- Ensures that only one thread processes a key at a time.
- - Other threads will block until it's done. -}
-onlyActionOn :: Key -> CommandStart -> CommandStart
-onlyActionOn k a = onlyActionOn' k run
-  where
-	-- Run whole action, not just start stage, so other threads
-	-- block until it's done.
-	run = callCommandActionQuiet a >>= \case
-		Nothing -> return Nothing
-		Just r' -> return $ Just $ return $ Just $ return r'
-
-onlyActionOn' :: Key -> Annex a -> Annex a
-onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
+ - Other threads will block until it's done.
+ -
+ - May be called repeatedly by the same thread without blocking. -}
+ensureOnlyActionOn :: Key -> Annex a -> Annex a
+ensureOnlyActionOn k a = 
+	go =<< Annex.getState Annex.concurrency
   where
 	go NonConcurrent = a
 	go (Concurrent _) = goconcurrent
@@ -240,7 +321,7 @@ onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
 			case M.lookup k m of
 				Just tid
 					| tid /= mytid -> retry
-					| otherwise -> return (return ())
+					| otherwise -> return $ return ()
 				Nothing -> do
 					writeTVar tv $! M.insert k mytid m
 					return $ liftIO $ atomically $

CmdLine/Seek.hs

@@ -24,7 +24,6 @@ import qualified Limit
 import CmdLine.GitAnnex.Options
 import Logs.Location
 import Logs.Unused
-import Types.ActionItem
 import Types.Transfer
 import Logs.Transfer
 import Remote.List

Command.hs

@@ -1,6 +1,6 @@
 {- git-annex command infrastructure
  -
- - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -22,14 +22,12 @@ import CmdLine.GlobalSetter as ReExported
 import CmdLine.GitAnnex.Options as ReExported
 import CmdLine.Batch as ReExported
 import Options.Applicative as ReExported hiding (command)
-import qualified Annex
 import qualified Git
 import Annex.Init
 import Config
 import Utility.Daemon
 import Types.Transfer
 import Types.ActionItem
-import Types.Messages
 
 {- Generates a normal Command -}
 command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
@@ -61,19 +59,11 @@ noCommit c = c { cmdnocommit = True }
  - starting or stopping processing a file or other item. Unless --json mode
  - is enabled, this also enables quiet output mode, so only things
  - explicitly output by the command are shown and not progress messages
- - etc. -}
+ - etc.
+ -}
 noMessages :: Command -> Command
 noMessages c = c { cmdnomessages = True }
 
-{- Undoes noMessages -}
-allowMessages :: Annex ()
-allowMessages = do
-	outputType <$> Annex.getState Annex.output >>= \case
-		QuietOutput -> Annex.setOutput NormalOutput
-		_ -> noop
-	Annex.changeState $ \s -> s
-		{ Annex.output = (Annex.output s) { implicitMessages = True } }
-
 {- Adds a fallback action to a command, that will be run if it's used
  - outside a git repository. -}
 noRepo :: (String -> Parser (IO ())) -> Command -> Command
@@ -83,11 +73,30 @@ noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) }
 withGlobalOptions :: [[GlobalOption]] -> Command -> Command
 withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }
 
-{- For start and perform stages to indicate what step to run next. -}
+{- For start stage to indicate what will be done. -}
+starting:: MkActionItem t => String -> t -> CommandPerform -> CommandStart
+starting msg t a = next (StartMessage msg (mkActionItem t), a)
+
+{- Use when noMessages was used but the command is going to output
+ - usual messages after all. -}
+startingUsualMessages :: MkActionItem t => String -> t -> CommandPerform -> CommandStart
+startingUsualMessages msg t a = next (StartUsualMessages msg (mkActionItem t), a)
+
+{- When no message should be displayed at start/end, but messages can still 
+ - be displayed when using eg includeCommandAction. -}
+startingNoMessage :: MkActionItem t => t -> CommandPerform -> CommandStart
+startingNoMessage t a = next (StartNoMessage (mkActionItem t), a)
+
+{- For commands that do not display usual start or end messages, 
+ - but have some other custom output. -}
+startingCustomOutput :: MkActionItem t => t -> CommandPerform -> CommandStart
+startingCustomOutput t a = next (CustomOutput (mkActionItem t), a)
+
+{- For perform stage to indicate what step to run next. -}
 next :: a -> Annex (Maybe a)
 next a = return $ Just a
 
-{- Or to indicate nothing needs to be done. -}
+{- For start and perform stage to indicate nothing needs to be done. -}
 stop :: Annex (Maybe a)
 stop = return Nothing
 

Command/Add.hs

@@ -78,9 +78,8 @@ seek o = allowConcurrentOutput $ do
 
 {- Pass file off to git-add. -}
 startSmall :: FilePath -> CommandStart
-startSmall file = do
-	showStart "add" file
-	next $ next $ addSmall file
+startSmall file = starting "add" (ActionItemWorkTreeFile file) $
+	next $ addSmall file
 
 addSmall :: FilePath -> Annex Bool
 addSmall file = do
@@ -107,11 +106,11 @@ start file = do
 		Nothing -> stop
 		Just s 
 			| not (isRegularFile s) && not (isSymbolicLink s) -> stop
-			| otherwise -> do
-				showStart "add" file
-				next $ if isSymbolicLink s
-					then next $ addFile file
-					else perform file
+			| otherwise -> 
+				starting "add" (ActionItemWorkTreeFile file) $
+					if isSymbolicLink s
+						then next $ addFile file
+						else perform file
 	addpresent key = ifM versionSupportsUnlockedPointers
 		( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case
 			Just s | isSymbolicLink s -> fixuplink key
@@ -124,18 +123,16 @@ start file = do
 			, fixuplink key
 			)
 		)
-	fixuplink key = do
+	fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do
 		-- the annexed symlink is present but not yet added to git
-		showStart "add" file
 		liftIO $ removeFile file
 		addLink file key Nothing
-		next $ next $
+		next $
 			cleanup key =<< inAnnex key
-	fixuppointer key = do
+	fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
 		-- the pointer file is present, but not yet added to git
-		showStart "add" file
 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
-		next $ next $ addFile file
+		next $ addFile file
 
 perform :: FilePath -> CommandPerform
 perform file = withOtherTmp $ \tmpdir -> do

Command/AddUrl.hs

@@ -124,10 +124,9 @@ checkUrl r o u = do
 		(Remote.checkUrl r)
   where
 
-	go _ (Left e) = void $ commandAction $ do
-		showStartAddUrl u o
+	go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do
 		warning (show e)
-		next $ next $ return False
+		next $ return False
 	go deffile (Right (UrlContents sz mf)) = do
 		let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o)))
 		void $ commandAction $ startRemote r o f u sz
@@ -151,10 +150,10 @@ startRemote :: Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer
 startRemote r o file uri sz = do
 	pathmax <- liftIO $ fileNameLengthLimit "."
 	let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file
-	showStartAddUrl uri o
-	showNote $ "from " ++ Remote.name r 
-	showDestinationFile file'
-	next $ performRemote r o uri file' sz
+	startingAddUrl uri o $ do
+		showNote $ "from " ++ Remote.name r 
+		showDestinationFile file'
+		performRemote r o uri file' sz
 
 performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform
 performRemote r o uri file sz = ifAnnexed file adduri geturi
@@ -194,8 +193,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
   where
 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
 		Url.parseURIRelaxed $ urlstring
-	go url = do
-		showStartAddUrl urlstring o
+	go url = startingAddUrl urlstring o $ do
 		pathmax <- liftIO $ fileNameLengthLimit "."
 		urlinfo <- if relaxedOption (downloadOptions o)
 			then pure Url.assumeUrlExists
@@ -212,7 +210,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
 						( pure $ url2file url (pathdepthOption o) pathmax
 						, pure f
 						)
-		next $ performWeb o urlstring file urlinfo
+		performWeb o urlstring file urlinfo
 
 performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform
 performWeb o url file urlinfo = ifAnnexed file addurl geturl
@@ -323,12 +321,12 @@ downloadWeb o url urlinfo file =
 {- The destination file is not known at start time unless the user provided
  - a filename. It's not displayed then for output consistency, 
  - but is added to the json when available. -}
-showStartAddUrl :: URLString -> AddUrlOptions -> Annex ()
-showStartAddUrl url o = do
-	showStart' "addurl" (Just url)
+startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart
+startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do
 	case fileOption (downloadOptions o) of
 		Nothing -> noop
 		Just file -> maybeShowJSON $ JSONChunk [("file", file)]
+	p
 
 showDestinationFile :: FilePath -> Annex ()
 showDestinationFile file = do

Command/Adjust.hs

@@ -47,5 +47,5 @@ seek = commandAction . start
 start :: Adjustment -> CommandStart
 start adj = do
 	checkVersionSupported
-	showStart' "adjust" Nothing
-	next $ next $ enterAdjustedBranch adj
+	starting "adjust" (ActionItemOther Nothing) $
+		next $ enterAdjustedBranch adj

Command/Commit.hs

@@ -20,10 +20,10 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = next $ next $ do
-	Annex.Branch.commit =<< Annex.Branch.commitMessage
-	_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
-	return True
+start = starting "commit" (ActionItemOther (Just "git-annex")) $ do
+		Annex.Branch.commit =<< Annex.Branch.commitMessage
+		_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
+		next $ return True
   where
 	runhook (Just hook) = liftIO $ boolSystem hook []
 	runhook Nothing = return True

Command/Config.hs

@@ -48,23 +48,19 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
 		)
 
 seek :: Action -> CommandSeek
-seek (SetConfig name val) = commandAction $ do
-	allowMessages
-	showStart' name (Just val)
-	next $ next $ do
+seek (SetConfig name val) = commandAction $
+	startingUsualMessages name (ActionItemOther (Just val)) $ do
 		setGlobalConfig name val
 		setConfig (ConfigKey name) val
-		return True
-seek (UnsetConfig name) = commandAction $ do
-	allowMessages
-	showStart' name (Just "unset")
-	next $ next $ do
+		next $ return True
+seek (UnsetConfig name) = commandAction $
+	startingUsualMessages name (ActionItemOther (Just "unset")) $do
 		unsetGlobalConfig name
 		unsetConfig (ConfigKey name)
-		return True
+		next $ return True
 seek (GetConfig name) = commandAction $
-	getGlobalConfig name >>= \case
-		Nothing -> stop
-		Just v -> do
-			liftIO $ putStrLn v
-			stop
+	startingCustomOutput (ActionItemOther Nothing) $ do
+		getGlobalConfig name >>= \case
+			Nothing -> return ()
+			Just v -> liftIO $ putStrLn v
+		next $ return True

Command/Dead.hs

@@ -32,10 +32,9 @@ seek (DeadRemotes rs) = trustCommand "dead" DeadTrusted rs
 seek (DeadKeys ks) = commandActions $ map startKey ks
 
 startKey :: Key -> CommandStart
-startKey key = do
-	showStart' "dead" (Just $ serializeKey key)
+startKey key = starting "dead" (mkActionItem key) $
 	keyLocations key >>= \case
-		[] -> next $ performKey key
+		[] -> performKey key
 		_ -> giveup "This key is still known to be present in some locations; not marking as dead."
 		
 performKey :: Key -> CommandPerform

Command/Describe.hs

@@ -22,9 +22,9 @@ seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
 start (name:description) | not (null description) = do
-	showStart' "describe" (Just name)
 	u <- Remote.nameToUUID name
-	next $ perform u $ unwords description
+	starting "describe" (ActionItemOther (Just name)) $
+		perform u $ unwords description
 start _ = giveup "Specify a repository and a description."	
 
 perform :: UUID -> String -> CommandPerform

Command/Direct.hs

@@ -25,44 +25,38 @@ seek = withNothing (commandAction start)
 
 start :: CommandStart
 start = ifM versionSupportsDirectMode
-	( ifM isDirect ( stop , next perform )
+	( ifM isDirect
+		( stop 
+		, starting "direct" (ActionItemOther Nothing)
+			perform
+		)
 	, giveup "Direct mode is not supported by this repository version. Use git-annex unlock instead."
 	)
 
 perform :: CommandPerform
 perform = do
-	showStart' "commit" Nothing
 	showOutput
 	_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
 		[ Param "-a"
 		, Param "-m"
 		, Param "commit before switching to direct mode"
 		]
-	showEndOk
 
 	top <- fromRepo Git.repoPath
 	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
 	forM_ l go
 	void $ liftIO clean
-	next cleanup
+	next $ return True
   where
 	go = whenAnnexed $ \f k -> do
 		toDirectGen k f >>= \case
 			Nothing -> noop
-			Just a -> do
-				showStart "direct" f
-				tryNonAsync a >>= \case
-					Left e -> warnlocked e
-					Right _ -> showEndOk
+			Just a -> tryNonAsync a >>= \case
+				Left e -> warnlocked f e
+				Right _ -> return ()
 		return Nothing
 
-	warnlocked :: SomeException -> Annex ()
-	warnlocked e = do
-		warning $ show e
+	warnlocked :: FilePath -> SomeException -> Annex ()
+	warnlocked f e = do
+		warning $ f ++ ": " ++ show e
 		warning "leaving this file as-is; correct this problem and run git annex fsck on it"
-
-cleanup :: CommandCleanup
-cleanup = do
-	showStart' "direct" Nothing
-	setDirect True
-	return True

Command/Drop.hs

@@ -69,7 +69,7 @@ start o file key = start' o key afile ai
 	ai = mkActionItem (key, afile)
 
 start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart
-start' o key afile ai = onlyActionOn key $ do
+start' o key afile ai = do
 	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)
 	checkDropAuto (autoMode o) from afile key $ \numcopies ->
 		stopUnless (want from) $
@@ -89,14 +89,15 @@ startKeys :: DropOptions -> (Key, ActionItem) -> CommandStart
 startKeys o (key, ai) = start' o key (AssociatedFile Nothing) ai
 
 startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
-startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do
-	showStartKey "drop" key ai
-	next $ performLocal key afile numcopies preverified
+startLocal afile ai numcopies key preverified =
+	stopUnless (inAnnex key) $
+		starting "drop" (OnlyActionOn key ai) $
+			performLocal key afile numcopies preverified
 
 startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart
-startRemote afile ai numcopies key remote = do
-	showStartKey ("drop " ++ Remote.name remote) key ai
-	next $ performRemote key afile numcopies remote
+startRemote afile ai numcopies key remote = 
+	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) $
+		performRemote key afile numcopies remote
 
 performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
 performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do

Command/DropKey.hs

@@ -41,9 +41,8 @@ seek o = do
 	parsekey = maybe (Left "bad key") Right . deserializeKey
 
 start :: Key -> CommandStart
-start key = do
-	showStartKey "dropkey" key (mkActionItem key)
-	next $ perform key
+start key = starting "dropkey" (mkActionItem key) $
+	perform key
 
 perform :: Key -> CommandPerform
 perform key = ifM (inAnnex key)

Command/EnableRemote.hs

@@ -54,13 +54,11 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
 -- the remote uuid.
 startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart
 startNormalRemote name restparams r
-	| null restparams = do
-		showStart' "enableremote" (Just name)
-		next $ next $ do
-			setRemoteIgnore r False
-			r' <- Remote.Git.configRead False r
-			u <- getRepoUUID r'
-			return $ u /= NoUUID
+	| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do
+		setRemoteIgnore r False
+		r' <- Remote.Git.configRead False r
+		u <- getRepoUUID r'
+		next $ return $ u /= NoUUID
 	| otherwise = giveup $
 		"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams
 
@@ -73,14 +71,14 @@ startSpecialRemote name config Nothing = do
 			startSpecialRemote name config $
 				Just (u, fromMaybe M.empty (M.lookup u confm))
 		_ -> unknownNameError "Unknown remote name."
-startSpecialRemote name config (Just (u, c)) = do
-	let fullconfig = config `M.union` c	
-	t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
-	showStart' "enableremote" (Just name)
-	gc <- maybe (liftIO dummyRemoteGitConfig) 
-		(return . Remote.gitconfig)
-		=<< Remote.byUUID u
-	next $ performSpecialRemote t u c fullconfig gc
+startSpecialRemote name config (Just (u, c)) =
+	starting "enableremote" (ActionItemOther (Just name)) $ do
+		let fullconfig = config `M.union` c	
+		t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
+		gc <- maybe (liftIO dummyRemoteGitConfig) 
+			(return . Remote.gitconfig)
+			=<< Remote.byUUID u
+		performSpecialRemote t u c fullconfig gc
 
 performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform
 performSpecialRemote t u oldc c gc = do

Command/EnableTor.hs

@@ -51,15 +51,14 @@ start os = do
 		then case readish =<< headMaybe os of
 			Nothing -> giveup "Need user-id parameter."
 			Just userid -> go uuid userid
-		else do
-			showStart' "enable-tor" Nothing
+		else starting "enable-tor" (ActionItemOther Nothing) $ do
 			gitannex <- liftIO readProgramFile
 			let ps = [Param (cmdname cmd), Param (show curruserid)]
 			sucommand <- liftIO $ mkSuCommand gitannex ps
 			maybe noop showLongNote
 				(describePasswordPrompt' sucommand)
 			ifM (liftIO $ runSuCommand sucommand)
-				( next $ next checkHiddenService
+				( next checkHiddenService
 				, giveup $ unwords $
 					[ "Failed to run as root:" , gitannex ] ++ toCommand ps
 				)

Command/Expire.hs

@@ -58,16 +58,18 @@ seek o = do
 start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart
 start (Expire expire) noact actlog descs u =
 	case lastact of
-		Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do
-			showStart' "unexpire" (Just desc)
-			showNote =<< whenactive
-			unless noact $
-				trustSet u SemiTrusted
-		_ -> checktrust (/= DeadTrusted) $ do
-			showStart' "expire" (Just desc)
-			showNote =<< whenactive
-			unless noact $
-				trustSet u DeadTrusted
+		Just ent | notexpired ent -> checktrust (== DeadTrusted) $
+			starting "unexpire" (ActionItemOther (Just desc)) $ do
+				showNote =<< whenactive
+				unless noact $
+					trustSet u SemiTrusted
+				next $ return True
+		_ -> checktrust (/= DeadTrusted) $
+			starting "expire" (ActionItemOther (Just desc)) $ do
+				showNote =<< whenactive
+				unless noact $
+					trustSet u DeadTrusted
+				next $ return True
   where
 	lastact = changed <$> M.lookup u actlog
 	whenactive = case lastact of
@@ -83,12 +85,7 @@ start (Expire expire) noact actlog descs u =
 			_ -> True
 	lookupexpire = headMaybe $ catMaybes $
 		map (`M.lookup` expire) [Just u, Nothing]
-	checktrust want a = ifM (want <$> lookupTrust u)
-		( do
-			void a
-			next $ next $ return True
-		, stop
-		)
+	checktrust want = stopUnless (want <$> lookupTrust u)
 
 data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime))
 

Command/Export.hs

@@ -249,14 +249,14 @@ fillExport r db (PreferredFiltered newtree) mtbcommitsha = do
 startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart
 startExport r db cvar allfilledvar ti = do
 	ek <- exportKey (Git.LsTree.sha ti)
-	stopUnless (notrecordedpresent ek) $ do
-		showStart ("export " ++ name r) f
-		ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
-			( next $ next $ cleanupExport r db ek loc False
-			, do
-				liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
-				next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
-			)
+	stopUnless (notrecordedpresent ek) $
+		starting ("export " ++ name r) (ActionItemOther (Just f)) $
+			ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
+				( next $ cleanupExport r db ek loc False
+				, do
+					liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
+					performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
+				)
   where
 	loc = mkExportLocation f
 	f = getTopFilePath (Git.LsTree.file ti)
@@ -313,17 +313,15 @@ startUnexport r db f shas = do
 	eks <- forM (filter (/= nullSha) shas) exportKey
 	if null eks
 		then stop
-		else do
-			showStart ("unexport " ++ name r) f'
-			next $ performUnexport r db eks loc
+		else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
+			performUnexport r db eks loc
   where
 	loc = mkExportLocation f'
 	f' = getTopFilePath f
 
 startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startUnexport' r db f ek = do
-	showStart ("unexport " ++ name r) f'
-	next $ performUnexport r db [ek] loc
+startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
+	performUnexport r db [ek] loc
   where
 	loc = mkExportLocation f'
 	f' = getTopFilePath f
@@ -365,17 +363,17 @@ startRecoverIncomplete r db sha oldf
 	| otherwise = do
 		ek <- exportKey sha
 		let loc = exportTempName ek
-		showStart ("unexport " ++ name r) (fromExportLocation loc)
-		liftIO $ removeExportedLocation db (asKey ek) oldloc
-		next $ performUnexport r db [ek] loc
+		starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do
+			liftIO $ removeExportedLocation db (asKey ek) oldloc
+			performUnexport r db [ek] loc
   where
 	oldloc = mkExportLocation oldf'
 	oldf' = getTopFilePath oldf
 
 startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startMoveToTempName r db f ek = do
-	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
-	next $ performRename r db ek loc tmploc
+startMoveToTempName r db f ek = starting ("rename " ++ name r) 
+	(ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc)
+	(performRename r db ek loc tmploc)
   where
 	loc = mkExportLocation f'
 	f' = getTopFilePath f
@@ -384,9 +382,9 @@ startMoveToTempName r db f ek = do
 startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
 startMoveFromTempName r db ek f = do
 	let tmploc = exportTempName ek
-	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
-		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
-		next $ performRename r db ek tmploc loc
+	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
+		starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $
+			performRename r db ek tmploc loc
   where
 	loc = mkExportLocation f'
 	f' = getTopFilePath f

Command/Find.hs

@@ -14,7 +14,6 @@ import Command
 import Annex.Content
 import Limit
 import Types.Key
-import Types.ActionItem
 import Git.FilePath
 import qualified Utility.Format
 import Utility.DataUnits
@@ -65,12 +64,11 @@ seek o = case batchOption o of
 -- only files inAnnex are shown, unless the user has requested
 -- others via a limit
 start :: FindOptions -> FilePath -> Key -> CommandStart
-start o file key = ifM (limited <||> inAnnex key)
-	( do
-		showFormatted (formatOption o) file $ ("file", file) : keyVars key
-		next $ next $ return True
-	, stop
-	)
+start o file key =
+	stopUnless (limited <||> inAnnex key) $
+		startingCustomOutput key $ do
+			showFormatted (formatOption o) file $ ("file", file) : keyVars key
+			next $ return True
 
 startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
 startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = 

Command/Fix.hs

@@ -54,9 +54,7 @@ start fixwhat file key = do
 			FixAll -> fixthin
 			FixSymlinks -> stop
   where
-	fixby a = do
-		showStart "fix" file
-		next a
+	fixby = starting "fix" (mkActionItem (key, file))
 	fixthin = do
 		obj <- calcRepo $ gitAnnexLocation key
 		stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do

Command/Forget.hs

@@ -33,14 +33,13 @@ seek :: ForgetOptions -> CommandSeek
 seek = commandAction . start
 
 start :: ForgetOptions -> CommandStart
-start o = do
-	showStart' "forget" (Just "git-annex")
+start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do
 	c <- liftIO currentVectorClock
 	let basets = addTransition c ForgetGitHistory noTransitions
 	let ts = if dropDead o
 		then addTransition c ForgetDeadRemotes basets
 		else basets
-	next $ perform ts =<< Annex.getState Annex.force
+	perform ts =<< Annex.getState Annex.force
 
 perform :: Transitions -> Bool -> CommandPerform
 perform ts True = do

Command/FromKey.hs

@@ -51,9 +51,8 @@ seekBatch fmt = batchInput fmt parse commandAction
 		in if not (null keyname) && not (null file)
 			then Right $ go file (mkKey keyname)
 			else Left "Expected pairs of key and filename"
-	go file key = do
-		showStart "fromkey" file
-		next $ perform key file
+	go file key = starting "fromkey" (mkActionItem (key, file)) $
+		perform key file
 
 start :: Bool -> (String, FilePath) -> CommandStart
 start force (keyname, file) = do
@@ -62,8 +61,8 @@ start force (keyname, file) = do
 		inbackend <- inAnnex key
 		unless inbackend $ giveup $
 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
-	showStart "fromkey" file
-	next $ perform key file
+	starting "fromkey" (mkActionItem (key, file)) $
+		perform key file
 
 -- From user input to a Key.
 -- User can input either a serialized key, or an url.

Command/Fsck.hs

@@ -586,16 +586,12 @@ badContentRemote remote localcopy key = do
 		(_, False) -> "failed to drop from" ++ Remote.name remote
 
 runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart
-runFsck inc ai key a = ifM (needFsck inc key)
-	( do
-		showStartKey "fsck" key ai
-		next $ do
-			ok <- a
-			when ok $
-				recordFsckTime inc key
-			next $ return ok
-	, stop
-	)
+runFsck inc ai key a = stopUnless (needFsck inc key) $
+	starting "fsck" ai $ do
+		ok <- a
+		when ok $
+			recordFsckTime inc key
+		next $ return ok
 
 {- Check if a key needs to be fscked, with support for incremental fscks. -}
 needFsck :: Incremental -> Key -> Annex Bool

Command/GCryptSetup.hs

@@ -22,7 +22,7 @@ seek :: CmdParams -> CommandSeek
 seek = withStrings (commandAction . start)
 
 start :: String -> CommandStart
-start gcryptid = next $ next $ do
+start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do
 	u <- getUUID
 	when (u /= NoUUID) $
 		giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
@@ -34,6 +34,6 @@ start gcryptid = next $ next $ do
 		then if Git.repoIsLocalBare g
 			then do
 				void $ Remote.GCrypt.setupRepo gcryptid g
-				return True
+				next $ return True
 			else giveup "cannot use gcrypt in a non-bare repository"
 		else giveup "gcryptsetup uuid mismatch"

Command/Get.hs

@@ -63,7 +63,7 @@ startKeys from (key, ai) = checkFailedTransferDirection ai Download $
 	start' (return True) from key (AssociatedFile Nothing) ai
 
 start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
-start' expensivecheck from key afile ai = onlyActionOn key $
+start' expensivecheck from key afile ai =
 	stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $
 		case from of
 			Nothing -> go $ perform key afile
@@ -71,9 +71,7 @@ start' expensivecheck from key afile ai = onlyActionOn key $
 				stopUnless (Command.Move.fromOk src key) $
 					go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile
   where
-	go a = do
-		showStartKey "get" key ai
-		next a
+	go = starting "get" (OnlyActionOn key ai)
 
 perform :: Key -> AssociatedFile -> CommandPerform
 perform key afile = stopUnless (getKey key afile) $

Command/Group.hs

@@ -23,14 +23,15 @@ seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
 start (name:g:[]) = do
-	allowMessages
-	showStart' "group" (Just name)
 	u <- Remote.nameToUUID name
-	next $ setGroup u (toGroup g)
+	startingUsualMessages "group" (ActionItemOther (Just name)) $
+		setGroup u (toGroup g)
 start (name:[]) = do
 	u <- Remote.nameToUUID name
-	liftIO . putStrLn . unwords . map fmt . S.toList =<< lookupGroups u
-	stop
+	startingCustomOutput (ActionItemOther Nothing) $ do
+		liftIO . putStrLn . unwords . map fmt . S.toList
+			=<< lookupGroups u
+		next $ return True
   where
 	fmt (Group g) = decodeBS g
 start _ = giveup "Specify a repository and a group."

Command/GroupWanted.hs

@@ -22,9 +22,8 @@ seek :: CmdParams -> CommandSeek
 seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
-start (g:[]) = next $ performGet groupPreferredContentMapRaw (toGroup g)
-start (g:expr:[]) = do
-	allowMessages
-	showStart' "groupwanted" (Just g)
-	next $ performSet groupPreferredContentSet expr (toGroup g)
+start (g:[]) = startingCustomOutput (ActionItemOther Nothing) $
+	performGet groupPreferredContentMapRaw (toGroup g)
+start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $
+	performSet groupPreferredContentSet expr (toGroup g)
 start _ = giveup "Specify a group."

Command/Import.hs

@@ -117,9 +117,8 @@ seek o@(RemoteImportOptions {}) = allowConcurrentOutput $ do
 startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
 startLocal largematcher mode (srcfile, destfile) =
 	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
-		( do
-			showStart "import" destfile
-			next pickaction
+		( starting "import" (ActionItemWorkTreeFile destfile)
+			pickaction
 		, stop
 		)
   where
@@ -280,7 +279,8 @@ seekRemote remote branch msubdir = do
 				, ". Re-run command to resume import."
 				]
 			Just imported -> void $
-				includeCommandAction $ commitimport imported
+				includeCommandAction $ 
+					commitimport imported
   where
 	importmessage = "import from " ++ Remote.name remote
 
@@ -289,9 +289,8 @@ seekRemote remote branch msubdir = do
 	fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb)
 
 listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart
-listContents remote tvar = do
-	showStart' "list" (Just (Remote.name remote))
-	next $ listImportableContents remote >>= \case
+listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $
+	listImportableContents remote >>= \case
 		Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
 		Just importable -> do
 			importable' <- makeImportMatcher remote >>= \case
@@ -302,9 +301,8 @@ listContents remote tvar = do
 				return True
 
 commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart
-commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = do
-	showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb)
-	next $ do
+commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =
+	starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do
 		importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable
 		next $ updateremotetrackingbranch importcommit
 		

Command/ImportFeed.hs

@@ -66,32 +66,27 @@ optParser desc = ImportFeedOptions
 seek :: ImportFeedOptions -> CommandSeek
 seek o = do
 	cache <- getCache (templateOption o)
-	withStrings (commandAction . start o cache) (feedUrls o)
+	forM_ (feedUrls o) (getFeed o cache)
 
-start :: ImportFeedOptions -> Cache -> URLString -> CommandStart
-start opts cache url = do
-	showStart' "importfeed" (Just url)
-	next $ perform opts cache url
-
-perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform
-perform opts cache url = go =<< downloadFeed url
-  where
-	go Nothing = next $ feedProblem url "downloading the feed failed"
-	go (Just feedcontent) = case parseFeedString feedcontent of
-		Nothing -> next $ feedProblem url "parsing the feed failed"
-		Just f -> case findDownloads url f of
-			[] -> next $
-				feedProblem url "bad feed content; no enclosures to download"
-			l -> do
-				showOutput
-				ok <- and <$> mapM (performDownload opts cache) l
-				next $ cleanup url ok
-
-cleanup :: URLString -> Bool -> CommandCleanup
-cleanup url True = do
-	clearFeedProblem url
-	return True
-cleanup url False = feedProblem url "problem downloading some item(s) from feed"
+getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek
+getFeed opts cache url = do
+	showStart "importfeed" url
+	downloadFeed url >>= \case
+		Nothing -> showEndResult =<< feedProblem url
+			"downloading the feed failed"
+		Just feedcontent -> case parseFeedString feedcontent of
+			Nothing -> showEndResult =<< feedProblem url
+				"parsing the feed failed"
+			Just f -> case findDownloads url f of
+				[] -> showEndResult =<< feedProblem url
+					"bad feed content; no enclosures to download"
+				l -> do
+					showEndOk
+					ifM (and <$> mapM (performDownload opts cache) l)
+						( clearFeedProblem url
+						, void $ feedProblem url 
+							"problem downloading some item(s) from feed"
+						)
 
 data ToDownload = ToDownload
 	{ feed :: Feed

Command/Indirect.hs

@@ -36,20 +36,19 @@ start = ifM isDirect
 			giveup "Git is configured to not use symlinks, so you must use direct mode."
 		whenM probeCrippledFileSystem $
 			giveup "This repository seems to be on a crippled filesystem, you must use direct mode."
-		next perform
+		starting "indirect" (ActionItemOther Nothing) 
+			perform
 	, stop
 	)
 
 perform :: CommandPerform
 perform = do
-	showStart' "commit" Nothing
 	whenM stageDirect $ do
 		showOutput
 		void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit
 			[ Param "-m"
 			, Param "commit before switching to indirect mode"
 			]
-	showEndOk
 
 	-- Note that we set indirect mode early, so that we can use
 	-- moveAnnex in indirect mode.
@@ -59,7 +58,7 @@ perform = do
 	(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
 	forM_ l go
 	void $ liftIO clean
-	next cleanup
+	next $ return True
   where
 	{- Walk tree from top and move all present direct mode files into
 	 - the annex, replacing with symlinks. Also delete direct mode
@@ -80,7 +79,6 @@ perform = do
 	go _ = noop
 
 	fromdirect f k = do
-		showStart "indirect" f
 		removeInodeCache k
 		removeAssociatedFiles k
 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
@@ -92,14 +90,7 @@ perform = do
 				Right False -> warnlocked "Failed to move file to annex"
 				Left e -> catchNonAsync (restoreFile f k e) $
 					warnlocked . show
-		showEndOk
 
 	warnlocked msg = do
 		warning msg
 		warning "leaving this file as-is; correct this problem and run git annex add on it"
-	
-cleanup :: CommandCleanup
-cleanup = do
-	showStart' "indirect" Nothing
-	showEndOk
-	return True

Command/Init.hs

@@ -46,9 +46,8 @@ seek :: InitOptions -> CommandSeek
 seek = commandAction . start
 
 start :: InitOptions -> CommandStart
-start os = do
-	showStart' "init" (Just $ initDesc os)
-	next $ perform os
+start os = starting "init" (ActionItemOther (Just $ initDesc os)) $
+	perform os
 
 perform :: InitOptions -> CommandPerform
 perform os = do

Command/InitRemote.hs

@@ -37,9 +37,8 @@ start (name:ws) = ifM (isJust <$> findExisting name)
 			, do
 				let c = newConfig name
 				t <- either giveup return (findType config)
-
-				showStart' "initremote" (Just name)
-				next $ perform t name $ M.union config c
+				starting "initremote" (ActionItemOther (Just name)) $
+					perform t name $ M.union config c
 			)
 	)
   where

Command/Inprogress.hs

@@ -45,17 +45,11 @@ seek o = do
 start :: S.Set Key -> FilePath -> Key -> CommandStart
 start s _file k
 	| S.member k s = start' k
-	| otherwise = notInprogress
+	| otherwise = stop
 
 start' :: Key -> CommandStart
-start' k = do
+start' k = startingCustomOutput k $ do
 	tmpf <- fromRepo $ gitAnnexTmpObjectLocation k
-	ifM (liftIO $ doesFileExist tmpf)
-		( next $ next $ do
-			liftIO $ putStrLn tmpf
-			return True
-		, notInprogress
-		)
-
-notInprogress :: CommandStart
-notInprogress = stop
+	whenM (liftIO $ doesFileExist tmpf) $
+		liftIO $ putStrLn tmpf
+	next $ return True

Command/Lock.hs

@@ -41,8 +41,7 @@ seek ps = do
 startNew :: FilePath -> Key -> CommandStart
 startNew file key = ifM (isJust <$> isAnnexLink file)
 	( stop
-	, do
-		showStart "lock" file
+	, starting "lock" (mkActionItem (key, file)) $
 		go =<< liftIO (isPointerFile file)
 	)
   where
@@ -57,7 +56,7 @@ startNew file key = ifM (isJust <$> isAnnexLink file)
 				, errorModified
 				)
 			)
-	cont = next $ performNew file key
+	cont = performNew file key
 
 performNew :: FilePath -> Key -> CommandPerform
 performNew file key = do
@@ -106,10 +105,10 @@ cleanupNew file key = do
 
 startOld :: FilePath -> CommandStart
 startOld file = do
-	showStart "lock" file
 	unlessM (Annex.getState Annex.force)
 		errorModified
-	next $ performOld file
+	starting "lock" (ActionItemWorkTreeFile file) $
+		performOld file
 
 performOld :: FilePath -> CommandPerform
 performOld file = do

Command/Map.hs

@@ -40,7 +40,7 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = do
+start = startingNoMessage (ActionItemOther Nothing) $ do
 	rs <- combineSame <$> (spider =<< gitRepo)
 
 	umap <- uuidDescMap
@@ -49,7 +49,7 @@ start = do
 	file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"
 
 	liftIO $ writeFile file (drawMap rs trustmap umap)
-	next $ next $
+	next $
 		ifM (Annex.getState Annex.fast)
 			( runViewer file []
 			, runViewer file

Command/Merge.hs

@@ -23,13 +23,11 @@ seek _ = do
 	commandAction mergeSynced
 
 mergeBranch :: CommandStart
-mergeBranch = do
-	showStart' "merge" (Just "git-annex")
-	next $ do
-		Annex.Branch.update
-		-- commit explicitly, in case no remote branches were merged
-		Annex.Branch.commit =<< Annex.Branch.commitMessage
-		next $ return True
+mergeBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do
+	Annex.Branch.update
+	-- commit explicitly, in case no remote branches were merged
+	Annex.Branch.commit =<< Annex.Branch.commitMessage
+	next $ return True
 
 mergeSynced :: CommandStart
 mergeSynced = do

Command/MetaData.hs

@@ -99,14 +99,13 @@ start c o file k = startKeys c o (k, mkActionItem (k, afile))
 
 startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart
 startKeys c o (k, ai) = case getSet o of
-	Get f -> do
+	Get f -> startingCustomOutput k $ do
 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
 		liftIO $ forM_ l $
 			B8.putStrLn . fromMetaValue
-		stop
-	_ -> do
-		showStartKey "metadata" k ai
-		next $ perform c o k
+		next $ return True
+	_ -> starting "metadata" ai $
+		perform c o k
 
 perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform
 perform c o k = case getSet o of
@@ -168,8 +167,7 @@ startBatch (i, (MetaData m)) = case i of
 			Nothing -> giveup $ "not an annexed file: " ++ f
 	Right k -> go k (mkActionItem k)
   where
-	go k ai = do
-		showStartKey "metadata" k ai
+	go k ai = starting "metadata" ai $ do
 		let o = MetaDataOptions
 			{ forFiles = []
 			, getSet = if MetaData m == emptyMetaData
@@ -187,7 +185,7 @@ startBatch (i, (MetaData m)) = case i of
 		-- probably less expensive than cleaner methods,
 		-- such as taking from a list of increasing timestamps.
 		liftIO $ threadDelay 1
-		next $ perform t o k
+		perform t o k
 	mkModMeta (f, s)
 		| S.null s = DelMeta f Nothing
 		| otherwise = SetMeta f s

Command/Migrate.hs

@@ -38,9 +38,8 @@ start file key = do
 			newbackend <- maybe defaultBackend return 
 				=<< chooseBackend file
 			if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
-				then do
-					showStart "migrate" file
-					next $ perform file key oldbackend newbackend
+				then starting "migrate" (mkActionItem (key, file)) $
+					perform file key oldbackend newbackend
 				else stop
 
 {- Checks if a key is upgradable to a newer representation.

Command/Mirror.hs

@@ -54,7 +54,7 @@ start o file k = startKey o afile (k, ai)
 	ai = mkActionItem (k, afile)
 
 startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart
-startKey o afile (key, ai) = onlyActionOn key $ case fromToOptions o of
+startKey o afile (key, ai) = case fromToOptions o of
 	ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
 		( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r
 		, do

Command/Move.hs

@@ -74,7 +74,7 @@ startKey fromto removewhen =
 	uncurry $ start' fromto removewhen (AssociatedFile Nothing)
 
 start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
-start' fromto removewhen afile key ai = onlyActionOn key $
+start' fromto removewhen afile key ai =
 	case fromto of
 		Right (FromRemote src) ->
 			checkFailedTransferDirection ai Download $
@@ -86,9 +86,9 @@ start' fromto removewhen afile key ai = onlyActionOn key $
 			checkFailedTransferDirection ai Download $
 				toHereStart removewhen afile key ai
 
-showMoveAction :: RemoveWhen -> Key -> ActionItem -> Annex ()
-showMoveAction RemoveNever = showStartKey "copy"
-showMoveAction _ = showStartKey "move"
+describeMoveAction :: RemoveWhen -> String
+describeMoveAction RemoveNever = "copy"
+describeMoveAction _ = "move"
 
 toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
 toStart removewhen afile key ai dest = do
@@ -108,9 +108,9 @@ toStart' dest removewhen afile key ai = do
 			)
 		else go False (Remote.hasKey dest key)
   where
-	go fastcheck isthere = do
-		showMoveAction removewhen key ai
-		next $ toPerform dest removewhen key afile fastcheck =<< isthere
+	go fastcheck isthere =
+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $
+			toPerform dest removewhen key afile fastcheck =<< isthere
 
 expectedPresent :: Remote -> Key -> Annex Bool
 expectedPresent dest key = do
@@ -182,9 +182,9 @@ fromStart removewhen afile key ai src = case removewhen of
 	RemoveNever -> stopUnless (not <$> inAnnex key) go
 	RemoveSafe -> go
   where
-	go = stopUnless (fromOk src key) $ do
-		showMoveAction removewhen key ai
-		next $ fromPerform src removewhen key afile
+	go = stopUnless (fromOk src key) $
+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $
+			fromPerform src removewhen key afile
 
 fromOk :: Remote -> Key -> Annex Bool
 fromOk src key 
@@ -247,13 +247,13 @@ toHereStart removewhen afile key ai = case removewhen of
 	RemoveNever -> stopUnless (not <$> inAnnex key) go
 	RemoveSafe -> go
   where
-	go = do
+	go = startingNoMessage (OnlyActionOn key ai) $ do
 		rs <- Remote.keyPossibilities key
 		forM_ rs $ \r ->
-			includeCommandAction $ do
-				showMoveAction removewhen key ai
-				next $ fromPerform r removewhen key afile
-		stop
+			includeCommandAction $
+				starting (describeMoveAction removewhen) ai $
+					fromPerform r removewhen key afile
+		next $ return True
 
 {- The goal of this command is to allow the user maximum freedom to move
  - files as they like, while avoiding making bad situations any worse

Command/Multicast.hs

@@ -79,8 +79,7 @@ seek (MultiCastOptions Receive ups []) = commandAction $ receive ups
 seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."
 
 genAddress :: CommandStart
-genAddress = do
-	showStart' "gen-address" Nothing
+genAddress = starting "gen-address" (ActionItemOther Nothing) $ do
 	k <- uftpKey
 	(s, ok) <- case k of
 		KeyContainer s -> liftIO $ genkey (Param s)
@@ -91,7 +90,7 @@ genAddress = do
 	case (ok, parseFingerprint s) of
 		(False, _) -> giveup $ "uftp_keymgt failed: " ++ s
 		(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s
-		(True, Just fp) -> next $ next $ do
+		(True, Just fp) -> next $ do
 			recordFingerprint fp =<< getUUID
 			return True
   where
@@ -123,7 +122,7 @@ parseFingerprint = Fingerprint <$$> lastMaybe . filter isfingerprint . words
 		in length os == 20
 	
 send :: [CommandParam] -> [FilePath] -> CommandStart
-send ups fs = withTmpFile "send" $ \t h -> do
+send ups fs = do
 	-- Need to be able to send files with the names of git-annex
 	-- keys, and uftp does not allow renaming the files that are sent.
 	-- In a direct mode repository, the annex objects do not have
@@ -131,47 +130,43 @@ send ups fs = withTmpFile "send" $ \t h -> do
 	-- expensive.
 	whenM isDirect $
 		giveup "Sorry, multicast send cannot be done from a direct mode repository."
-	
-	showStart' "generating file list" Nothing
-	fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs
-	matcher <- Limit.getMatcher
-	let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
-		liftIO $ hPutStrLn h o
-	forM_ fs' $ \f -> do
-		mk <- lookupFile f
-		case mk of
-			Nothing -> noop
-			Just k -> withObjectLoc k (addlist f) (const noop)
-	liftIO $ hClose h
-	showEndOk
-
-	showStart' "sending files" Nothing
-	showOutput
-	serverkey <- uftpKey
-	u <- getUUID
-	withAuthList $ \authlist -> do
-		let ps =
-			-- Force client authentication.
-			[ Param "-c"
-			, Param "-Y", Param "aes256-cbc"
-			, Param "-h", Param "sha512"
-			-- Picked ecdh_ecdsa for perfect forward secrecy,
-			-- and because a EC key exchange algorithm is
-			-- needed since all keys are EC.
-			, Param "-e", Param "ecdh_ecdsa"
-			, Param "-k", uftpKeyParam serverkey
-			, Param "-U", Param (uftpUID u)
-			-- only allow clients on the authlist
-			, Param "-H", Param ("@"++authlist)
-			-- pass in list of files to send
-			, Param "-i", File t
-			] ++ ups
-		liftIO (boolSystem "uftp" ps) >>= showEndResult
-	stop
+	starting "sending files" (ActionItemOther Nothing) $
+		withTmpFile "send" $ \t h -> do
+			fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs
+			matcher <- Limit.getMatcher
+			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
+				liftIO $ hPutStrLn h o
+			forM_ fs' $ \f -> do
+				mk <- lookupFile f
+				case mk of
+					Nothing -> noop
+					Just k -> withObjectLoc k (addlist f) (const noop)
+			liftIO $ hClose h
+			
+			serverkey <- uftpKey
+			u <- getUUID
+			withAuthList $ \authlist -> do
+				let ps =
+					-- Force client authentication.
+					[ Param "-c"
+					, Param "-Y", Param "aes256-cbc"
+					, Param "-h", Param "sha512"
+					-- Picked ecdh_ecdsa for perfect forward secrecy,
+					-- and because a EC key exchange algorithm is
+					-- needed since all keys are EC.
+					, Param "-e", Param "ecdh_ecdsa"
+					, Param "-k", uftpKeyParam serverkey
+					, Param "-U", Param (uftpUID u)
+					-- only allow clients on the authlist
+					, Param "-H", Param ("@"++authlist)
+					-- pass in list of files to send
+					, Param "-i", File t
+					] ++ ups
+				liftIO (boolSystem "uftp" ps) >>= showEndResult
+			next $ return True
 
 receive :: [CommandParam] -> CommandStart
-receive ups = do
-	showStart' "receiving multicast files" Nothing
+receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do
 	showNote "Will continue to run until stopped by ctrl-c"
 	
 	showOutput
@@ -204,7 +199,7 @@ receive ups = do
 				`after` boolSystemEnv "uftpd" ps (Just environ)
 		mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
 		showEndResult =<< liftIO (wait runner)
-	stop
+	next $ return True
 
 storeReceived :: FilePath -> Annex ()
 storeReceived f = do

Command/NumCopies.hs

@@ -33,7 +33,7 @@ start [s] = case readish s of
 start _ = giveup "Specify a single number."
 
 startGet :: CommandStart
-startGet = next $ next $ do
+startGet = startingCustomOutput (ActionItemOther Nothing) $ next $ do
 	v <- getGlobalNumCopies
 	case v of
 		Just n -> liftIO $ putStrLn $ show $ fromNumCopies n
@@ -46,9 +46,6 @@ startGet = next $ next $ do
 	return True
 
 startSet :: Int -> CommandStart
-startSet n = do
-	allowMessages
-	showStart' "numcopies" (Just $ show n)
-	next $ next $ do
-		setGlobalNumCopies $ NumCopies n
-		return True
+startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do
+	setGlobalNumCopies $ NumCopies n
+	next $ return True

Command/P2P.hs

@@ -96,9 +96,8 @@ genAddresses addrs = do
 
 -- Address is read from stdin, to avoid leaking it in shell history.
 linkRemote :: RemoteName -> CommandStart
-linkRemote remotename = do
-	showStart' "p2p link" (Just remotename)
-	next $ next promptaddr
+linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $
+	next promptaddr
   where
 	promptaddr = do
 		liftIO $ putStrLn ""
@@ -122,12 +121,11 @@ linkRemote remotename = do
 
 startPairing :: RemoteName -> [P2PAddress] -> CommandStart
 startPairing _ [] = giveup "No P2P networks are currrently available."
-startPairing remotename addrs = do
-	showStart' "p2p pair" (Just remotename)
-	ifM (liftIO Wormhole.isInstalled)
-		( next $ performPairing remotename addrs
-		, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
-		) 
+startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)
+	( starting "p2p pair" (ActionItemOther (Just remotename)) $
+		performPairing remotename addrs
+	, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
+	) 
 
 performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
 performPairing remotename addrs = do

Command/P2PStdIO.hs

@@ -27,7 +27,7 @@ seek [u] = commandAction $ start $ toUUID u
 seek _ = giveup "missing UUID parameter"
 
 start :: UUID -> CommandStart
-start theiruuid = do
+start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do
 	servermode <- liftIO $ do
 		ro <- Checks.checkEnvSet Checks.readOnlyEnv
 		ao <- Checks.checkEnvSet Checks.appendOnlyEnv
@@ -47,4 +47,4 @@ start theiruuid = do
 		Left (ProtoFailureIOError e) | isEOFError e -> done
 		Left e -> giveup (describeProtoFailure e)
   where
-	done = next $ next $ return True
+	done = next $ return True

Command/PreCommit.hs

@@ -84,23 +84,22 @@ seek ps = lockPreCommitHook $ ifM isDirect
 	
 
 startInjectUnlocked :: FilePath -> CommandStart
-startInjectUnlocked f = next $ do
+startInjectUnlocked f = startingCustomOutput (ActionItemOther Nothing) $ do
 	unlessM (callCommandAction $ Command.Add.start f) $
 		error $ "failed to add " ++ f ++ "; canceling commit"
 	next $ return True
 
 startDirect :: [String] -> CommandStart
-startDirect _ = next $ next preCommitDirect
+startDirect _ = startingCustomOutput (ActionItemOther Nothing) $ 
+	next preCommitDirect
 
 addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
-addViewMetaData v f k = do
-	showStart "metadata" f
-	next $ next $ changeMetaData k $ fromView v f
+addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
+	next $ changeMetaData k $ fromView v f
 
 removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
-removeViewMetaData v f k = do
-	showStart "metadata" f
-	next $ next $ changeMetaData k $ unsetMetaData $ fromView v f
+removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
+	next $ changeMetaData k $ unsetMetaData $ fromView v f
 
 changeMetaData :: Key -> MetaData -> CommandCleanup
 changeMetaData k metadata = do

Command/ReKey.hs

@@ -60,9 +60,8 @@ start (file, newkey) = ifAnnexed file go stop
   where
 	go oldkey
 		| oldkey == newkey = stop
-		| otherwise = do
-			showStart "rekey" file
-			next $ perform file oldkey newkey
+		| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $
+			perform file oldkey newkey
 
 perform :: FilePath -> Key -> Key -> CommandPerform
 perform file oldkey newkey = do

Command/RegisterUrl.hs

@@ -39,16 +39,16 @@ seek o = case (batchOption o, keyUrlPairs o) of
 	(NoBatch, ps) -> withWords (commandAction . start) ps
 
 start :: [String] -> CommandStart
-start (keyname:url:[]) = do
-	let key = mkKey keyname
-	showStart' "registerurl" (Just url)
-	next $ perform key url
+start (keyname:url:[]) = 
+	starting "registerurl" (ActionItemOther (Just url)) $ do
+		let key = mkKey keyname
+		perform key url
 start _ = giveup "specify a key and an url"
 
 startMass :: BatchFormat -> CommandStart
-startMass fmt = do
-	showStart' "registerurl" (Just "stdin")
-	next (massAdd fmt)
+startMass fmt = 
+	starting "registerurl" (ActionItemOther (Just "stdin")) $
+		massAdd fmt
 
 massAdd :: BatchFormat -> CommandPerform
 massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt

Command/Reinit.hs

@@ -24,9 +24,8 @@ seek :: CmdParams -> CommandSeek
 seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
-start ws = do
-	showStart' "reinit" (Just s)
-	next $ perform s
+start ws = starting "reinit" (ActionItemOther (Just s)) $
+	perform s
   where
 	s = unwords ws
 

Command/Reinject.hs

@@ -41,28 +41,27 @@ seek os
 startSrcDest :: [FilePath] -> CommandStart
 startSrcDest (src:dest:[])
 	| src == dest = stop
-	| otherwise = notAnnexed src $ do
-		showStart "reinject" dest
-		next $ ifAnnexed dest go stop
+	| otherwise = notAnnexed src $ ifAnnexed dest go stop
   where
-	go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
-		( perform src key
-		, giveup $ src ++ " does not have expected content of " ++ dest
-		)
+	go key = starting "reinject" (ActionItemOther (Just src)) $
+		ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
+			( perform src key
+			, giveup $ src ++ " does not have expected content of " ++ dest
+			)
 startSrcDest _ = giveup "specify a src file and a dest file"
 
 startKnown :: FilePath -> CommandStart
-startKnown src = notAnnexed src $ do
-	showStart "reinject" src
-	mkb <- genKey (KeySource src src Nothing) Nothing
-	case mkb of
-		Nothing -> error "Failed to generate key"
-		Just (key, _) -> ifM (isKnownKey key)
-			( next $ perform src key
-			, do
-				warning "Not known content; skipping"
-				next $ next $ return True
-			)
+startKnown src = notAnnexed src $
+	starting "reinject" (ActionItemOther (Just src)) $ do
+		mkb <- genKey (KeySource src src Nothing) Nothing
+		case mkb of
+			Nothing -> error "Failed to generate key"
+			Just (key, _) -> ifM (isKnownKey key)
+				( perform src key
+				, do
+					warning "Not known content; skipping"
+					next $ return True
+				)
 
 notAnnexed :: FilePath -> CommandStart -> CommandStart
 notAnnexed src = ifAnnexed src $

Command/RenameRemote.hs

@@ -40,9 +40,8 @@ start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
 				Nothing -> giveup "That is not a special remote."
 				Just cfg -> go u cfg
   where
-	go u cfg = do
-		showStart' "rename" Nothing
-		next $ perform u cfg newname
+	go u cfg = starting "rename" (ActionItemOther Nothing) $
+		perform u cfg newname
 start _ = giveup "Specify an old name (or uuid or description) and a new name."
 
 perform :: UUID -> R.RemoteConfig -> String -> CommandPerform

Command/Repair.hs

@@ -25,7 +25,8 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = next $ next $ runRepair =<< Annex.getState Annex.force
+start = starting "repair" (ActionItemOther Nothing) $ 
+	next $ runRepair =<< Annex.getState Annex.force
 
 runRepair :: Bool -> Annex Bool
 runRepair forced = do

Command/ResolveMerge.hs

@@ -22,8 +22,7 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = do
-	showStart' "resolvemerge" Nothing
+start = starting "resolvemerge" (ActionItemOther Nothing) $ do
 	us <- fromMaybe nobranch <$> inRepo Git.Branch.current
 	d <- fromRepo Git.localGitDir
 	let merge_head = d </> "MERGE_HEAD"
@@ -32,7 +31,7 @@ start = do
 	ifM (resolveMerge (Just us) them False)
 		( do
 			void $ commitResolvedMerge Git.Branch.ManualCommit
-			next $ next $ return True
+			next $ return True
 		, giveup "Merge conflict could not be automatically resolved."
 		)
   where

Command/RmUrl.hs

@@ -42,9 +42,9 @@ batchParser s = case separate (== ' ') (reverse s) of
 		| otherwise -> Right (reverse rf, reverse ru)
 
 start :: (FilePath, URLString) -> CommandStart
-start (file, url) = flip whenAnnexed file $ \_ key -> do
-	showStart "rmurl" file
-	next $ next $ cleanup url key
+start (file, url) = flip whenAnnexed file $ \_ key ->
+	starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $
+		next $ cleanup url key
 
 cleanup :: String -> Key -> CommandCleanup
 cleanup url key = do

Command/Schedule.hs

@@ -25,16 +25,15 @@ seek = withWords (commandAction . start)
 start :: [String] -> CommandStart
 start = parse
   where
-	parse (name:[]) = go name performGet
-	parse (name:expr:[]) = go name $ \uuid -> do
-		allowMessages
-		showStart' "schedule" (Just name)
-		performSet expr uuid
-	parse _ = giveup "Specify a repository."
-
-	go name a = do
+	parse (name:[]) = do
 		u <- Remote.nameToUUID name
-		next $ a u
+		startingCustomOutput (ActionItemOther Nothing) $
+			performGet u
+	parse (name:expr:[]) = do
+		u <- Remote.nameToUUID name
+		startingUsualMessages "schedule" (ActionItemOther (Just name)) $
+			performSet expr u
+	parse _ = giveup "Specify a repository."
 
 performGet :: UUID -> CommandPerform
 performGet uuid = do

Command/SetKey.hs

@@ -20,9 +20,8 @@ seek :: CmdParams -> CommandSeek
 seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
-start (keyname:file:[]) = do
-	showStart "setkey" file
-	next $ perform file (mkKey keyname)
+start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $
+	perform file (mkKey keyname)
 start _ = giveup "specify a key and a content file"
 
 mkKey :: String -> Key

Command/SetPresentKey.hs

@@ -47,9 +47,8 @@ parseKeyStatus (ks:us:vs:[]) = do
 parseKeyStatus _ = Left "Bad input. Expected: key uuid value"
 
 start :: KeyStatus -> CommandStart
-start (KeyStatus k u s) = do
-	showStartKey "setpresentkey" k (mkActionItem k)
-	next $ perform k u s
+start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $
+	perform k u s
 
 perform :: Key -> UUID -> LogStatus -> CommandPerform
 perform k u s = next $ do

Command/Sync.hs

@@ -280,11 +280,10 @@ syncRemotes' ps available =
 	fastest = fromMaybe [] . headMaybe . Remote.byCost
 
 commit :: SyncOptions -> CommandStart
-commit o = stopUnless shouldcommit $ next $ next $ do
+commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do
 	commitmessage <- maybe commitMsg return (messageOption o)
-	showStart' "commit" Nothing
 	Annex.Branch.commit =<< Annex.Branch.commitMessage
-	ifM isDirect
+	next $ ifM isDirect
 		( do
 			void stageDirect
 			void preCommitDirect
@@ -321,20 +320,19 @@ commitStaged commitmode commitmessage = do
 
 mergeLocal :: [Git.Merge.MergeConfig] -> ResolveMergeOverride -> CurrBranch -> CommandStart
 mergeLocal mergeconfig resolvemergeoverride currbranch@(Just _, _) =
-	go =<< needMerge currbranch
-  where
-	go Nothing = stop
-	go (Just syncbranch) = do
-		showStart' "merge" (Just $ Git.Ref.describe syncbranch)
-		next $ next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
+	needMerge currbranch >>= \case
+		Nothing -> stop
+		Just syncbranch ->
+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $
+				next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
 mergeLocal _ _ (Nothing, madj) = do
 	b <- inRepo Git.Branch.currentUnsafe
-	ifM (isJust <$> needMerge (b, madj))
-		( do
-			warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."
-			next $ next $ return False
-		, stop
-		)
+	needMerge (b, madj) >>= \case
+		Nothing -> stop
+		Just syncbranch ->
+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do
+				warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."
+				next $ return False
 
 -- Returns the branch that should be merged, if any.
 needMerge :: CurrBranch -> Annex (Maybe Git.Branch)
@@ -395,12 +393,13 @@ updateBranch syncbranch updateto g =
 		] g
 
 pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart
-pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ do
-	showStart' "pull" (Just (Remote.name remote))
-	next $ do
+pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $
+	starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do
 		showOutput
-		stopUnless fetch $
-			next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
+		ifM fetch
+			( next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
+			, next $ return True
+			)
   where
 	fetch = do
 		repo <- Remote.getRepo remote
@@ -451,9 +450,8 @@ mergeRemote remote currbranch mergeconfig resolvemergeoverride = ifM isBareRepo
 
 pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
 pushRemote _o _remote (Nothing, _) = stop
-pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
-	showStart' "push" (Just (Remote.name remote))
-	next $ next $ do
+pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $
+	starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
 		repo <- Remote.getRepo remote
 		showOutput
 		ok <- inRepoWithSshOptionsTo repo gc $
@@ -628,10 +626,14 @@ seekSyncContent o rs currbranch = do
 	
 	gokey mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k
 
-	go ebloom mvar af k = commandAction $ do
-		whenM (syncFile ebloom rs af k) $
-			void $ liftIO $ tryPutMVar mvar ()
-		return Nothing
+	go ebloom mvar af k = do
+		-- Run syncFile as a command action so file transfers run
+		-- concurrently.
+		let ai = OnlyActionOn k (ActionItemKey k)
+		commandAction $ startingNoMessage ai $ do
+			whenM (syncFile ebloom rs af k) $
+				void $ liftIO $ tryPutMVar mvar ()
+			next $ return True
 
 {- If it's preferred content, and we don't have it, get it from one of the
  - listed remotes (preferring the cheaper earlier ones).
@@ -647,7 +649,7 @@ seekSyncContent o rs currbranch = do
  - Returns True if any file transfers were made.
  -}
 syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool
-syncFile ebloom rs af k = onlyActionOn' k $ do
+syncFile ebloom rs af k = do
 	inhere <- inAnnex k
 	locs <- map Remote.uuid <$> Remote.keyPossibilities k
 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
@@ -689,9 +691,8 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
 		( return [ get have ]
 		, return []
 		)
-	get have = includeCommandAction $ do
-		showStartKey "get" k ai
-		next $ next $ getKey' k af have
+	get have = includeCommandAction $ starting "get" ai $
+		next $ getKey' k af have
 
 	wantput r
 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
@@ -764,24 +765,23 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
 
 cleanupLocal :: CurrBranch -> CommandStart
 cleanupLocal (Nothing, _) = stop
-cleanupLocal (Just currb, _) = do
-	showStart' "cleanup" (Just "local")
-	next $ next $ do
-		delbranch $ syncBranch currb
-		delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
-		mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
-			=<< listTaggedBranches
-		return True
+cleanupLocal (Just currb, _) = 
+	starting "cleanup" (ActionItemOther (Just "local")) $ 
+		next $ do
+			delbranch $ syncBranch currb
+			delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
+			mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
+				=<< listTaggedBranches
+			return True
   where
 	delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $
 		inRepo $ Git.Branch.delete b
 
 cleanupRemote :: Remote -> CurrBranch -> CommandStart
 cleanupRemote _ (Nothing, _) = stop
-cleanupRemote remote (Just b, _) = do
-	showStart' "cleanup" (Just (Remote.name remote))
-	next $ next $
-		inRepo $ Git.Command.runBool
+cleanupRemote remote (Just b, _) =
+	starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $
+		next $ inRepo $ Git.Command.runBool
 			[ Param "push"
 			, Param "--quiet"
 			, Param "--delete"

Command/TestRemote.hs

@@ -66,8 +66,7 @@ seek :: TestRemoteOptions -> CommandSeek
 seek = commandAction . start 
 
 start :: TestRemoteOptions -> CommandStart
-start o = do
-	showStart' "testremote" (Just (testRemote o))
+start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
 	fast <- Annex.getState Annex.fast
 	r <- either giveup disableExportTree =<< Remote.byName' (testRemote o)
 	ks <- case testReadonlyFile o of
@@ -89,7 +88,7 @@ start o = do
 	exportr <- if Remote.readonly r'
 		then return Nothing
 		else exportTreeVariant r'
-	next $ perform rs unavailrs exportr ks
+	perform rs unavailrs exportr ks
   where
 	basesz = fromInteger $ sizeOption o
 

Command/TransferKey.hs

@@ -45,9 +45,9 @@ seek :: TransferKeyOptions -> CommandSeek
 seek o = withKeys (commandAction . start o) (keyOptions o)
 
 start :: TransferKeyOptions -> Key -> CommandStart
-start o key = case fromToOptions o of
-	ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest
-	FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src
+start o key = startingCustomOutput key $ case fromToOptions o of
+	ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest
+	FromRemote src -> fromPerform key (fileOption o) =<< getParsed src
 
 toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
 toPerform key file remote = go Upload file $

Command/Trust.hs

@@ -27,9 +27,8 @@ trustCommand c level = withWords (commandAction . start)
   where
 	start ws = do
 		let name = unwords ws
-		showStart' c (Just name)
 		u <- Remote.nameToUUID name
-		next $ perform u
+		starting c (ActionItemOther (Just name)) (perform u)
 	perform uuid = do
 		trustSet uuid level
 		when (level == DeadTrusted) $

Command/Unannex.hs

@@ -66,12 +66,12 @@ wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
 		)
 
 start :: FilePath -> Key -> CommandStart
-start file key = stopUnless (inAnnex key) $ do
-	showStart "unannex" file
-	next $ ifM isDirect
-		( performDirect file key
-		, performIndirect file key
-		)
+start file key = stopUnless (inAnnex key) $
+	starting "unannex" (mkActionItem (key, file)) $
+		ifM isDirect
+			( performDirect file key
+			, performIndirect file key
+			)
 
 performIndirect :: FilePath -> Key -> CommandPerform
 performIndirect file key = do

Command/Undo.hs

@@ -46,9 +46,8 @@ seek ps = do
 	withStrings (commandAction . start) ps
 
 start :: FilePath -> CommandStart
-start p = do
-	showStart "undo" p
-	next $ perform p
+start p = starting "undo" (ActionItemOther (Just p)) $
+	perform p
 
 perform :: FilePath -> CommandPerform
 perform p = do

Command/Ungroup.hs

@@ -23,9 +23,9 @@ seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
 start (name:g:[]) = do
-	showStart' "ungroup" (Just name)
 	u <- Remote.nameToUUID name
-	next $ perform u (toGroup g)
+	starting "ungroup" (ActionItemOther (Just name)) $
+		perform u (toGroup g)
 start _ = giveup "Specify a repository and a group."
 
 perform :: UUID -> Group -> CommandPerform

Command/Unlock.hs

@@ -37,11 +37,10 @@ seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems p
  - to a pointer. -}
 start :: FilePath -> Key -> CommandStart
 start file key = ifM (isJust <$> isAnnexLink file)
-	( do
-		showStart "unlock" file
+	( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $
 		ifM versionSupportsUnlockedPointers
-			( next $ performNew file key
-			, startOld file key
+			( performNew file key
+			, performOld file key
 			)
 	, stop
 	)
@@ -67,22 +66,22 @@ cleanupNew dest key destmode = do
 	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest)
 	return True
 
-startOld :: FilePath -> Key -> CommandStart
-startOld file key = 
+performOld :: FilePath -> Key -> CommandPerform
+performOld file key = 
 	ifM (inAnnex key)
 		( ifM (isJust <$> catKeyFileHEAD file)
-			( next $ performOld file key
+			( performOld' file key
 			, do
 				warning "this has not yet been committed to git; cannot unlock it"
-				next $ next $ return False
+				next $ return False
 			)
 		, do
 			warning "content not present; cannot unlock"
-			next $ next $ return False
+			next $ return False
 		)
 
-performOld :: FilePath -> Key -> CommandPerform
-performOld dest key = ifM (checkDiskSpace Nothing key 0 True)
+performOld' :: FilePath -> Key -> CommandPerform
+performOld' dest key = ifM (checkDiskSpace Nothing key 0 True)
 	( do
 		src <- calcRepo $ gitAnnexLocation key
 		tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key

Command/Unused.hs

@@ -70,8 +70,7 @@ start o = do
 		Just "." -> (".", checkUnused refspec)
 		Just "here" -> (".", checkUnused refspec)
 		Just n -> (n, checkRemoteUnused n refspec)
-	showStart' "unused" (Just name)
-	next perform
+	starting "unused" (ActionItemOther (Just name)) perform
 
 checkUnused :: RefSpec -> CommandPerform
 checkUnused refspec = chain 0
@@ -335,6 +334,6 @@ startUnused message unused badunused tmpunused maps n = search
 	search ((m, a):rest) =
 		case M.lookup n m of
 			Nothing -> search rest
-			Just key -> do
-				showStart' message (Just $ show n)
-				next $ a key
+			Just key -> starting message
+				(ActionItemOther $ Just $ show n)
+				(a key)

Command/Upgrade.hs

@@ -22,9 +22,8 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = do
-	showStart' "upgrade" Nothing
+start = starting "upgrade" (ActionItemOther Nothing) $ do
 	whenM (isNothing <$> getVersion) $ do
 		initialize Nothing Nothing
 	r <- upgrade False latestVersion
-	next $ next $ return r
+	next $ return r

Command/VAdd.hs

@@ -22,16 +22,15 @@ seek :: CmdParams -> CommandSeek
 seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
-start params = do
-	showStart' "vadd" Nothing
+start params = starting "vadd" (ActionItemOther Nothing) $ 
 	withCurrentView $ \view -> do
 		let (view', change) = refineView view $
 			map parseViewParam $ reverse params
 		case change of
 			Unchanged -> do
 				showNote "unchanged"
-				next $ next $ return True
-			Narrowing -> next $ next $ do
+				next $ return True
+			Narrowing -> next $ do
 				if visibleViewSize view' == visibleViewSize view
 					then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
 					else checkoutViewBranch view' narrowView

Command/VCycle.hs

@@ -26,14 +26,13 @@ start ::CommandStart
 start = go =<< currentView
   where
 	go Nothing = giveup "Not in a view."
-	go (Just v) = do
-		showStart' "vcycle" Nothing
+	go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do
 		let v' = v { viewComponents = vcycle [] (viewComponents v) }
 		if v == v'
 			then do
 				showNote "unchanged"
-				next $ next $ return True
-			else next $ next $ checkoutViewBranch v' narrowView
+				next $ return True
+			else next $ checkoutViewBranch v' narrowView
 
 	vcycle rest (c:cs)
 		| viewVisible c = rest ++ cs ++ [c]

Command/VFilter.hs

@@ -20,11 +20,10 @@ seek :: CmdParams -> CommandSeek
 seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
-start params = do
-	showStart' "vfilter" Nothing
+start params = starting "vfilter" (ActionItemOther Nothing) $
 	withCurrentView $ \view -> do
 		let view' = filterView view $
 			map parseViewParam $ reverse params
-		next $ next $ if visibleViewSize view' > visibleViewSize view
+		next $ if visibleViewSize view' > visibleViewSize view
 			then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
 			else checkoutViewBranch view' narrowView

Command/VPop.hs

@@ -27,17 +27,16 @@ start :: [String] -> CommandStart
 start ps = go =<< currentView
   where
 	go Nothing = giveup "Not in a view."
-	go (Just v) = do
-		showStart' "vpop" (Just $ show num)
+	go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do
 		removeView v
 		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
 			<$> recentViews
 		mapM_ removeView oldvs
 		case vs of
-			(oldv:_) -> next $ next $ do
+			(oldv:_) -> next $ do
 				showOutput
 				checkoutViewBranch oldv (return . branchView)
-			_ -> next $ next $ do
+			_ -> next $ do
 				showOutput
 				inRepo $ Git.Command.runBool
 					[ Param "checkout"

Command/View.hs

@@ -29,16 +29,15 @@ seek = withWords (commandAction . start)
 
 start :: [String] -> CommandStart
 start [] = giveup "Specify metadata to include in view"
-start ps = do
-	showStart' "view" Nothing
-	ifM safeToEnterView
-		( do
-			view <- mkView ps
-			go view  =<< currentView
-		, giveup "Not safe to enter view."
-		)
+start ps = ifM safeToEnterView
+	( do
+		view <- mkView ps
+		go view  =<< currentView
+	, giveup "Not safe to enter view."
+	)
   where
-	go view Nothing = next $ perform view
+	go view Nothing = starting "view" (ActionItemOther Nothing) $
+		perform view
 	go view (Just v)
 		| v == view = stop
 		| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."

Command/Wanted.hs

@@ -32,16 +32,15 @@ cmd' name desc getter setter = noMessages $
 
 	seek = withWords (commandAction . start)
 
-	start (rname:[]) = go rname (performGet getter)
-	start (rname:expr:[]) = go rname $ \uuid -> do
-		allowMessages
-		showStart' name (Just rname)
-		performSet setter expr uuid
-	start _ = giveup "Specify a repository."
-		
-	go rname a = do
+	start (rname:[]) = do
 		u <- Remote.nameToUUID rname
-		next $ a u
+		startingCustomOutput (ActionItemOther Nothing) $
+			performGet getter u
+	start (rname:expr:[]) = do
+		u <- Remote.nameToUUID rname
+		startingUsualMessages name (ActionItemOther (Just rname)) $
+			performSet setter expr u
+	start _ = giveup "Specify a repository."
 
 performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform
 performGet getter a = do

Command/Whereis.hs

@@ -53,9 +53,7 @@ start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile))
 	afile = AssociatedFile (Just file)
 
 startKeys :: M.Map UUID Remote -> (Key, ActionItem) -> CommandStart
-startKeys remotemap (key, ai) = do
-	showStartKey "whereis" key ai
-	next $ perform remotemap key
+startKeys remotemap (key, ai) = starting "whereis" ai $ perform remotemap key
 
 perform :: M.Map UUID Remote -> Key -> CommandPerform
 perform remotemap key = do

Git/FilePath.hs

@@ -37,6 +37,7 @@ newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
 
 {- A file in a branch or other treeish. -}
 data BranchFilePath = BranchFilePath Ref TopFilePath
+	deriving (Show, Eq, Ord)
 
 {- Git uses the branch:file form to refer to a BranchFilePath -}
 descBranchFilePath :: BranchFilePath -> String

Messages.hs

@@ -1,6 +1,6 @@
 {- git-annex output messages
  -
- - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -8,8 +8,10 @@
 module Messages (
 	showStart,
 	showStart',
-	showStartKey,
-	ActionItem,
+	showStartMessage,
+	showEndMessage,
+	StartMessage(..),
+	ActionItem(..),
 	mkActionItem,
 	showNote,
 	showAction,
@@ -42,7 +44,6 @@ module Messages (
 	debugEnabled,
 	commandProgressDisabled,
 	outputMessage,
-	implicitMessage,
 	withMessageState,
 	prompt,
 ) where
@@ -58,6 +59,8 @@ import Types
 import Types.Messages
 import Types.ActionItem
 import Types.Concurrency
+import Types.Command (StartMessage(..))
+import Types.Transfer (transferKey)
 import Messages.Internal
 import Messages.Concurrent
 import qualified Messages.JSON as JSON
@@ -81,6 +84,30 @@ showStartKey command key i = outputMessage json $
   where
 	json = JSON.start command (actionItemWorkTreeFile i) (Just key)
 
+showStartMessage :: StartMessage -> Annex ()
+showStartMessage (StartMessage command ai) = case ai of
+	ActionItemAssociatedFile _ k -> showStartKey command k ai
+	ActionItemKey k -> showStartKey command k ai
+	ActionItemBranchFilePath _ k -> showStartKey command k ai
+	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai
+	ActionItemWorkTreeFile file -> showStart command file
+	ActionItemOther msg -> showStart' command msg
+	OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai')
+showStartMessage (StartUsualMessages command ai) = do
+	outputType <$> Annex.getState Annex.output >>= \case
+		QuietOutput -> Annex.setOutput NormalOutput
+		_ -> noop
+	showStartMessage (StartMessage command ai)
+showStartMessage (StartNoMessage _) = noop
+showStartMessage (CustomOutput _) = Annex.setOutput QuietOutput
+
+-- Only show end result if the StartMessage is one that gets displayed.
+showEndMessage :: StartMessage -> Bool -> Annex ()
+showEndMessage (StartMessage _ _) = showEndResult
+showEndMessage (StartUsualMessages _ _) = showEndResult
+showEndMessage (StartNoMessage _) = const noop
+showEndMessage (CustomOutput _) = const noop
+
 showNote :: String -> Annex ()
 showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") "
 
@@ -251,12 +278,6 @@ commandProgressDisabled = withMessageState $ \s -> return $
 		JSONOutput _ -> True
 		NormalOutput -> concurrentOutputEnabled s
 
-{- Use to show a message that is displayed implicitly, and so might be
- - disabled when running a certian command that needs more control over its
- - output. -}
-implicitMessage :: Annex () -> Annex ()
-implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output)
-
 {- Prevents any concurrent console access while running an action, so
  - that the action is the only thing using the console, and can eg prompt
  - the user.

Types/ActionItem.hs

@@ -13,21 +13,38 @@ import Key
 import Types.Transfer
 import Git.FilePath
 
+import Data.Maybe
+
 data ActionItem 
 	= ActionItemAssociatedFile AssociatedFile Key
 	| ActionItemKey Key
 	| ActionItemBranchFilePath BranchFilePath Key
 	| ActionItemFailedTransfer Transfer TransferInfo
+	| ActionItemWorkTreeFile FilePath
+	| ActionItemOther (Maybe String)
+	-- Use to avoid more than one thread concurrently processing the
+	-- same Key.
+	| OnlyActionOn Key ActionItem
+	deriving (Show, Eq)
 
 class MkActionItem t where
 	mkActionItem :: t -> ActionItem
 
+instance MkActionItem ActionItem where
+	mkActionItem = id
+
 instance MkActionItem (AssociatedFile, Key) where
 	mkActionItem = uncurry ActionItemAssociatedFile
 
 instance MkActionItem (Key, AssociatedFile) where
 	mkActionItem = uncurry $ flip ActionItemAssociatedFile
 
+instance MkActionItem (Key, FilePath) where
+	mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key
+
+instance MkActionItem (FilePath, Key) where
+	mkActionItem (file, key) = mkActionItem (key, file)
+
 instance MkActionItem Key where
 	mkActionItem = ActionItemKey
 
@@ -39,23 +56,33 @@ instance MkActionItem (Transfer, TransferInfo) where
 
 actionItemDesc :: ActionItem -> String
 actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f
-actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = 
+	serializeKey k
 actionItemDesc (ActionItemKey k) = serializeKey k
 actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
 actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
 	ActionItemAssociatedFile (associatedFile i) (transferKey t)
+actionItemDesc (ActionItemWorkTreeFile f) = f
+actionItemDesc (ActionItemOther s) = fromMaybe "" s
+actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
 
-actionItemKey :: ActionItem -> Key
-actionItemKey (ActionItemAssociatedFile _ k) = k
-actionItemKey (ActionItemKey k) = k
-actionItemKey (ActionItemBranchFilePath _ k) = k
-actionItemKey (ActionItemFailedTransfer t _) = transferKey t
+actionItemKey :: ActionItem -> Maybe Key
+actionItemKey (ActionItemAssociatedFile _ k) = Just k
+actionItemKey (ActionItemKey k) = Just k
+actionItemKey (ActionItemBranchFilePath _ k) = Just k
+actionItemKey (ActionItemFailedTransfer t _) = Just (transferKey t)
+actionItemKey (ActionItemWorkTreeFile _) = Nothing
+actionItemKey (ActionItemOther _) = Nothing
+actionItemKey (OnlyActionOn _ ai) = actionItemKey ai
 
 actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
 actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
+actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f
+actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai
 actionItemWorkTreeFile _ = Nothing
 
 actionItemTransferDirection :: ActionItem -> Maybe Direction
 actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $
 	transferDirection t
+actionItemTransferDirection (OnlyActionOn _ ai) = actionItemTransferDirection ai
 actionItemTransferDirection _ = Nothing

Types/Command.hs

@@ -1,6 +1,6 @@
 {- git-annex command data types
  -
- - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -12,6 +12,7 @@ import Options.Applicative.Types (Parser)
 
 import Types
 import Types.DeferredParse
+import Types.ActionItem
 
 {- A command runs in these stages.
  -
@@ -25,11 +26,11 @@ data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
  -    the repo to find things to act on (ie, new files to add), and
  -    runs commandAction to handle all necessary actions. -}
 type CommandSeek = Annex ()
-{- d. The start stage is run before anything is printed about the
- -    command, is passed some input, and can early abort it
- -    if nothing needs to be done. It should run quickly and
- -    should not modify Annex state. -}
-type CommandStart = Annex (Maybe CommandPerform)
+{- d. The start stage is run before anything is output, is passed some
+ -    value from the seek stage, and can check if anything needs to be
+ -    done, and early abort if not. It should run quickly and should
+ -    not modify Annex state or output anything. -}
+type CommandStart = Annex (Maybe (StartMessage, CommandPerform))
 {- e. The perform stage is run after a message is printed about the command
  -    being run, and it should be where the bulk of the work happens. -}
 type CommandPerform = Annex (Maybe CommandCleanup)
@@ -37,6 +38,29 @@ type CommandPerform = Annex (Maybe CommandCleanup)
  -    returns the overall success/fail of the command. -}
 type CommandCleanup = Annex Bool
 
+{- Message that is displayed when starting to perform an action on
+ - something. The String is typically the name of the command or action
+ - being performed.
+ -}
+data StartMessage
+	= StartMessage String ActionItem
+	| StartUsualMessages String ActionItem
+	-- ^ Like StartMessage, but makes sure to enable usual message
+	-- display in case it was disabled by cmdnomessages.
+	| StartNoMessage ActionItem
+	-- ^ Starts, without displaying any message but also without
+	-- disabling display of any of the usual messages.
+	| CustomOutput ActionItem
+	-- ^ Prevents any start, end, or other usual messages from
+	-- being displayed, letting a command output its own custom format.
+	deriving (Show)
+
+instance MkActionItem StartMessage where
+	mkActionItem (StartMessage _ ai) = ai
+	mkActionItem (StartUsualMessages _ ai) = ai
+	mkActionItem (StartNoMessage ai) = ai
+	mkActionItem (CustomOutput ai) = ai
+
 {- A command is defined by specifying these things. -}
 data Command = Command
 	{ cmdcheck :: [CommandCheck] -- check stage

Types/Messages.hs

@@ -35,7 +35,6 @@ data MessageState = MessageState
 	{ outputType :: OutputType
 	, concurrentOutputEnabled :: Bool
 	, sideActionBlock :: SideActionBlock
-	, implicitMessages :: Bool
 	, consoleRegion :: Maybe ConsoleRegion
 	, consoleRegionErrFlag :: Bool
 	, jsonBuffer :: Maybe Aeson.Object
@@ -49,7 +48,6 @@ newMessageState = do
 		{ outputType = NormalOutput
 		, concurrentOutputEnabled = False
 		, sideActionBlock = NoBlock
-		, implicitMessages = True 
 		, consoleRegion = Nothing
 		, consoleRegionErrFlag = False
 		, jsonBuffer = Nothing

Types/WorkerPool.hs

@@ -7,8 +7,8 @@
 
 module Types.WorkerPool where
 
+import Control.Concurrent
 import Control.Concurrent.Async
-import Data.Either
 
 -- | Pool of worker threads. 
 data WorkerPool t
@@ -16,15 +16,65 @@ data WorkerPool t
 	| WorkerPool [Worker t]
 
 -- | A worker can either be idle or running an Async action.
-type Worker t = Either t (Async t)
+-- And it is used for some stage.
+data Worker t
+	= IdleWorker t WorkerStage
+	| ActiveWorker (Async t) WorkerStage
 
+-- | These correspond to CommandPerform and CommandCleanup.
+data WorkerStage = PerformStage | CleanupStage
+	deriving (Eq)
+
+workerStage :: Worker t -> WorkerStage
+workerStage (IdleWorker _ s) = s
+workerStage (ActiveWorker _ s) = s
+
+workerAsync :: Worker t -> Maybe (Async t)
+workerAsync (IdleWorker _ _) = Nothing
+workerAsync (ActiveWorker aid _) = Just aid
+
+-- | Allocates a WorkerPool that has the specified number of workers
+-- in it, of each stage.
+--
+-- The stages are distributed evenly throughout.
 allocateWorkerPool :: t -> Int -> WorkerPool t
-allocateWorkerPool t n = WorkerPool $ replicate n (Left t)
+allocateWorkerPool t n = WorkerPool $ take (n+n) $
+	map (uncurry IdleWorker) $ zip (repeat t) stages
+  where
+	stages = concat $ repeat [PerformStage, CleanupStage]
 
-addWorkerPool :: WorkerPool t -> Worker t -> WorkerPool t
-addWorkerPool (WorkerPool l) w = WorkerPool (w:l)
-addWorkerPool UnallocatedWorkerPool w = WorkerPool [w]
+addWorkerPool :: Worker t -> WorkerPool t -> WorkerPool t
+addWorkerPool w (WorkerPool l) = WorkerPool (w:l)
+addWorkerPool w UnallocatedWorkerPool = WorkerPool [w]
 
 idleWorkers :: WorkerPool t -> [t]
 idleWorkers UnallocatedWorkerPool = []
-idleWorkers (WorkerPool l) = lefts l
+idleWorkers (WorkerPool l) = go l
+  where
+	go [] = []
+	go (IdleWorker t _ : rest) = t : go rest
+	go (ActiveWorker _ _ : rest) = go rest
+
+-- | Removes a worker from the pool whose Async uses the ThreadId.
+--
+-- Each Async has its own ThreadId, so this stops once it finds
+-- a match.
+removeThreadIdWorkerPool :: ThreadId -> WorkerPool t -> Maybe ((Async t, WorkerStage), WorkerPool t)
+removeThreadIdWorkerPool _ UnallocatedWorkerPool = Nothing
+removeThreadIdWorkerPool tid (WorkerPool l) = go [] l
+  where
+	go _ [] = Nothing
+	go c (ActiveWorker a stage : rest)
+		| asyncThreadId a == tid = Just ((a, stage), WorkerPool (c++rest))
+	go c (v : rest) = go (v:c) rest
+
+deactivateWorker :: WorkerPool t -> Async t -> t -> WorkerPool t
+deactivateWorker UnallocatedWorkerPool _ _ = UnallocatedWorkerPool
+deactivateWorker (WorkerPool l) aid t = WorkerPool $ go l
+  where
+	go [] = []
+	go (w@(IdleWorker _ _) : rest) = w : go rest
+	go (w@(ActiveWorker a st) : rest)
+		| a == aid = IdleWorker t st : rest
+		| otherwise = w : go rest
+

doc/todo/parallel_possibilities.mdwn

@@ -21,19 +21,3 @@ are still some things that could be improved, tracked here:
   all that needs to be done is make checksum verification be done as the
   cleanup action. Currently, it's bundled into the same action that
   transfers content.
-
-* onlyActionOn collapses the cleanup action into the start action,
-  and so prevents use of the separate cleanup queue.
-
-* Don't parallelize start stage actions. They are supposed to run fast,
-  and often a huge number of them don't print out anything. The overhead of
-  bookkeeping for parallizing those swamps the benefit of parallelizing by
-  what seems to be a large degree. Compare `git annex get` in a directory
-  where the first several thousand files are already present with and
-  without -J.
-  
-  Only once the start stage has decided
-  something needs to be done should a job be started up.
-
-  This probably needs display of any output to be moved out of the start
-  stage, because no console region will be allocated for it.