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