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.

3 files changed, 47 insertions, 50 deletions

diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
index 91b840231..41153d067 100644
--- a/Messages/Concurrent.hs
+++ b/Messages/Concurrent.hs
@@ -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
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 ()
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index f6541c191..fa11c1304 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -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)