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:
parent
8e9267a1ed
commit
8ef494a833
12 changed files with 96 additions and 84 deletions
|
@ -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 ()
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue