make CommandStart return a StartMessage

The goal is to be able to run CommandStart in the main thread when -J is
used, rather than unncessarily passing it off to a worker thread, which
incurs overhead that is signficant when the CommandStart is going to
quickly decide to stop.

To do that, the message it displays needs to be displayed in the worker
thread, after the CommandStart has run.

Also, the change will mean that CommandStart will no longer necessarily
run with the same Annex state as CommandPerform. While its docs already
said it should avoid modifying Annex state, I audited all the
CommandStart code as part of the conversion. (Note that CommandSeek
already sometimes runs with a different Annex state, and that has not been
a source of any problems, so I am not too worried that this change will
lead to breakage going forward.)

The only modification of Annex state I found was it calling
allowMessages in some Commands that default to noMessages. Dealt with
that by adding a startCustomOutput and a startingUsualMessages.
This lets a command start with noMessages and then select the output it
wants for each CommandStart.

One bit of breakage: onlyActionOn has been removed from commands that used it.
The plan is that, since a StartMessage contains an ActionItem,
when a Key can be extracted from that, the parallel job runner can
run onlyActionOn' automatically. Then commands won't need to worry about
this detail. Future work.

Otherwise, this was a fairly straightforward process of making each
CommandStart compile again. Hopefully other behavior changes were mostly
avoided.

In a few cases, a command had a CommandStart that called a CommandPerform
that then called showStart multiple times. I have collapsed those
down to a single start action. The main command to perhaps suffer from it
is Command.Direct, which used to show a start for each file, and no
longer does.

Another minor behavior change is that some commands used showStart
before, but had an associated file and a Key available, so were changed
to ShowStart with an ActionItemAssociatedFile. That will not change the
normal output or behavior, but --json output will now include the key.
This should not break it for anyone using a real json parser.

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
+			let ai = ActionItemOther (Just (fromImportLocation loc))
-				showStart ("import " ++ Remote.name remote) (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 $

CmdLine/Action.hs

@@ -196,17 +196,16 @@ callCommandAction' a = callCommandActionQuiet a >>= \case
 	Just r -> implicitMessage (showEndResult r) >> return (Just r)
 
 callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool)
-callCommandActionQuiet = start
+callCommandActionQuiet start =
-  where
+	start >>= \case
-	start   = stage $ maybe skip perform
+		Nothing -> return Nothing
-	perform = stage $ maybe failure $ \a -> do
+		Just (startmsg, perform) -> do
-		changeStageTo CleanupStage
+			showStartMessage startmsg
-		cleanup a
+			perform >>= \case
-	cleanup = stage $ status
+				Nothing -> return (Just False)
-	stage = (=<<)
+				Just cleanup -> do
-	skip = return Nothing
+					changeStageTo CleanupStage
-	failure = return (Just False)
+					Just <$> cleanup
-	status = return . Just
 
 {- Do concurrent output when that has been requested. -}
 allowConcurrentOutput :: Annex a -> Annex a
@@ -255,6 +254,7 @@ allowConcurrentOutput a = do
 
 {- 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
@@ -263,7 +263,10 @@ onlyActionOn k a = onlyActionOn' k run
 	run = callCommandActionQuiet a >>= \case
 		Nothing -> return Nothing
 		Just r' -> return $ Just $ return $ Just $ return r'
+-}
 
+{- Ensures that only one thread processes a key at a time.
+ - Other threads will block until it's done. -}
 onlyActionOn' :: Key -> Annex a -> Annex a
 onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
   where

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

@@ -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,25 @@ 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)
+
+{- For commands that do not display usual start or end messages, 
+ - but have some other custom output. -}
+startingCustomOutput :: CommandPerform -> CommandStart
+startingCustomOutput a = next (CustomOutput, 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
+startSmall file = starting "add" (ActionItemWorkTreeFile file) $
-	showStart "add" file
+	next $ addSmall file
-	next $ 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
+			| otherwise -> 
-				showStart "add" file
+				starting "add" (ActionItemWorkTreeFile file) $
-				next $ if isSymbolicLink s
+					if isSymbolicLink s
-					then next $ addFile file
+						then next $ addFile file
-					else perform 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
+	go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do
-		showStartAddUrl u o
 		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
+	startingAddUrl uri o $ do
-	showNote $ "from " ++ Remote.name r 
+		showNote $ "from " ++ Remote.name r 
-	showDestinationFile file'
+		showDestinationFile file'
-	next $ performRemote r o uri file' sz
+		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
+	go url = startingAddUrl urlstring o $ do
-		showStartAddUrl urlstring o
 		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 ()
+startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart
-showStartAddUrl url o = do
+startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do
-	showStart' "addurl" (Just url)
 	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
+	starting "adjust" (ActionItemOther Nothing) $
-	next $ next $ enterAdjustedBranch adj
+		next $ enterAdjustedBranch adj

Command/Commit.hs

@@ -20,10 +20,10 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = next $ next $ do
+start = starting "commit" (ActionItemOther (Just "git-annex")) $ do
-	Annex.Branch.commit =<< Annex.Branch.commitMessage
+		Annex.Branch.commit =<< Annex.Branch.commitMessage
-	_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
+		_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
-	return True
+		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
+seek (SetConfig name val) = commandAction $
-	allowMessages
+	startingUsualMessages name (ActionItemOther (Just val)) $ do
-	showStart' name (Just val)
-	next $ next $ do
 		setGlobalConfig name val
 		setConfig (ConfigKey name) val
-		return True
+		next $ return True
-seek (UnsetConfig name) = commandAction $ do
+seek (UnsetConfig name) = commandAction $
-	allowMessages
+	startingUsualMessages name (ActionItemOther (Just "unset")) $do
-	showStart' name (Just "unset")
-	next $ next $ do
 		unsetGlobalConfig name
 		unsetConfig (ConfigKey name)
-		return True
+		next $ return True
 seek (GetConfig name) = commandAction $
-	getGlobalConfig name >>= \case
+	startingCustomOutput $ do
-		Nothing -> stop
+		getGlobalConfig name >>= \case
-		Just v -> do
+			Nothing -> return ()
-			liftIO $ putStrLn v
+			Just v -> liftIO $ putStrLn v
-			stop
+		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
+startKey key = starting "dead" (mkActionItem key) $
-	showStart' "dead" (Just $ serializeKey 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
+			Just a -> tryNonAsync a >>= \case
-				showStart "direct" f
+				Left e -> warnlocked f e
-				tryNonAsync a >>= \case
+				Right _ -> return ()
-					Left e -> warnlocked e
-					Right _ -> showEndOk
 		return Nothing
 
-	warnlocked :: SomeException -> Annex ()
+	warnlocked :: FilePath -> SomeException -> Annex ()
-	warnlocked e = do
+	warnlocked f e = do
-		warning $ show e
+		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
+startLocal afile ai numcopies key preverified =
-	showStartKey "drop" key ai
+	stopUnless (inAnnex key) $
-	next $ performLocal key afile numcopies preverified
+		starting "drop" ai $
+			performLocal key afile numcopies preverified
 
 startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart
-startRemote afile ai numcopies key remote = do
+startRemote afile ai numcopies key remote = 
-	showStartKey ("drop " ++ Remote.name remote) key ai
+	starting ("drop " ++ Remote.name remote) ai $
-	next $ performRemote key afile numcopies remote
+		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
+start key = starting "dropkey" (mkActionItem key) $
-	showStartKey "dropkey" key (mkActionItem key)
+	perform key
-	next $ 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
+	| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do
-		showStart' "enableremote" (Just name)
+		setRemoteIgnore r False
-		next $ next $ do
+		r' <- Remote.Git.configRead False r
-			setRemoteIgnore r False
+		u <- getRepoUUID r'
-			r' <- Remote.Git.configRead False r
+		next $ return $ u /= NoUUID
-			u <- getRepoUUID r'
-			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
+startSpecialRemote name config (Just (u, c)) =
-	let fullconfig = config `M.union` c	
+	starting "enableremote" (ActionItemOther (Just name)) $ do
-	t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
+		let fullconfig = config `M.union` c	
-	showStart' "enableremote" (Just name)
+		t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
-	gc <- maybe (liftIO dummyRemoteGitConfig) 
+		gc <- maybe (liftIO dummyRemoteGitConfig) 
-		(return . Remote.gitconfig)
+			(return . Remote.gitconfig)
-		=<< Remote.byUUID u
+			=<< Remote.byUUID u
-	next $ performSpecialRemote t u c fullconfig gc
+		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
+		else starting "enable-tor" (ActionItemOther Nothing) $ do
-			showStart' "enable-tor" Nothing
 			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
+		Just ent | notexpired ent -> checktrust (== DeadTrusted) $
-			showStart' "unexpire" (Just desc)
+			starting "unexpire" (ActionItemOther (Just desc)) $ do
-			showNote =<< whenactive
+				showNote =<< whenactive
-			unless noact $
+				unless noact $
-				trustSet u SemiTrusted
+					trustSet u SemiTrusted
-		_ -> checktrust (/= DeadTrusted) $ do
+				next $ return True
-			showStart' "expire" (Just desc)
+		_ -> checktrust (/= DeadTrusted) $
-			showNote =<< whenactive
+			starting "expire" (ActionItemOther (Just desc)) $ do
-			unless noact $
+				showNote =<< whenactive
-				trustSet u DeadTrusted
+				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)
+	checktrust want = stopUnless (want <$> lookupTrust u)
-		( do
-			void a
-			next $ next $ return True
-		, stop
-		)
 
 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
+	stopUnless (notrecordedpresent ek) $
-		showStart ("export " ++ name r) f
+		starting ("export " ++ name r) (ActionItemOther (Just f)) $
-		ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
+			ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
-			( next $ next $ cleanupExport r db ek loc False
+				( next $ cleanupExport r db ek loc False
-			, do
+				, do
-				liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
+					liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))
-				next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar
+					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
+		else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
-			showStart ("unexport " ++ name r) f'
+			performUnexport r db eks loc
-			next $ performUnexport r db eks loc
   where
 	loc = mkExportLocation f'
 	f' = getTopFilePath f
 
 startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startUnexport' r db f ek = do
+startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $
-	showStart ("unexport " ++ name r) f'
+	performUnexport r db [ek] loc
-	next $ 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)
+		starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do
-		liftIO $ removeExportedLocation db (asKey ek) oldloc
+			liftIO $ removeExportedLocation db (asKey ek) oldloc
-		next $ performUnexport r db [ek] loc
+			performUnexport r db [ek] loc
   where
 	oldloc = mkExportLocation oldf'
 	oldf' = getTopFilePath oldf
 
 startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
-startMoveToTempName r db f ek = do
+startMoveToTempName r db f ek = starting ("rename " ++ name r) 
-	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
+	(ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc)
-	next $ performRename r db ek loc 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
+	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
-		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
+		starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $
-		next $ performRename r db ek tmploc loc
+			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)
+start o file key =
-	( do
+	stopUnless (limited <||> inAnnex key) $
-		showFormatted (formatOption o) file $ ("file", file) : keyVars key
+		startingCustomOutput $ do
-		next $ next $ return True
+			showFormatted (formatOption o) file $ ("file", file) : keyVars key
-	, stop
+			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
+	fixby = starting "fix" (mkActionItem (key, file))
-		showStart "fix" file
-		next a
 	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
+start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do
-	showStart' "forget" (Just "git-annex")
 	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
+	go file key = starting "fromkey" (mkActionItem (key, file)) $
-		showStart "fromkey" file
+		perform key file
-		next $ 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
+	starting "fromkey" (mkActionItem (key, file)) $
-	next $ perform 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)
+runFsck inc ai key a = stopUnless (needFsck inc key) $
-	( do
+	starting "fsck" ai $ do
-		showStartKey "fsck" key ai
+		ok <- a
-		next $ do
+		when ok $
-			ok <- a
+			recordFsckTime inc key
-			when ok $
+		next $ return ok
-				recordFsckTime inc key
-			next $ return ok
-	, stop
-	)
 
 {- 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
+	go = starting "get" ai
-		showStartKey "get" key ai
-		next a
 
 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
+	startingCustomOutput $ do
-	stop
+		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:[]) = startingCustomOutput $
-start (g:expr:[]) = do
+	performGet groupPreferredContentMapRaw (toGroup g)
-	allowMessages
+start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $
-	showStart' "groupwanted" (Just g)
+	performSet groupPreferredContentSet expr (toGroup g)
-	next $ 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
+		( starting "import" (ActionItemWorkTreeFile destfile)
-			showStart "import" destfile
+			pickaction
-			next pickaction
 		, stop
 		)
   where
@@ -289,9 +288,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
+listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $
-	showStart' "list" (Just (Remote.name remote))
+	listImportableContents remote >>= \case
-	next $ listImportableContents remote >>= \case
 		Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
 		Just importable -> do
 			importable' <- makeImportMatcher remote >>= \case
@@ -302,9 +300,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
+commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =
-	showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb)
+	starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do
-	next $ 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
+getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek
-start opts cache url = do
+getFeed opts cache url = do
-	showStart' "importfeed" (Just url)
+	showStart "importfeed" url
-	next $ perform opts cache url
+	downloadFeed url >>= \case
-
+		Nothing -> showEndResult =<< feedProblem url
-perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform
+			"downloading the feed failed"
-perform opts cache url = go =<< downloadFeed url
+		Just feedcontent -> case parseFeedString feedcontent of
-  where
+			Nothing -> showEndResult =<< feedProblem url
-	go Nothing = next $ feedProblem url "downloading the feed failed"
+				"parsing the feed failed"
-	go (Just feedcontent) = case parseFeedString feedcontent of
+			Just f -> case findDownloads url f of
-		Nothing -> next $ feedProblem url "parsing the feed failed"
+				[] -> showEndResult =<< feedProblem url
-		Just f -> case findDownloads url f of
+					"bad feed content; no enclosures to download"
-			[] -> next $
+				l -> do
-				feedProblem url "bad feed content; no enclosures to download"
+					showEndOk
-			l -> do
+					ifM (and <$> mapM (performDownload opts cache) l)
-				showOutput
+						( clearFeedProblem url
-				ok <- and <$> mapM (performDownload opts cache) l
+						, void $ feedProblem url 
-				next $ cleanup url ok
+							"problem downloading some item(s) from feed"
-
+						)
-cleanup :: URLString -> Bool -> CommandCleanup
-cleanup url True = do
-	clearFeedProblem url
-	return True
-cleanup url False = 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
+start os = starting "init" (ActionItemOther (Just $ initDesc os)) $
-	showStart' "init" (Just $ initDesc os)
+	perform os
-	next $ 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)
-
+				starting "initremote" (ActionItemOther (Just name)) $
-				showStart' "initremote" (Just name)
+					perform t name $ M.union config c
-				next $ 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 $ do
 	tmpf <- fromRepo $ gitAnnexTmpObjectLocation k
-	ifM (liftIO $ doesFileExist tmpf)
+	whenM (liftIO $ doesFileExist tmpf) $
-		( next $ next $ do
+		liftIO $ putStrLn tmpf
-			liftIO $ putStrLn tmpf
+	next $ return True
-			return True
-		, notInprogress
-		)
-
-notInprogress :: CommandStart
-notInprogress = stop

Command/Lock.hs

@@ -41,8 +41,7 @@ seek ps = do
 startNew :: FilePath -> Key -> CommandStart
 startNew file key = ifM (isJust <$> isAnnexLink file)
 	( stop
-	, do
+	, starting "lock" (mkActionItem (key, file)) $
-		showStart "lock" 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 = starting "map" (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
+mergeBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do
-	showStart' "merge" (Just "git-annex")
+	Annex.Branch.update
-	next $ do
+	-- commit explicitly, in case no remote branches were merged
-		Annex.Branch.update
+	Annex.Branch.commit =<< Annex.Branch.commitMessage
-		-- commit explicitly, in case no remote branches were merged
+	next $ return True
-		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 $ do
 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
 		liftIO $ forM_ l $
 			B8.putStrLn . fromMetaValue
-		stop
+		next $ return True
-	_ -> do
+	_ -> starting "metadata" ai $
-		showStartKey "metadata" k ai
+		perform c o k
-		next $ 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
+	go k ai = starting "metadata" ai $ do
-		showStartKey "metadata" k ai
 		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
+				then starting "migrate" (mkActionItem (key, file)) $
-					showStart "migrate" file
+					perform file key oldbackend newbackend
-					next $ 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 ()
+describeMoveAction :: RemoveWhen -> String
-showMoveAction RemoveNever = showStartKey "copy"
+describeMoveAction RemoveNever = "copy"
-showMoveAction _ = showStartKey "move"
+describeMoveAction _ = "move"
 
 toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
 toStart removewhen afile key ai dest = do
@@ -108,9 +108,8 @@ toStart' dest removewhen afile key ai = do
 			)
 		else go False (Remote.hasKey dest key)
   where
-	go fastcheck isthere = do
+	go fastcheck isthere = starting (describeMoveAction removewhen) ai $
-		showMoveAction removewhen key ai
+		toPerform dest removewhen key afile fastcheck =<< isthere
-		next $ toPerform dest removewhen key afile fastcheck =<< isthere
 
 expectedPresent :: Remote -> Key -> Annex Bool
 expectedPresent dest key = do
@@ -182,9 +181,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
+	go = stopUnless (fromOk src key) $
-		showMoveAction removewhen key ai
+		starting (describeMoveAction removewhen) ai $
-		next $ fromPerform src removewhen key afile
+			fromPerform src removewhen key afile
 
 fromOk :: Remote -> Key -> Annex Bool
 fromOk src key 
@@ -250,9 +249,9 @@ toHereStart removewhen afile key ai = case removewhen of
 	go = do
 		rs <- Remote.keyPossibilities key
 		forM_ rs $ \r ->
-			includeCommandAction $ do
+			includeCommandAction $
-				showMoveAction removewhen key ai
+				starting (describeMoveAction removewhen) ai $
-				next $ fromPerform r removewhen key afile
+					fromPerform r removewhen key afile
 		stop
 
 {- The goal of this command is to allow the user maximum freedom to move

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
+genAddress = starting "gen-address" (ActionItemOther Nothing) $ do
-	showStart' "gen-address" Nothing
 	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."
+	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
 			
-	showStart' "generating file list" Nothing
+			serverkey <- uftpKey
-	fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs
+			u <- getUUID
-	matcher <- Limit.getMatcher
+			withAuthList $ \authlist -> do
-	let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
+				let ps =
-		liftIO $ hPutStrLn h o
+					-- Force client authentication.
-	forM_ fs' $ \f -> do
+					[ Param "-c"
-		mk <- lookupFile f
+					, Param "-Y", Param "aes256-cbc"
-		case mk of
+					, Param "-h", Param "sha512"
-			Nothing -> noop
+					-- Picked ecdh_ecdsa for perfect forward secrecy,
-			Just k -> withObjectLoc k (addlist f) (const noop)
+					-- and because a EC key exchange algorithm is
-	liftIO $ hClose h
+					-- needed since all keys are EC.
-	showEndOk
+					, Param "-e", Param "ecdh_ecdsa"
-
+					, Param "-k", uftpKeyParam serverkey
-	showStart' "sending files" Nothing
+					, Param "-U", Param (uftpUID u)
-	showOutput
+					-- only allow clients on the authlist
-	serverkey <- uftpKey
+					, Param "-H", Param ("@"++authlist)
-	u <- getUUID
+					-- pass in list of files to send
-	withAuthList $ \authlist -> do
+					, Param "-i", File t
-		let ps =
+					] ++ ups
-			-- Force client authentication.
+				liftIO (boolSystem "uftp" ps) >>= showEndResult
-			[ Param "-c"
+			next $ return True
-			, 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
 
 receive :: [CommandParam] -> CommandStart
-receive ups = do
+receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do
-	showStart' "receiving multicast files" Nothing
 	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 $ 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
+startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do
-	allowMessages
+	setGlobalNumCopies $ NumCopies n
-	showStart' "numcopies" (Just $ show n)
+	next $ return True
-	next $ next $ do
-		setGlobalNumCopies $ NumCopies n
-		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
+linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $
-	showStart' "p2p link" (Just remotename)
+	next promptaddr
-	next $ 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
+startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)
-	showStart' "p2p pair" (Just remotename)
+	( starting "p2p pair" (ActionItemOther (Just remotename)) $
-	ifM (liftIO Wormhole.isInstalled)
+		performPairing remotename addrs
-		( 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/"
-		, 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 $ 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,21 @@ seek ps = lockPreCommitHook $ ifM isDirect
 	
 
 startInjectUnlocked :: FilePath -> CommandStart
-startInjectUnlocked f = next $ do
+startInjectUnlocked f = startingCustomOutput $ 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 $ next preCommitDirect
 
 addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
-addViewMetaData v f k = do
+addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
-	showStart "metadata" f
+	next $ changeMetaData k $ fromView v f
-	next $ next $ changeMetaData k $ fromView v f
 
 removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
-removeViewMetaData v f k = do
+removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $
-	showStart "metadata" f
+	next $ changeMetaData k $ unsetMetaData $ fromView v f
-	next $ 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
+		| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $
-			showStart "rekey" file
+			perform file oldkey newkey
-			next $ 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
+start (keyname:url:[]) = 
-	let key = mkKey keyname
+	starting "registerurl" (ActionItemOther (Just url)) $ do
-	showStart' "registerurl" (Just url)
+		let key = mkKey keyname
-	next $ perform key url
+		perform key url
 start _ = giveup "specify a key and an url"
 
 startMass :: BatchFormat -> CommandStart
-startMass fmt = do
+startMass fmt = 
-	showStart' "registerurl" (Just "stdin")
+	starting "registerurl" (ActionItemOther (Just "stdin")) $
-	next (massAdd fmt)
+		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
+start ws = starting "reinit" (ActionItemOther (Just s)) $
-	showStart' "reinit" (Just s)
+	perform s
-	next $ 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
+	| otherwise = notAnnexed src $ ifAnnexed dest go stop
-		showStart "reinject" dest
-		next $ ifAnnexed dest go stop
   where
-	go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
+	go key = starting "reinject" (ActionItemOther (Just src)) $
-		( perform src key
+		ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
-		, giveup $ src ++ " does not have expected content of " ++ dest
+			( 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
+startKnown src = notAnnexed src $
-	showStart "reinject" src
+	starting "reinject" (ActionItemOther (Just src)) $ do
-	mkb <- genKey (KeySource src src Nothing) Nothing
+		mkb <- genKey (KeySource src src Nothing) Nothing
-	case mkb of
+		case mkb of
-		Nothing -> error "Failed to generate key"
+			Nothing -> error "Failed to generate key"
-		Just (key, _) -> ifM (isKnownKey key)
+			Just (key, _) -> ifM (isKnownKey key)
-			( next $ perform src key
+				( perform src key
-			, do
+				, do
-				warning "Not known content; skipping"
+					warning "Not known content; skipping"
-				next $ next $ return True
+					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
+	go u cfg = starting "rename" (ActionItemOther Nothing) $
-		showStart' "rename" Nothing
+		perform u cfg newname
-		next $ 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
+start = starting "resolvemerge" (ActionItemOther Nothing) $ do
-	showStart' "resolvemerge" Nothing
 	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
+start (file, url) = flip whenAnnexed file $ \_ key ->
-	showStart "rmurl" file
+	starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $
-	next $ next $ cleanup url key
+		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:[]) = do
-	parse (name:expr:[]) = go name $ \uuid -> do
-		allowMessages
-		showStart' "schedule" (Just name)
-		performSet expr uuid
-	parse _ = giveup "Specify a repository."
-
-	go name a = do
 		u <- Remote.nameToUUID name
-		next $ a u
+		startingCustomOutput $
+			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
+start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $
-	showStart "setkey" file
+	perform file (mkKey keyname)
-	next $ 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
+start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $
-	showStartKey "setpresentkey" k (mkActionItem k)
+	perform k u s
-	next $ 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
+	needMerge currbranch >>= \case
-  where
+		Nothing -> stop
-	go Nothing = stop
+		Just syncbranch ->
-	go (Just syncbranch) = do
+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $
-		showStart' "merge" (Just $ Git.Ref.describe syncbranch)
+				next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
-		next $ next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch
 mergeLocal _ _ (Nothing, madj) = do
 	b <- inRepo Git.Branch.currentUnsafe
-	ifM (isJust <$> needMerge (b, madj))
+	needMerge (b, madj) >>= \case
-		( do
+		Nothing -> stop
-			warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."
+		Just syncbranch ->
-			next $ next $ return False
+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do
-		, stop
+				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
+pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $
-	showStart' "pull" (Just (Remote.name remote))
+	starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do
-	next $ do
 		showOutput
-		stopUnless fetch $
+		ifM fetch
-			next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)
+			( 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
+pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $
-	showStart' "push" (Just (Remote.name remote))
+	starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
-	next $ next $ do
 		repo <- Remote.getRepo remote
 		showOutput
 		ok <- inRepoWithSshOptionsTo repo gc $
@@ -689,9 +687,8 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
 		( return [ get have ]
 		, return []
 		)
-	get have = includeCommandAction $ do
+	get have = includeCommandAction $ starting "get" ai $
-		showStartKey "get" k ai
+		next $ getKey' k af have
-		next $ next $ getKey' k af have
 
 	wantput r
 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
@@ -764,24 +761,23 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
 
 cleanupLocal :: CurrBranch -> CommandStart
 cleanupLocal (Nothing, _) = stop
-cleanupLocal (Just currb, _) = do
+cleanupLocal (Just currb, _) = 
-	showStart' "cleanup" (Just "local")
+	starting "cleanup" (ActionItemOther (Just "local")) $ 
-	next $ next $ do
+		next $ do
-		delbranch $ syncBranch currb
+			delbranch $ syncBranch currb
-		delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
+			delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
-		mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
+			mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
-			=<< listTaggedBranches
+				=<< listTaggedBranches
-		return True
+			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
+cleanupRemote remote (Just b, _) =
-	showStart' "cleanup" (Just (Remote.name remote))
+	starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $
-	next $ next $
+		next $ inRepo $ Git.Command.runBool
-		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
+start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
-	showStart' "testremote" (Just (testRemote o))
 	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
+start o key = startingCustomOutput $ case fromToOptions o of
-	ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest
+	ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest
-	FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src
+	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
+start file key = stopUnless (inAnnex key) $
-	showStart "unannex" file
+	starting "unannex" (mkActionItem (key, file)) $
-	next $ ifM isDirect
+		ifM isDirect
-		( performDirect file key
+			( performDirect file key
-		, performIndirect 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
+start p = starting "undo" (ActionItemOther (Just p)) $
-	showStart "undo" p
+	perform p
-	next $ 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
+	( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $
-		showStart "unlock" file
 		ifM versionSupportsUnlockedPointers
-			( next $ performNew file key
+			( performNew file key
-			, startOld 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
+performOld :: FilePath -> Key -> CommandPerform
-startOld file key = 
+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' :: FilePath -> Key -> CommandPerform
-performOld dest key = ifM (checkDiskSpace Nothing key 0 True)
+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)
+	starting "unused" (ActionItemOther (Just name)) perform
-	next 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
+			Just key -> starting message
-				showStart' message (Just $ show n)
+				(ActionItemOther $ Just $ show n)
-				next $ a key
+				(a key)

Command/Upgrade.hs

@@ -22,9 +22,8 @@ seek :: CmdParams -> CommandSeek
 seek = withNothing (commandAction start)
 
 start :: CommandStart
-start = do
+start = starting "upgrade" (ActionItemOther Nothing) $ do
-	showStart' "upgrade" Nothing
 	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
+start params = starting "vadd" (ActionItemOther Nothing) $ 
-	showStart' "vadd" Nothing
 	withCurrentView $ \view -> do
 		let (view', change) = refineView view $
 			map parseViewParam $ reverse params
 		case change of
 			Unchanged -> do
 				showNote "unchanged"
-				next $ next $ return True
+				next $ return True
-			Narrowing -> next $ next $ do
+			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
+	go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do
-		showStart' "vcycle" Nothing
 		let v' = v { viewComponents = vcycle [] (viewComponents v) }
 		if v == v'
 			then do
 				showNote "unchanged"
-				next $ next $ return True
+				next $ return True
-			else next $ next $ checkoutViewBranch v' narrowView
+			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
+start params = starting "vfilter" (ActionItemOther Nothing) $
-	showStart' "vfilter" 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
+	go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do
-		showStart' "vpop" (Just $ show num)
 		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
+start ps = ifM safeToEnterView
-	showStart' "view" Nothing
+	( do
-	ifM safeToEnterView
+		view <- mkView ps
-		( do
+		go view  =<< currentView
-			view <- mkView ps
+	, giveup "Not safe to enter view."
-			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:[]) = do
-	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
 		u <- Remote.nameToUUID rname
-		next $ a u
+		startingCustomOutput $
+			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
+startKeys remotemap (key, ai) = starting "whereis" ai $ perform remotemap key
-	showStartKey "whereis" key ai
-	next $ perform remotemap key
 
 perform :: M.Map UUID Remote -> Key -> CommandPerform
 perform remotemap key = do

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,9 @@
 module Messages (
 	showStart,
 	showStart',
-	showStartKey,
+	showStartMessage,
-	ActionItem,
+	StartMessage(..),
+	ActionItem(..),
 	mkActionItem,
 	showNote,
 	showAction,
@@ -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,26 @@ 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
+showStartMessage (StartUsualMessages command ai) = do
+	outputType <$> Annex.getState Annex.output >>= \case
+		QuietOutput -> Annex.setOutput NormalOutput
+		_ -> noop
+	Annex.changeState $ \s -> s
+		{ Annex.output = (Annex.output s) { implicitMessages = True } }
+	showStartMessage (StartMessage command ai)
+showStartMessage CustomOutput = do
+	Annex.setOutput QuietOutput
+	Annex.changeState $ \s -> s
+		{ Annex.output = (Annex.output s) { implicitMessages = False } }
+
 showNote :: String -> Annex ()
 showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") "
 

Types/ActionItem.hs

@@ -13,21 +13,34 @@ 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)
 
 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,20 +52,26 @@ 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
 
-actionItemKey :: ActionItem -> Key
+actionItemKey :: ActionItem -> Maybe Key
-actionItemKey (ActionItemAssociatedFile _ k) = k
+actionItemKey (ActionItemAssociatedFile _ k) = Just k
-actionItemKey (ActionItemKey k) = k
+actionItemKey (ActionItemKey k) = Just k
-actionItemKey (ActionItemBranchFilePath _ k) = k
+actionItemKey (ActionItemBranchFilePath _ k) = Just k
-actionItemKey (ActionItemFailedTransfer t _) = transferKey t
+actionItemKey (ActionItemFailedTransfer t _) = Just (transferKey t)
+actionItemKey (ActionItemWorkTreeFile _) = Nothing
+actionItemKey (ActionItemOther _) = Nothing
 
 actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
 actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
+actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f
 actionItemWorkTreeFile _ = Nothing
 
 actionItemTransferDirection :: ActionItem -> Maybe Direction

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
+{- d. The start stage is run before anything is output, is passed some
- -    command, is passed some input, and can early abort it
+ -    value from the seek stage, and can check if anything needs to be
- -    if nothing needs to be done. It should run quickly and
+ -    done, and early abort if not. It should run quickly and should
- -    should not modify Annex state. -}
+ -    not modify Annex state or output anything. -}
-type CommandStart = Annex (Maybe CommandPerform)
+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,18 @@ 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.
+ -
+ - CustomOutput prevents any start, end, or other implicit messages from
+ - being displayed, letting a command output its own custom format.
+ -}
+data StartMessage
+	= StartMessage String ActionItem
+	| StartUsualMessages String ActionItem
+	| CustomOutput
+
 {- A command is defined by specifying these things. -}
 data Command = Command
 	{ cmdcheck :: [CommandCheck] -- check stage