diff options
author | Joey Hess <joeyh@joeyh.name> | 2015-11-05 17:22:45 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2015-11-05 17:23:26 -0400 |
commit | e0d5901349c15b3eeace319cbe8854e655a602d6 (patch) | |
tree | da3346ca3aeb17f283fd2e814b2e3faa470dd8aa /Messages/Internal.hs | |
parent | 021c06e8998a365c95db2f362d37bdf00f61ea01 (diff) |
join back threads before ending concurrent output so display works
I didn't really want to put allowConcurrentOutput in CmdLine.Action,
but there were dep loops and that was the best place available.
Diffstat (limited to 'Messages/Internal.hs')
-rw-r--r-- | Messages/Internal.hs | 90 |
1 files changed, 1 insertions, 89 deletions
diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 168846205..fcbbe10b4 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {- git-annex output messages, including concurrent output to display regions - - Copyright 2010-2015 Joey Hess <id@joeyh.name> @@ -7,20 +5,12 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Messages.Internal where import Common import Annex import Types.Messages - -#ifdef WITH_CONCURRENTOUTPUT -import qualified System.Console.Concurrent as Console -import qualified System.Console.Regions as Regions -import Control.Concurrent.STM -import qualified Data.Text as T -#endif +import Messages.Concurrent withOutputType :: (OutputType -> Annex a) -> Annex a withOutputType a = outputType <$> Annex.getState Annex.output >>= a @@ -48,81 +38,3 @@ q = noop flushed :: IO () -> IO () flushed a = a >> hFlush stdout - -{- Outputs a message in a concurrency safe way. - - - - The message may be an error message, in which case it goes to stderr. - - - - When built without concurrent-output support, the fallback action is run - - instead. - -} -concurrentMessage :: Bool -> String -> Annex () -> Annex () -#ifdef WITH_CONCURRENTOUTPUT -concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output - where - go Nothing - | iserror = liftIO $ Console.errorConcurrent msg - | otherwise = liftIO $ Console.outputConcurrent msg - go (Just r) = do - -- 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 $ do - Annex.changeState $ \s -> - s { Annex.output = (Annex.output s) { consoleRegionErrFlag = True } } - liftIO $ Regions.appendConsoleRegion r msg -#else -concurrentMessage _ _ fallback = fallback -#endif - -{- Do concurrent output when that has been requested. -} -allowConcurrentOutput :: Annex a -> Annex a -#ifdef WITH_CONCURRENTOUTPUT -allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs - where - go (Just n) = Regions.displayConsoleRegions $ bracket_ - (Annex.setOutput (ConcurrentOutput n)) - (Annex.setOutput NormalOutput) - a - go Nothing = a -#else -allowConcurrentOutput = id -#endif - -{- Runs an action in its own dedicated region of the console. - - - - The region is closed at the end or on exception, and at that point - - the value of the region is displayed in the scrolling area above - - any other active regions. - - - - When not at a console, a region is not displayed until the action is - - complete. - -} -inOwnConsoleRegion :: Annex a -> Annex a -#ifdef WITH_CONCURRENTOUTPUT -inOwnConsoleRegion a = bracket mkregion rmregion go - where - go r = do - setregion (Just r) - a - mkregion = Regions.openConsoleRegion Regions.Linear - rmregion r = do - errflag <- consoleRegionErrFlag <$> Annex.getState Annex.output - let h = if errflag then Console.StdErr else Console.StdOut - Annex.changeState $ \s -> - s { Annex.output = (Annex.output s) { consoleRegionErrFlag = False } } - setregion Nothing - liftIO $ atomically $ do - t <- Regions.getConsoleRegion r - unless (T.null t) $ - Console.bufferOutputSTM h t - Regions.closeConsoleRegion r - setregion r = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { consoleRegion = r } } -#else -inOwnConsoleRegion = id -#endif - -#ifdef WITH_CONCURRENTOUTPUT -instance Regions.LiftRegion Annex where - liftRegion = liftIO . atomically -#endif |