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.
This commit is contained in:
Joey Hess 2016-09-09 12:57:42 -04:00
parent 8e9267a1ed
commit 8ef494a833
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
12 changed files with 96 additions and 84 deletions

View file

@ -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 ()