From 527b6970457e74f8c88dfdac7c96241e2496a2f2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Nov 2015 14:52:07 -0400 Subject: add regions to concurrent output still no progress displays when getting files etc, but a big improvement --- Messages/Concurrent.hs | 33 --------------- Messages/Internal.hs | 106 ++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 87 insertions(+), 52 deletions(-) delete mode 100644 Messages/Concurrent.hs (limited to 'Messages') diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs deleted file mode 100644 index 3b7b28d28..000000000 --- a/Messages/Concurrent.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- git-annex concurrent output - - - - Copyright 2015 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Messages.Concurrent where - -import Common.Annex -import Messages.Internal -import Types.Messages - -#ifdef WITH_CONCURRENTOUTPUT -import qualified System.Console.Concurrent as Console -#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 -#ifdef WITH_CONCURRENTOUTPUT -withConcurrentOutput a = withOutputType go - where - go (ConcurrentOutput _) = Console.withConcurrentOutput a - go _ = a -#else -withConcurrentOutput = id -#endif diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 1501c072a..8bbb0cfc8 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -1,6 +1,8 @@ -{- git-annex output messages +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- git-annex output messages, including concurrent output - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,37 +12,32 @@ module Messages.Internal where import Common -import Types +import Annex import Types.Messages -import qualified Annex #ifdef WITH_CONCURRENTOUTPUT -import System.Console.Concurrent +import qualified System.Console.Concurrent as Console +import qualified System.Console.Regions as Regions +import Data.String +import Control.Concurrent.STM #endif +withOutputType :: (OutputType -> Annex a) -> Annex a +withOutputType a = outputType <$> Annex.getState Annex.output >>= a + outputMessage :: IO () -> String -> Annex () outputMessage json s = withOutputType go where go NormalOutput = liftIO $ flushed $ putStr s go QuietOutput = q - go (ConcurrentOutput _) = liftIO $ -#ifdef WITH_CONCURRENTOUTPUT - outputConcurrent s -#else - q -#endif + go (ConcurrentOutput _) = concurrentMessage False s q go JSONOutput = liftIO $ flushed json outputError :: String -> Annex () outputError s = withOutputType go where - go (ConcurrentOutput _) = liftIO $ -#ifdef WITH_CONCURRENTOUTPUT - errorConcurrent s -#else - q -#endif + go (ConcurrentOutput _) = concurrentMessage True s (go NormalOutput) go _ = liftIO $ do hFlush stdout hPutStr stderr s @@ -52,5 +49,76 @@ q = noop flushed :: IO () -> IO () flushed a = a >> hFlush stdout -withOutputType :: (OutputType -> Annex a) -> Annex a -withOutputType a = outputType <$> Annex.getState Annex.output >>= a +{- 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 =<< Annex.getState Annex.consoleregion + 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 $ + Annex.changeState $ \s -> s { Annex.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 +#ifdef WITH_CONCURRENTOUTPUT +withConcurrentOutput a = withOutputType go + where + go (ConcurrentOutput _) = Console.withConcurrentOutput a + go _ = a +#else +withConcurrentOutput = 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 end. + -} +inOwnConsoleRegion :: Annex a -> Annex a +#ifdef WITH_CONCURRENTOUTPUT +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 } + removeregion r = do + errflag <- Annex.getState Annex.consoleregionerrflag + let h = if errflag then Console.StdErr else Console.StdOut + Annex.changeState $ \s -> s { Annex.consoleregionerrflag = False } + setregion Nothing + liftIO $ atomically $ do + t <- Regions.getConsoleRegion r + Regions.closeConsoleRegion r + Console.bufferOutputSTM h $ + Console.toOutput (t <> fromString "\n") +#else +inOwnConsoleRegion = id +#endif + +#ifdef WITH_CONCURRENTOUTPUT +instance Regions.LiftRegion Annex where + liftRegion = liftIO . atomically +#endif -- cgit v1.2.3