display "Recording state in git..." when staging the journal

A bit tricky to avoid printing it twice in a row when there are queued git
commands to run and journal to stage.

Added a generic way to run an action that may output multiple side
messages, with only the first displayed.

Annex.hs

@@ -10,7 +10,6 @@
 module Annex (
 	Annex,
 	AnnexState(..),
-	OutputType(..),
 	new,
 	newState,
 	run,
@@ -44,6 +43,7 @@ import qualified Types.Remote
 import Types.Crypto
 import Types.BranchState
 import Types.TrustLevel
+import Types.Messages
 import Utility.State
 import qualified Utility.Matcher
 import qualified Data.Map as M
@@ -69,8 +69,6 @@ instance MonadBaseControl IO Annex where
 		where
 			unStAnnex (StAnnex st) = st
 
-data OutputType = NormalOutput | QuietOutput | JSONOutput
-
 type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
 
 -- internal state storage
@@ -78,7 +76,7 @@ data AnnexState = AnnexState
 	{ repo :: Git.Repo
 	, backends :: [BackendA Annex]
 	, remotes :: [Types.Remote.RemoteA Annex]
-	, output :: OutputType
+	, output :: MessageState
 	, force :: Bool
 	, fast :: Bool
 	, auto :: Bool
@@ -104,7 +102,7 @@ newState gitrepo = AnnexState
 	{ repo = gitrepo
 	, backends = []
 	, remotes = []
-	, output = NormalOutput
+	, output = defaultMessageState
 	, force = False
 	, fast = False
 	, auto = False

Annex/Branch.hs

@@ -330,6 +330,7 @@ setCommitted = void $ do
 {- Stages the journal into the index. -}
 stageJournal :: Annex ()
 stageJournal = do
+	showStoringStateAction
 	fs <- getJournalFiles
 	g <- gitRepo
 	withIndex $ liftIO $ do

Annex/Content.hs

@@ -297,8 +297,8 @@ getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
  - especially if performing a short-lived action.
  -}
 saveState :: Bool -> Annex ()
-saveState oneshot = do
-	Annex.Queue.flush False
+saveState oneshot = doSideAction $ do
+	Annex.Queue.flush
 	unless oneshot $
 		ifM alwayscommit
 			( Annex.Branch.commit "update" , Annex.Branch.stage)

Annex/Queue.hs

@@ -26,15 +26,14 @@ add command params files = do
 flushWhenFull :: Annex ()
 flushWhenFull = do
 	q <- get
-	when (Git.Queue.full q) $ flush False
+	when (Git.Queue.full q) flush
 
 {- Runs (and empties) the queue. -}
-flush :: Bool -> Annex ()
-flush silent = do
+flush :: Annex ()
+flush = do
 	q <- get
 	unless (0 == Git.Queue.size q) $ do
-		unless silent $
-			showSideAction "Recording state in git"
+		showStoringStateAction
 		q' <- inRepo $ Git.Queue.flush q
 		store q'
 

Messages.hs

@@ -13,6 +13,8 @@ module Messages (
 	metered,
 	MeterUpdate,
 	showSideAction,
+	doSideAction,
+	showStoringStateAction,
 	showOutput,
 	showLongNote,
 	showEndOk,
@@ -37,6 +39,7 @@ import Data.Quantity
 
 import Common
 import Types
+import Types.Messages
 import Types.Key
 import qualified Annex
 import qualified Messages.JSON as JSON
@@ -61,9 +64,9 @@ showProgress = handle q $
  - The action is passed a callback to use to update the meter. -}
 type MeterUpdate = Integer -> IO ()
 metered :: Key -> (MeterUpdate -> Annex a) -> Annex a
-metered key a = Annex.getState Annex.output >>= go (keySize key)
+metered key a = withOutputType $ go (keySize key)
 	where
-		go (Just size) Annex.NormalOutput = do
+		go (Just size) NormalOutput = do
 			progress <- liftIO $ newProgress "" size
 			meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
 			showOutput
@@ -76,8 +79,27 @@ metered key a = Annex.getState Annex.output >>= go (keySize key)
                 go _ _ = a (const noop)
 
 showSideAction :: String -> Annex ()
-showSideAction s = handle q $
-	putStrLn $ "(" ++ s ++ "...)"
+showSideAction m = Annex.getState Annex.output >>= go
+	where
+		go (MessageState v StartBlock) = do
+			p
+	 		Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
+		go (MessageState _ InBlock) = return ()
+		go _ = p
+		p = handle q $ putStrLn $ "(" ++ m ++ "...)"
+			
+showStoringStateAction :: Annex ()
+showStoringStateAction = showSideAction "Recording state in git"
+
+{- Performs an action, that may call showSideAction multiple times.
+ - Only the first will be displayed. -}
+doSideAction :: Annex a -> Annex a
+doSideAction a = do
+	o <- Annex.getState Annex.output
+	set $ o { sideActionBlock = StartBlock }
+	set o `after` a
+	where
+		set o = Annex.changeState $ \s -> s {  Annex.output = o }
 
 showOutput :: Annex ()
 showOutput = handle q $
@@ -122,9 +144,9 @@ maybeShowJSON v = handle (JSON.add v) q
 
 {- Shows a complete JSON value, only when in json mode. -}
 showFullJSON :: JSON a => [(String, a)] -> Annex Bool
-showFullJSON v = Annex.getState Annex.output >>= liftIO . go
+showFullJSON v = withOutputType $ liftIO . go
 	where
-		go Annex.JSONOutput = JSON.complete v >> return True
+		go JSONOutput = JSON.complete v >> return True
 		go _ = return False
 
 {- Performs an action that outputs nonstandard/customized output, and
@@ -153,14 +175,17 @@ setupConsole = do
 	fileEncoding stderr
 
 handle :: IO () -> IO () -> Annex ()
-handle json normal = Annex.getState Annex.output >>= go
+handle json normal = withOutputType $ go
 	where
-		go Annex.NormalOutput = liftIO normal
-		go Annex.QuietOutput = q
-		go Annex.JSONOutput = liftIO $ flushed json
+		go NormalOutput = liftIO normal
+		go QuietOutput = q
+		go JSONOutput = liftIO $ flushed json
 
 q :: Monad m => m ()
 q = noop
 
 flushed :: IO () -> IO ()
 flushed a = a >> hFlush stdout
+
+withOutputType :: (OutputType -> Annex a) -> Annex a
+withOutputType a = outputType <$> Annex.getState Annex.output >>= a

Option.hs

@@ -20,6 +20,7 @@ import System.Log.Logger
 
 import Common.Annex
 import qualified Annex
+import Types.Messages
 import Limit
 import Usage
 
@@ -31,11 +32,11 @@ common =
 		"avoid slow operations"
 	, Option ['a'] ["auto"] (NoArg (setauto True))
 		"automatic mode"
-	, Option ['q'] ["quiet"] (NoArg (setoutput Annex.QuietOutput))
+	, Option ['q'] ["quiet"] (NoArg (setoutput QuietOutput))
 		"avoid verbose output"
-	, Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput))
+	, Option ['v'] ["verbose"] (NoArg (setoutput NormalOutput))
 		"allow verbose output (default)"
-	, Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput))
+	, Option ['j'] ["json"] (NoArg (setoutput JSONOutput))
 		"enable JSON output"
 	, Option ['d'] ["debug"] (NoArg setdebug)
 		"show debug messages"
@@ -46,7 +47,8 @@ common =
 		setforce v = Annex.changeState $ \s -> s { Annex.force = v }
 		setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
 		setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
-		setoutput v = Annex.changeState $ \s -> s { Annex.output = v }
+		setoutput v = Annex.changeState $ \s ->
+			s { Annex.output = (Annex.output s) { outputType = v } }
 		setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
 		setdebug = liftIO $ updateGlobalLogger rootLoggerName $
 			setLevel DEBUG

Types/Messages.hs

@@ -0,0 +1,20 @@
+{- git-annex Messages data types
+ - 
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Messages where
+
+data OutputType = NormalOutput | QuietOutput | JSONOutput
+
+data SideActionBlock = NoBlock | StartBlock | InBlock
+
+data MessageState = MessageState
+	{ outputType :: OutputType
+	, sideActionBlock :: SideActionBlock
+	}
+
+defaultMessageState :: MessageState
+defaultMessageState = MessageState NormalOutput NoBlock

Upgrade/V1.hs

@@ -59,7 +59,7 @@ upgrade = do
 			updateSymlinks
 			moveLocationLogs
 	
-			Annex.Queue.flush True
+			Annex.Queue.flush
 			setVersion
 		)