summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex.hs8
-rw-r--r--Annex/Branch.hs1
-rw-r--r--Annex/Content.hs4
-rw-r--r--Annex/Queue.hs9
-rw-r--r--Messages.hs45
-rw-r--r--Option.hs10
-rw-r--r--Types/Messages.hs20
-rw-r--r--Upgrade/V1.hs2
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
)