arrange for regional output manager to run when -J is enabled

Commands that want to use it have to run their seek action inside
allowConcurrentOutput. Which seems reasonable; perhaps some future command
will want to support the -J flag but not use regions.

The region state moved from Annex to MessageState. This makes sense
organizationally, and note that some uses of onLocal use a different Annex
state, but pass the MessageState into it, which is what is needed.

Annex.hs

@@ -65,9 +65,6 @@ import Utility.Quvi (QuviVersion)
 #endif
 import Utility.InodeCache
 import Utility.Url
-#ifdef WITH_CONCURRENTOUTPUT
-import System.Console.Regions (ConsoleRegion)
-#endif
 
 import "mtl" Control.Monad.Reader
 import Control.Concurrent
@@ -136,10 +133,7 @@ data AnnexState = AnnexState
 	, existinghooks :: M.Map Git.Hook.Hook Bool
 	, desktopnotify :: DesktopNotify
 	, workers :: [Either AnnexState (Async AnnexState)]
-#ifdef WITH_CONCURRENTOUTPUT
-	, consoleregion :: Maybe ConsoleRegion
-	, consoleregionerrflag :: Bool
-#endif
+	, concurrentjobs :: Maybe Int
 	}
 
 newState :: GitConfig -> Git.Repo -> AnnexState
@@ -184,10 +178,7 @@ newState c r = AnnexState
 	, existinghooks = M.empty
 	, desktopnotify = mempty
 	, workers = []
-#ifdef WITH_CONCURRENTOUTPUT
-	, consoleregion = Nothing
-	, consoleregionerrflag = True
-#endif
+	, concurrentjobs = Nothing
 	}
 
 {- Makes an Annex state object for the specified git repo.

CmdLine.hs

@@ -24,7 +24,6 @@ import Annex.Action
 import Annex.Environment
 import Command
 import Types.Messages
-import Messages.Internal
 
 {- Runs the passed command line. -}
 dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
@@ -46,9 +45,8 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde
 			whenM (annexDebug <$> Annex.getGitConfig) $
 				liftIO enableDebugOutput
 			startup
-			withConcurrentOutput $
-				performCommandAction cmd seek $
-					shutdown $ cmdnocommit cmd
+			performCommandAction cmd seek $
+				shutdown $ cmdnocommit cmd
 	go (Left norepo) = do
 		let ingitrepo = \a -> a =<< Git.Config.global
 		-- Parse command line with full cmdparser first,

CmdLine/Action.hs

@@ -56,7 +56,8 @@ commandAction a = withOutputType go
 			else do
 				l <- liftIO $ drainTo (n-1) ws
 				findFreeSlot l
-		w <- liftIO $ async $ snd <$> Annex.run st run
+		w <- liftIO $ async
+			$ snd <$> Annex.run st (inOwnConsoleRegion run)
 		Annex.changeState $ \s -> s { Annex.workers = Right w:ws' }
 	go _  =	run
 	run = void $ includeCommandAction a

CmdLine/GitAnnex/Options.hs

@@ -282,13 +282,17 @@ jsonOption = globalFlag (Annex.setOutput JSONOutput)
 	<> hidden
 	)
 
+-- Note that a command that adds this option should wrap its seek
+-- action in `allowConcurrentOutput`.
 jobsOption :: GlobalOption
-jobsOption = globalSetter (Annex.setOutput . ConcurrentOutput) $ 
+jobsOption = globalSetter set $ 
 	option auto
 		( long "jobs" <> short 'J' <> metavar paramNumber
 		<> help "enable concurrent jobs"
 		<> hidden
 		)
+  where
+	set n = Annex.changeState $ \s -> s { Annex.concurrentjobs = Just n }
 
 timeLimitOption :: GlobalOption
 timeLimitOption = globalSetter Limit.addTimeLimit $ strOption

Command.hs

@@ -19,6 +19,7 @@ module Command (
 	whenAnnexed,
 	ifAnnexed,
 	isBareRepo,
+	allowConcurrentOutput,
 	module ReExported
 ) where
 
@@ -36,6 +37,7 @@ import CmdLine.Option as ReExported
 import CmdLine.GlobalSetter as ReExported
 import CmdLine.GitAnnex.Options as ReExported
 import Options.Applicative as ReExported hiding (command)
+import Messages.Internal (allowConcurrentOutput)
 
 import qualified Options.Applicative as O
 

Command/Get.hs

@@ -37,7 +37,7 @@ optParser desc = GetOptions
 	<*> optional (parseKeyOptions True)
 
 seek :: GetOptions -> CommandSeek
-seek o = do
+seek o = allowConcurrentOutput $ do
 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)
 	withKeyOptions (keyOptions o) (autoMode o)
 		(startKeys from)

Command/Mirror.hs

@@ -41,10 +41,11 @@ instance DeferredParseClass MirrorOptions where
 		<*> pure (keyOptions v)
 
 seek :: MirrorOptions -> CommandSeek
-seek o = withKeyOptions (keyOptions o) False
-	(startKey o Nothing)
-	(withFilesInGit $ whenAnnexed $ start o)
-	(mirrorFiles o)
+seek o = allowConcurrentOutput $ 
+	withKeyOptions (keyOptions o) False
+		(startKey o Nothing)
+		(withFilesInGit $ whenAnnexed $ start o)
+		(mirrorFiles o)
 
 start :: MirrorOptions -> FilePath -> Key -> CommandStart
 start o file = startKey o (Just file)

Command/Move.hs

@@ -45,10 +45,11 @@ instance DeferredParseClass MoveOptions where
 		<*> pure (keyOptions v)
 
 seek :: MoveOptions -> CommandSeek
-seek o = withKeyOptions (keyOptions o) False
-	(startKey o True)
-	(withFilesInGit $ whenAnnexed $ start o True)
-	(moveFiles o)
+seek o = allowConcurrentOutput $ 
+	withKeyOptions (keyOptions o) False
+		(startKey o True)
+		(withFilesInGit $ whenAnnexed $ start o True)
+		(moveFiles o)
 
 start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart
 start o move = start' o move . Just

Command/Sync.hs

@@ -93,7 +93,7 @@ optParser desc = SyncOptions
 	<*> optional parseAllOption
 
 seek :: SyncOptions -> CommandSeek
-seek o = do
+seek o = allowConcurrentOutput $ do
 	prepMerge
 
 	-- There may not be a branch checked out until after the commit,

Messages/Internal.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{- git-annex output messages, including concurrent output
+{- git-annex output messages, including concurrent output to display regions
  -
  - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
@@ -58,35 +58,38 @@ flushed a = a >> hFlush stdout
  -}
 concurrentMessage :: Bool -> String -> Annex () -> Annex ()
 #ifdef WITH_CONCURRENTOUTPUT
-concurrentMessage iserror msg _ = go =<< Annex.getState Annex.consoleregion
+concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output
   where
 	go Nothing
 		| iserror = liftIO $ Console.errorConcurrent msg
-		| otherwise = liftIO $ Console.outputConcurrent msg
+		| otherwise = do
+			liftIO $ Console.outputConcurrent ("REGION MESSAGE NO REGION" ++ show msg)
+			liftIO $ Console.outputConcurrent msg
 	go (Just r) = do
+		liftIO $ Console.outputConcurrent ("REGION MESSAGE " ++ show msg)
 		-- Can't display the error to stdout while
 		-- console regions are in use, so set the errflag
 		-- to get it to display to stderr later.
-		when iserror $
-			Annex.changeState $ \s -> s { Annex.consoleregionerrflag = True }
+		when iserror $ do
+			Annex.changeState $ \s ->
+				s { Annex.output = (Annex.output s) { consoleRegionErrFlag = True } }
 		liftIO $ Regions.appendConsoleRegion r msg
 #else
 concurrentMessage _ _ fallback = fallback
 #endif
 
-{- Enable concurrent output when that has been requested.
- -
- - This should only be run once per git-annex lifetime, with
- - everything that might generate messages run inside it.
- -}
-withConcurrentOutput :: Annex a -> Annex a
+{- Do concurrent output when that has been requested. -}
+allowConcurrentOutput :: Annex a -> Annex a
 #ifdef WITH_CONCURRENTOUTPUT
-withConcurrentOutput a = withOutputType go
+allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs
   where
-	go (ConcurrentOutput _) = Console.withConcurrentOutput a
-	go _ = a
+	go (Just n) = Regions.displayConsoleRegions $ bracket_
+		(Annex.setOutput (ConcurrentOutput n))
+		(Annex.setOutput NormalOutput)
+		a
+	go Nothing = a
 #else
-withConcurrentOutput = id
+allowConcurrentOutput = id
 #endif
 
 {- Runs an action in its own dedicated region of the console.
@@ -103,11 +106,12 @@ inOwnConsoleRegion a = Regions.withConsoleRegion Regions.Linear $ \r -> do
 	setregion (Just r)
 	a `finally` removeregion r
   where
-	setregion v = Annex.changeState $ \s -> s { Annex.consoleregion = v }
+	setregion r = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { consoleRegion = r } }
 	removeregion r = do
-		errflag <- Annex.getState Annex.consoleregionerrflag
+		errflag <- consoleRegionErrFlag <$> Annex.getState Annex.output
 		let h = if errflag then Console.StdErr else Console.StdOut
-		Annex.changeState $ \s -> s { Annex.consoleregionerrflag = False }
+		Annex.changeState $ \s ->
+			s { Annex.output = (Annex.output s) { consoleRegionErrFlag = False } }
 		setregion Nothing
 		liftIO $ atomically $ do
 			t <- Regions.getConsoleRegion r

Messages/Progress.hs

@@ -65,10 +65,7 @@ metered combinemeterupdate key af a = case keySize key of
 		return r
 #else
 	-- Old progress bar code, not suitable for concurrent output.
-	go _ (ConcurrentOutput _) = do
-		r <- nometer
-		liftIO $ putStrLn $ fromMaybe (key2file key) af
-		return r
+	go _ (ConcurrentOutput _) = nometer
 	go size NormalOutput = do
 		showOutput
 		progress <- liftIO $ newProgress "" size

Types/Messages.hs

@@ -5,11 +5,18 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Types.Messages where
 
 import Data.Default
 
+#ifdef WITH_CONCURRENTOUTPUT
+import System.Console.Regions (ConsoleRegion)
+#endif
+
 data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int | JSONOutput
+	deriving (Show)
 
 data SideActionBlock = NoBlock | StartBlock | InBlock
 	deriving (Eq)
@@ -17,8 +24,10 @@ data SideActionBlock = NoBlock | StartBlock | InBlock
 data MessageState = MessageState
 	{ outputType :: OutputType
 	, sideActionBlock :: SideActionBlock
+	, consoleRegion :: Maybe ConsoleRegion
+	, consoleRegionErrFlag :: Bool
 	}
 
 instance Default MessageState
   where
-	def = MessageState NormalOutput NoBlock
+	def = MessageState NormalOutput NoBlock Nothing False