add regions to concurrent output

still no progress displays when getting files etc, but a big improvement

diff --git a/Annex.hs b/Annex.hs
index d6834e24a6a9f8e15ab379c48cd86ad6c6817eed..47147b3589a533e7bd6782ac63eac03ef658442e 100644 (file)
--- a/Annex.hs
+++ b/Annex.hs
@@ -65,6 +65,9 @@ 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
@@ -133,6 +136,10 @@ 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
        }
 
 newState :: GitConfig -> Git.Repo -> AnnexState
@@ -177,6 +184,10 @@ newState c r = AnnexState
        , existinghooks = M.empty
        , desktopnotify = mempty
        , workers = []
+#ifdef WITH_CONCURRENTOUTPUT
+       , consoleregion = Nothing
+       , consoleregionerrflag = True
+#endif
        }
 
 {- Makes an Annex state object for the specified git repo.

diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs
index d3585e04fee63bc5fbe286b9542ed43a61c8a91d..5faa98a47d12200c7c670f97d042d75ed79f3c19 100644 (file)
--- a/Annex/Concurrent.hs
+++ b/Annex/Concurrent.hs
@@ -51,7 +51,7 @@ dupState = do
                }
 
 {- Merges the passed AnnexState into the current Annex state.
- - Also shuts closes various handles in it. -}
+ - Also closes various handles in it. -}
 mergeState :: AnnexState -> Annex ()
 mergeState st = do
        st' <- liftIO $ snd <$> run st closehandles

diff --git a/CmdLine.hs b/CmdLine.hs
index 073d4b32df8c2f48658f7ecf72e6526b9e2f3c2b..880f9de09bd07d738551e49ee5688471cde3d7e1 100644 (file)
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -24,7 +24,7 @@ import Annex.Action
 import Annex.Environment
 import Command
 import Types.Messages
-import Messages.Concurrent
+import Messages.Internal
 
 {- Runs the passed command line. -}
 dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()

diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
deleted file mode 100644 (file)
index 3b7b28d..0000000
--- a/Messages/Concurrent.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{- git-annex concurrent output
- -
- - Copyright 2015 Joey Hess <id@joeyh.name>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE CPP #-}
-
-module Messages.Concurrent where
-
-import Common.Annex
-import Messages.Internal
-import Types.Messages
-
-#ifdef WITH_CONCURRENTOUTPUT
-import qualified System.Console.Concurrent as Console
-#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
-#ifdef WITH_CONCURRENTOUTPUT
-withConcurrentOutput a = withOutputType go
-  where
-       go (ConcurrentOutput _) = Console.withConcurrentOutput a
-       go _ = a
-#else
-withConcurrentOutput = id
-#endif

diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 1501c072a5587fbdc779461097f5478708729069..8bbb0cfc8dafb52f9fe0230db793907f11b23c09 100644 (file)
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -1,6 +1,8 @@
-{- git-annex output messages
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- git-annex output messages, including concurrent output
  -
- - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,37 +12,32 @@
 module Messages.Internal where
 
 import Common
-import Types
+import Annex
 import Types.Messages
-import qualified Annex
 
 #ifdef WITH_CONCURRENTOUTPUT
-import System.Console.Concurrent
+import qualified System.Console.Concurrent as Console
+import qualified System.Console.Regions as Regions
+import Data.String
+import Control.Concurrent.STM
 #endif
 
+withOutputType :: (OutputType -> Annex a) -> Annex a
+withOutputType a = outputType <$> 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 (ConcurrentOutput _) = liftIO $
-#ifdef WITH_CONCURRENTOUTPUT
-               outputConcurrent s
-#else
-               q
-#endif
+       go (ConcurrentOutput _) = concurrentMessage False s q
        go JSONOutput = liftIO $ flushed json
 
 outputError :: String -> Annex ()
 outputError s = withOutputType go
   where
-       go (ConcurrentOutput _) = liftIO $
-#ifdef WITH_CONCURRENTOUTPUT
-               errorConcurrent s
-#else
-               q
-#endif
+       go (ConcurrentOutput _) = concurrentMessage True s (go NormalOutput)
        go _ = liftIO $ do
                hFlush stdout
                hPutStr stderr s
@@ -52,5 +49,76 @@ q = noop
 flushed :: IO () -> IO ()
 flushed a = a >> hFlush stdout
 
-withOutputType :: (OutputType -> Annex a) -> Annex a
-withOutputType a = outputType <$> Annex.getState Annex.output >>= a
+{- Outputs a message in a concurrency safe way.
+ -
+ - The message may be an error message, in which case it goes to stderr.
+ -
+ - When built without concurrent-output support, the fallback action is run
+ - instead.
+ -}
+concurrentMessage :: Bool -> String -> Annex () -> Annex ()
+#ifdef WITH_CONCURRENTOUTPUT
+concurrentMessage iserror msg _ = go =<< Annex.getState Annex.consoleregion
+  where
+       go Nothing
+               | iserror = liftIO $ Console.errorConcurrent msg
+               | otherwise = liftIO $ Console.outputConcurrent msg
+       go (Just r) = do
+               -- 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 }
+               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
+#ifdef WITH_CONCURRENTOUTPUT
+withConcurrentOutput a = withOutputType go
+  where
+       go (ConcurrentOutput _) = Console.withConcurrentOutput a
+       go _ = a
+#else
+withConcurrentOutput = id
+#endif
+
+{- Runs an action in its own dedicated region of the console.
+ -
+ - The region is closed at the end or on exception, and at that point
+ - the value of the region is displayed in the scrolling area above
+ - any other active regions.
+ -
+ - When not at a console, a region is not displayed until the end.
+ -}
+inOwnConsoleRegion :: Annex a -> Annex a
+#ifdef WITH_CONCURRENTOUTPUT
+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 }
+       removeregion r = do
+               errflag <- Annex.getState Annex.consoleregionerrflag
+               let h = if errflag then Console.StdErr else Console.StdOut
+               Annex.changeState $ \s -> s { Annex.consoleregionerrflag = False }
+               setregion Nothing
+               liftIO $ atomically $ do
+                       t <- Regions.getConsoleRegion r
+                       Regions.closeConsoleRegion r
+                       Console.bufferOutputSTM h $
+                               Console.toOutput (t <> fromString "\n")
+#else
+inOwnConsoleRegion = id
+#endif
+
+#ifdef WITH_CONCURRENTOUTPUT
+instance Regions.LiftRegion Annex where
+       liftRegion = liftIO . atomically
+#endif

diff --git a/git-annex.cabal b/git-annex.cabal
index f38834bfe5f8dc65cdc54b3f878bc5c95e9962f7..8430161d795746004cbcb975572d6d68ba03766e 100644 (file)
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -279,7 +279,7 @@ Executable git-annex
     CPP-Options: -DWITH_DATABASE
 
   if flag(ConcurrentOutput)
-    Build-Depends: concurrent-output (>= 1.4.1)
+    Build-Depends: concurrent-output (>= 1.5)
     CPP-Options: -DWITH_CONCURRENTOUTPUT
 
   if flag(EKG)