From c0c595345cfd094bd4d80afca158cbec2bbadf28 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Nov 2015 16:19:00 -0400 Subject: [PATCH] arrange for regional output manager to run when -J is enabled Commands that want to use it have to run their seek action inside allowConcurrentOutput. Which seems reasonable; perhaps some future command will want to support the -J flag but not use regions. The region state moved from Annex to MessageState. This makes sense organizationally, and note that some uses of onLocal use a different Annex state, but pass the MessageState into it, which is what is needed. --- Annex.hs | 13 ++---------- CmdLine.hs | 6 ++---- CmdLine/Action.hs | 3 ++- CmdLine/GitAnnex/Options.hs | 6 +++++- Command.hs | 2 ++ Command/Get.hs | 2 +- Command/Mirror.hs | 9 +++++---- Command/Move.hs | 9 +++++---- Command/Sync.hs | 2 +- Messages/Internal.hs | 40 ++++++++++++++++++++----------------- Messages/Progress.hs | 5 +---- Types/Messages.hs | 11 +++++++++- 12 files changed, 58 insertions(+), 50 deletions(-) diff --git a/Annex.hs b/Annex.hs index 47147b3589..c9a4ef6a05 100644 --- a/Annex.hs +++ b/Annex.hs @@ -65,9 +65,6 @@ import Utility.Quvi (QuviVersion) #endif import Utility.InodeCache import Utility.Url -#ifdef WITH_CONCURRENTOUTPUT -import System.Console.Regions (ConsoleRegion) -#endif import "mtl" Control.Monad.Reader import Control.Concurrent @@ -136,10 +133,7 @@ data AnnexState = AnnexState , existinghooks :: M.Map Git.Hook.Hook Bool , desktopnotify :: DesktopNotify , workers :: [Either AnnexState (Async AnnexState)] -#ifdef WITH_CONCURRENTOUTPUT - , consoleregion :: Maybe ConsoleRegion - , consoleregionerrflag :: Bool -#endif + , concurrentjobs :: Maybe Int } newState :: GitConfig -> Git.Repo -> AnnexState @@ -184,10 +178,7 @@ newState c r = AnnexState , existinghooks = M.empty , desktopnotify = mempty , workers = [] -#ifdef WITH_CONCURRENTOUTPUT - , consoleregion = Nothing - , consoleregionerrflag = True -#endif + , concurrentjobs = Nothing } {- Makes an Annex state object for the specified git repo. diff --git a/CmdLine.hs b/CmdLine.hs index 880f9de09b..e6ee0c2e6c 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -24,7 +24,6 @@ import Annex.Action import Annex.Environment import Command import Types.Messages -import Messages.Internal {- Runs the passed command line. -} dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () @@ -46,9 +45,8 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput startup - withConcurrentOutput $ - performCommandAction cmd seek $ - shutdown $ cmdnocommit cmd + performCommandAction cmd seek $ + shutdown $ cmdnocommit cmd go (Left norepo) = do let ingitrepo = \a -> a =<< Git.Config.global -- Parse command line with full cmdparser first, diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index eeb41394a4..73cffec762 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -56,7 +56,8 @@ commandAction a = withOutputType go else do l <- liftIO $ drainTo (n-1) ws findFreeSlot l - w <- liftIO $ async $ snd <$> Annex.run st run + w <- liftIO $ async + $ snd <$> Annex.run st (inOwnConsoleRegion run) Annex.changeState $ \s -> s { Annex.workers = Right w:ws' } go _ = run run = void $ includeCommandAction a diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 06e04748d7..b004e42398 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -282,13 +282,17 @@ jsonOption = globalFlag (Annex.setOutput JSONOutput) <> hidden ) +-- Note that a command that adds this option should wrap its seek +-- action in `allowConcurrentOutput`. jobsOption :: GlobalOption -jobsOption = globalSetter (Annex.setOutput . ConcurrentOutput) $ +jobsOption = globalSetter set $ option auto ( long "jobs" <> short 'J' <> metavar paramNumber <> help "enable concurrent jobs" <> hidden ) + where + set n = Annex.changeState $ \s -> s { Annex.concurrentjobs = Just n } timeLimitOption :: GlobalOption timeLimitOption = globalSetter Limit.addTimeLimit $ strOption diff --git a/Command.hs b/Command.hs index bee63bb741..17787539b0 100644 --- a/Command.hs +++ b/Command.hs @@ -19,6 +19,7 @@ module Command ( whenAnnexed, ifAnnexed, isBareRepo, + allowConcurrentOutput, module ReExported ) where @@ -36,6 +37,7 @@ import CmdLine.Option as ReExported import CmdLine.GlobalSetter as ReExported import CmdLine.GitAnnex.Options as ReExported import Options.Applicative as ReExported hiding (command) +import Messages.Internal (allowConcurrentOutput) import qualified Options.Applicative as O diff --git a/Command/Get.hs b/Command/Get.hs index 58fbefed2d..07a5010721 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -37,7 +37,7 @@ optParser desc = GetOptions <*> optional (parseKeyOptions True) seek :: GetOptions -> CommandSeek -seek o = do +seek o = allowConcurrentOutput $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) withKeyOptions (keyOptions o) (autoMode o) (startKeys from) diff --git a/Command/Mirror.hs b/Command/Mirror.hs index a8caf9da7f..148ca8d3cb 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -41,10 +41,11 @@ instance DeferredParseClass MirrorOptions where <*> pure (keyOptions v) seek :: MirrorOptions -> CommandSeek -seek o = withKeyOptions (keyOptions o) False - (startKey o Nothing) - (withFilesInGit $ whenAnnexed $ start o) - (mirrorFiles o) +seek o = allowConcurrentOutput $ + withKeyOptions (keyOptions o) False + (startKey o Nothing) + (withFilesInGit $ whenAnnexed $ start o) + (mirrorFiles o) start :: MirrorOptions -> FilePath -> Key -> CommandStart start o file = startKey o (Just file) diff --git a/Command/Move.hs b/Command/Move.hs index 9a289d8b69..7a0b57c109 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -45,10 +45,11 @@ instance DeferredParseClass MoveOptions where <*> pure (keyOptions v) seek :: MoveOptions -> CommandSeek -seek o = withKeyOptions (keyOptions o) False - (startKey o True) - (withFilesInGit $ whenAnnexed $ start o True) - (moveFiles o) +seek o = allowConcurrentOutput $ + withKeyOptions (keyOptions o) False + (startKey o True) + (withFilesInGit $ whenAnnexed $ start o True) + (moveFiles o) start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart start o move = start' o move . Just diff --git a/Command/Sync.hs b/Command/Sync.hs index fffc113d2d..2de92188b5 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -93,7 +93,7 @@ optParser desc = SyncOptions <*> optional parseAllOption seek :: SyncOptions -> CommandSeek -seek o = do +seek o = allowConcurrentOutput $ do prepMerge -- There may not be a branch checked out until after the commit, diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 8bbb0cfc8d..e4651238b4 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{- git-annex output messages, including concurrent output +{- git-annex output messages, including concurrent output to display regions - - Copyright 2010-2015 Joey Hess - @@ -58,35 +58,38 @@ flushed a = a >> hFlush stdout -} concurrentMessage :: Bool -> String -> Annex () -> Annex () #ifdef WITH_CONCURRENTOUTPUT -concurrentMessage iserror msg _ = go =<< Annex.getState Annex.consoleregion +concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output where go Nothing | iserror = liftIO $ Console.errorConcurrent msg - | otherwise = liftIO $ Console.outputConcurrent msg + | otherwise = do + liftIO $ Console.outputConcurrent ("REGION MESSAGE NO REGION" ++ show msg) + liftIO $ Console.outputConcurrent msg go (Just r) = do + liftIO $ Console.outputConcurrent ("REGION MESSAGE " ++ show msg) -- Can't display the error to stdout while -- console regions are in use, so set the errflag -- to get it to display to stderr later. - when iserror $ - Annex.changeState $ \s -> s { Annex.consoleregionerrflag = True } + when iserror $ do + Annex.changeState $ \s -> + s { Annex.output = (Annex.output s) { consoleRegionErrFlag = True } } liftIO $ Regions.appendConsoleRegion r msg #else concurrentMessage _ _ fallback = fallback #endif -{- Enable concurrent output when that has been requested. - - - - This should only be run once per git-annex lifetime, with - - everything that might generate messages run inside it. - -} -withConcurrentOutput :: Annex a -> Annex a +{- Do concurrent output when that has been requested. -} +allowConcurrentOutput :: Annex a -> Annex a #ifdef WITH_CONCURRENTOUTPUT -withConcurrentOutput a = withOutputType go +allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs where - go (ConcurrentOutput _) = Console.withConcurrentOutput a - go _ = a + go (Just n) = Regions.displayConsoleRegions $ bracket_ + (Annex.setOutput (ConcurrentOutput n)) + (Annex.setOutput NormalOutput) + a + go Nothing = a #else -withConcurrentOutput = id +allowConcurrentOutput = id #endif {- Runs an action in its own dedicated region of the console. @@ -103,11 +106,12 @@ inOwnConsoleRegion a = Regions.withConsoleRegion Regions.Linear $ \r -> do setregion (Just r) a `finally` removeregion r where - setregion v = Annex.changeState $ \s -> s { Annex.consoleregion = v } + setregion r = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { consoleRegion = r } } removeregion r = do - errflag <- Annex.getState Annex.consoleregionerrflag + errflag <- consoleRegionErrFlag <$> Annex.getState Annex.output let h = if errflag then Console.StdErr else Console.StdOut - Annex.changeState $ \s -> s { Annex.consoleregionerrflag = False } + Annex.changeState $ \s -> + s { Annex.output = (Annex.output s) { consoleRegionErrFlag = False } } setregion Nothing liftIO $ atomically $ do t <- Regions.getConsoleRegion r diff --git a/Messages/Progress.hs b/Messages/Progress.hs index a20ba098ee..89f2f0c8c2 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -65,10 +65,7 @@ metered combinemeterupdate key af a = case keySize key of return r #else -- Old progress bar code, not suitable for concurrent output. - go _ (ConcurrentOutput _) = do - r <- nometer - liftIO $ putStrLn $ fromMaybe (key2file key) af - return r + go _ (ConcurrentOutput _) = nometer go size NormalOutput = do showOutput progress <- liftIO $ newProgress "" size diff --git a/Types/Messages.hs b/Types/Messages.hs index 5cbb530570..0e60f36c8b 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -5,11 +5,18 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Types.Messages where import Data.Default +#ifdef WITH_CONCURRENTOUTPUT +import System.Console.Regions (ConsoleRegion) +#endif + data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int | JSONOutput + deriving (Show) data SideActionBlock = NoBlock | StartBlock | InBlock deriving (Eq) @@ -17,8 +24,10 @@ data SideActionBlock = NoBlock | StartBlock | InBlock data MessageState = MessageState { outputType :: OutputType , sideActionBlock :: SideActionBlock + , consoleRegion :: Maybe ConsoleRegion + , consoleRegionErrFlag :: Bool } instance Default MessageState where - def = MessageState NormalOutput NoBlock + def = MessageState NormalOutput NoBlock Nothing False