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.

8 files changed, 72 insertions, 27 deletions

diff --git a/Annex.hs b/Annex.hs
index 2b58c2bd4..441e460be 100644
--- a/Annex.hs
+++ b/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
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index ce1dd58ce..706522f3b 100644
--- a/Annex/Branch.hs
+++ b/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
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 01ee7d83d..b5754e15b 100644
--- a/Annex/Content.hs
+++ b/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)
diff --git a/Annex/Queue.hs b/Annex/Queue.hs
index f49a22069..728e29645 100644
--- a/Annex/Queue.hs
+++ b/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'
 
diff --git a/Messages.hs b/Messages.hs
index af7eb88b4..4330f7c09 100644
--- a/Messages.hs
+++ b/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
diff --git a/Option.hs b/Option.hs
index 2f0d00744..769622055 100644
--- a/Option.hs
+++ b/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
diff --git a/Types/Messages.hs b/Types/Messages.hs
new file mode 100644
index 000000000..75653d574
--- /dev/null
+++ b/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
diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs
index a8005b264..ddf0728b6 100644
--- a/Upgrade/V1.hs
+++ b/Upgrade/V1.hs
@@ -59,7 +59,7 @@ upgrade = do
 			updateSymlinks
 			moveLocationLogs
 	
-			Annex.Queue.flush True
+			Annex.Queue.flush
 			setVersion
 		)