summaryrefslogtreecommitdiff
path: root/Messages
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-09-09 12:57:42 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-09-09 12:57:42 -0400
commitcac7297784a4eb953f0d6108d7e67e97be9285ad (patch)
treeca0098b875209945e15de2f63f52463487eb5e43 /Messages
parent70ad04b5fc21d39bdae85b08ec948359a28021e6 (diff)
disentangle concurrency and message type
This makes -Jn work with --json and --quiet, where before setting -Jn disabled those options. Concurrent json output is currently a mess though since threads output chunks over top of one-another.
Diffstat (limited to 'Messages')
-rw-r--r--Messages/Concurrent.hs33
-rw-r--r--Messages/Internal.hs27
-rw-r--r--Messages/Progress.hs37
3 files changed, 47 insertions, 50 deletions
diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
index 91b840231..41153d067 100644
--- a/Messages/Concurrent.hs
+++ b/Messages/Concurrent.hs
@@ -31,13 +31,13 @@ import GHC.IO.Encoding
- When built without concurrent-output support, the fallback action is run
- instead.
-}
-concurrentMessage :: OutputType -> Bool -> String -> Annex () -> Annex ()
+concurrentMessage :: MessageState -> Bool -> String -> Annex () -> Annex ()
#ifdef WITH_CONCURRENTOUTPUT
-concurrentMessage o iserror msg fallback
- | concurrentOutputEnabled o =
+concurrentMessage s iserror msg fallback
+ | concurrentOutputEnabled s =
go =<< consoleRegion <$> Annex.getState Annex.output
#else
-concurrentMessage _o _iserror _msg fallback
+concurrentMessage _s _iserror _msg fallback
#endif
| otherwise = fallback
#ifdef WITH_CONCURRENTOUTPUT
@@ -50,8 +50,8 @@ concurrentMessage _o _iserror _msg fallback
-- 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 } }
+ Annex.changeState $ \st ->
+ st { Annex.output = (Annex.output st) { consoleRegionErrFlag = True } }
liftIO $ atomically $ do
Regions.appendConsoleRegion r msg
rl <- takeTMVar Regions.regionList
@@ -68,24 +68,24 @@ concurrentMessage _o _iserror _msg fallback
- When not at a console, a region is not displayed until the action is
- complete.
-}
-inOwnConsoleRegion :: OutputType -> Annex a -> Annex a
+inOwnConsoleRegion :: MessageState -> Annex a -> Annex a
#ifdef WITH_CONCURRENTOUTPUT
-inOwnConsoleRegion o a
- | concurrentOutputEnabled o = do
+inOwnConsoleRegion s a
+ | concurrentOutputEnabled s = do
r <- mkregion
setregion (Just r)
eret <- tryNonAsync a `onException` rmregion r
case eret of
Left e -> do
-- Add error message to region before it closes.
- concurrentMessage o True (show e) noop
+ concurrentMessage s True (show e) noop
rmregion r
throwM e
Right ret -> do
rmregion r
return ret
#else
-inOwnConsoleRegion _o a
+inOwnConsoleRegion _s a
#endif
| otherwise = a
#ifdef WITH_CONCURRENTOUTPUT
@@ -94,12 +94,13 @@ inOwnConsoleRegion _o a
-- a message is added to it. This avoids unnecessary screen
-- updates when a region does not turn out to need to be used.
mkregion = Regions.newConsoleRegion Regions.Linear ""
- setregion r = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { consoleRegion = r } }
+ setregion r = Annex.changeState $ \st -> st
+ { Annex.output = (Annex.output st) { consoleRegion = r } }
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 } }
+ Annex.changeState $ \st -> st
+ { Annex.output = (Annex.output st) { consoleRegionErrFlag = False } }
setregion Nothing
liftIO $ atomically $ do
t <- Regions.getConsoleRegion r
@@ -135,7 +136,3 @@ concurrentOutputSupported = return True -- Windows is always unicode
#else
concurrentOutputSupported = return False
#endif
-
-concurrentOutputEnabled :: OutputType -> Bool
-concurrentOutputEnabled (ConcurrentOutput _ b) = b
-concurrentOutputEnabled _ = False
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 9b9edccc5..5c5b19bd1 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -12,25 +12,26 @@ import Annex
import Types.Messages
import Messages.Concurrent
-withOutputType :: (OutputType -> Annex a) -> Annex a
-withOutputType a = outputType <$> Annex.getState Annex.output >>= a
+withMessageState :: (MessageState -> Annex a) -> Annex a
+withMessageState a = 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 o@(ConcurrentOutput {}) = concurrentMessage o False s q
- go JSONOutput = liftIO $ flushed json
+outputMessage json msg = withMessageState $ \s -> case outputType s of
+ NormalOutput
+ | concurrentOutputEnabled s -> concurrentMessage s False msg q
+ | otherwise -> liftIO $ flushed $ putStr msg
+ QuietOutput -> q
+ JSONOutput -> liftIO $ flushed json
outputError :: String -> Annex ()
-outputError s = withOutputType go
+outputError msg = withMessageState $ \s ->
+ if concurrentOutputEnabled s
+ then concurrentMessage s True msg go
+ else go
where
- go o@(ConcurrentOutput {}) = concurrentMessage o True s (go NormalOutput)
- go _ = liftIO $ do
+ go = liftIO $ do
hFlush stdout
- hPutStr stderr s
+ hPutStr stderr msg
hFlush stderr
q :: Monad m => m ()
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index f6541c191..fa11c1304 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -32,11 +32,11 @@ import Data.Quantity
metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
metered othermeter key a = case keySize key of
Nothing -> nometer
- Just size -> withOutputType (go $ fromInteger size)
+ Just size -> withMessageState (go $ fromInteger size)
where
- go _ QuietOutput = nometer
- go _ JSONOutput = nometer
- go size NormalOutput = do
+ go _ (MessageState { outputType = QuietOutput }) = nometer
+ go _ (MessageState { outputType = JSONOutput }) = nometer
+ go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
showOutput
(progress, meter) <- mkmeter size
m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do
@@ -45,9 +45,9 @@ metered othermeter key a = case keySize key of
r <- a (combinemeter m)
liftIO $ clearMeter stdout meter
return r
+ go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
#if WITH_CONCURRENTOUTPUT
- go size o@(ConcurrentOutput {})
- | concurrentOutputEnabled o = withProgressRegion $ \r -> do
+ withProgressRegion $ \r -> do
(progress, meter) <- mkmeter size
m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do
setP progress $ fromBytesProcessed n
@@ -55,9 +55,8 @@ metered othermeter key a = case keySize key of
Regions.setConsoleRegion r ("\n" ++ s)
a (combinemeter m)
#else
- go _size _o
+ nometer
#endif
- | otherwise = nometer
mkmeter size = do
progress <- liftIO $ newProgress "" size
@@ -73,18 +72,18 @@ metered othermeter key a = case keySize key of
{- Use when the progress meter is only desired for concurrent
- output; as when a command's own progress output is preferred. -}
concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
-concurrentMetered combinemeterupdate key a = withOutputType go
- where
- go (ConcurrentOutput {}) = metered combinemeterupdate key a
- go _ = a (fromMaybe nullMeterUpdate combinemeterupdate)
+concurrentMetered combinemeterupdate key a =
+ withMessageState $ \s -> if concurrentOutputEnabled s
+ then metered combinemeterupdate key a
+ else a (fromMaybe nullMeterUpdate combinemeterupdate)
{- Poll file size to display meter, but only for concurrent output. -}
concurrentMeteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
-concurrentMeteredFile file combinemeterupdate key a = withOutputType go
- where
- go (ConcurrentOutput {}) = metered combinemeterupdate key $ \p ->
- watchFileSize file p a
- go _ = a
+concurrentMeteredFile file combinemeterupdate key a =
+ withMessageState $ \s -> if concurrentOutputEnabled s
+ then metered combinemeterupdate key $ \p ->
+ watchFileSize file p a
+ else a
{- Progress dots. -}
showProgressDots :: Annex ()
@@ -123,9 +122,9 @@ mkStderrRelayer = do
- messing it up with interleaved stderr from a command.
-}
mkStderrEmitter :: Annex (String -> IO ())
-mkStderrEmitter = withOutputType go
+mkStderrEmitter = withMessageState go
where
#ifdef WITH_CONCURRENTOUTPUT
- go o | concurrentOutputEnabled o = return Console.errorConcurrent
+ go s | concurrentOutputEnabled s = return Console.errorConcurrent
#endif
go _ = return (hPutStrLn stderr)