diff options
author | 2016-09-09 12:57:42 -0400 | |
---|---|---|
committer | 2016-09-09 12:57:42 -0400 | |
commit | cac7297784a4eb953f0d6108d7e67e97be9285ad (patch) | |
tree | ca0098b875209945e15de2f63f52463487eb5e43 /Messages/Internal.hs | |
parent | 70ad04b5fc21d39bdae85b08ec948359a28021e6 (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/Internal.hs')
-rw-r--r-- | Messages/Internal.hs | 27 |
1 files changed, 14 insertions, 13 deletions
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 () |