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.

diff --git a/Annex.hs b/Annex.hs
index 47147b3589a533e7bd6782ac63eac03ef658442e..c9a4ef6a05a682c7934d4bae4491788e30ef57fd 100644 (file)
--- a/Annex.hs
+++ b/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.

diff --git a/CmdLine.hs b/CmdLine.hs
index 880f9de09bd07d738551e49ee5688471cde3d7e1..e6ee0c2e6c7cb0d5897c4fdb5a1acfe427c4f21f 100644 (file)
--- a/CmdLine.hs
+++ b/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,

diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index eeb41394a495db82156523837a05df99d379b94f..73cffec762760a6ee2ddb960c574aeb9a05ca9ee 100644 (file)
--- a/CmdLine/Action.hs
+++ b/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

diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs
index 06e04748d78c66ae3296a9d09b7cd707d741377a..b004e4239814947189d45092df894c262dac0f6e 100644 (file)
--- a/CmdLine/GitAnnex/Options.hs
+++ b/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

diff --git a/Command.hs b/Command.hs
index bee63bb741fa66ae533b0962e5c66560ab2676d0..17787539b00e895c076c8d29d25fb9b5744471b0 100644 (file)
--- a/Command.hs
+++ b/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
 

diff --git a/Command/Get.hs b/Command/Get.hs
index 58fbefed2d598ee26b304f517f62155653461fda..07a501072122cf69b03ea9367cb0673339ef040b 100644 (file)
--- a/Command/Get.hs
+++ b/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)

diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index a8caf9da7f28a56a63bb1e5b9076aef946564868..148ca8d3cb6e6ef63a51c8ecddfc783084f6126c 100644 (file)
--- a/Command/Mirror.hs
+++ b/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)

diff --git a/Command/Move.hs b/Command/Move.hs
index 9a289d8b691fb2963b86e91b15a0f23ec2ef6ace..7a0b57c10926ced81bc13504874b61bd9177eb01 100644 (file)
--- a/Command/Move.hs
+++ b/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

diff --git a/Command/Sync.hs b/Command/Sync.hs
index fffc113d2df06f03255912792eb554510efecd28..2de92188b594242668ff009a55533baed178b3a6 100644 (file)
--- a/Command/Sync.hs
+++ b/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,

diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 8bbb0cfc8dafb52f9fe0230db793907f11b23c09..e4651238b429d40307a2209f3be3bf58a10ff3c6 100644 (file)
--- a/Messages/Internal.hs
+++ b/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

diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index a20ba098ee0c0e15c9749c5eacf8e384450e2c0b..89f2f0c8c2f51ae2c36c94742156bfd0764c2efc 100644 (file)
--- a/Messages/Progress.hs
+++ b/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

diff --git a/Types/Messages.hs b/Types/Messages.hs
index 5cbb53057034973521064c3a3e7a1fa560d6bc44..0e60f36c8b0007aa80b3df7b5a3a97b2343c7c3b 100644 (file)
--- a/Types/Messages.hs
+++ b/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