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.
This commit is contained in:
Joey Hess 2012-04-27 13:23:52 -04:00
parent e0b7012ccc
commit 76102c1c75
8 changed files with 72 additions and 27 deletions

View file

@ -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