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

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