diff options
| -rw-r--r-- | Annex.hs | 8 | ||||
| -rw-r--r-- | Annex/Branch.hs | 1 | ||||
| -rw-r--r-- | Annex/Content.hs | 4 | ||||
| -rw-r--r-- | Annex/Queue.hs | 9 | ||||
| -rw-r--r-- | Messages.hs | 45 | ||||
| -rw-r--r-- | Option.hs | 10 | ||||
| -rw-r--r-- | Types/Messages.hs | 20 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 2 |
8 files changed, 72 insertions, 27 deletions
@@ -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 @@ -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 ) |