Concurrent progress bars are now displayed when using -J with a command that moves file contents around.

Messages/Concurrent.hs

@@ -98,7 +98,13 @@ inOwnConsoleRegion a = do
 inOwnConsoleRegion = id
 #endif
 
+{- The progress region is displayed inline with the current console region. -}
 #ifdef WITH_CONCURRENTOUTPUT
+withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a
+withProgressRegion a = do
+	parent <- consoleRegion <$> Annex.getState Annex.output
+	Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a
+
 instance Regions.LiftRegion Annex where
 	liftRegion = liftIO . atomically
 #endif

Messages/Progress.hs

@@ -18,10 +18,11 @@ import Types.Messages
 import Types.Key
 
 #ifdef WITH_CONCURRENTOUTPUT
-import System.Console.Concurrent
+import Messages.Concurrent
-import System.Console.Regions
+import qualified System.Console.Regions as Regions
-import Control.Concurrent
+import qualified System.Console.Concurrent as Console
 #endif
+
 import Data.Progress.Meter
 import Data.Progress.Tracker
 import Data.Quantity
@@ -29,65 +30,37 @@ import Data.Quantity
 {- Shows a progress meter while performing a transfer of a key.
  - The action is passed a callback to use to update the meter. -}
 metered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
-metered combinemeterupdate key af a = case keySize key of
+metered combinemeterupdate key _af a = case keySize key of
 	Nothing -> nometer
 	Just size -> withOutputType (go $ fromInteger size)
   where
 	go _ QuietOutput = nometer
 	go _ JSONOutput = nometer
-#if 0
-	go size _ = do
-		showOutput
-		liftIO $ putStrLn ""
-
-		cols <- liftIO $ maybe 79 Terminal.width <$> Terminal.size
-		let desc = truncatepretty cols $ fromMaybe (key2file key) af
-
-		result <- liftIO newEmptyMVar
-		pg <- liftIO $ newProgressBar def
-			{ pgWidth = cols
-			, pgFormat = desc ++ " :percent :bar ETA :eta"
-			, pgTotal = size
-			, pgOnCompletion = do
-				ok <- takeMVar result
-				putStrLn $ desc ++ " " ++ endResult ok
-			}
-		r <- a $ liftIO . pupdate pg
-
-		liftIO $ do
-			-- See if the progress bar is complete or not.
-			sofar <- stCompleted <$> getProgressStats pg
-			putMVar result (sofar >= size)
-			-- May not be actually complete if the action failed,
-			-- but this just clears the progress bar.
-			complete pg
-
-		return r
-#else
-	-- Old progress bar code, not suitable for concurrent output.
-	go _ (ConcurrentOutput _) = nometer
 	go size NormalOutput = do
 		showOutput
-		progress <- liftIO $ newProgress "" size
+		(progress, meter) <- mkmeter size
-		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
+		r <- a $ \n -> liftIO $ do
-		r <- a $ liftIO . pupdate meter progress
+			setP progress $ fromBytesProcessed n
+			displayMeter stdout meter
+			maybe noop (\m -> m n) combinemeterupdate
 		liftIO $ clearMeter stdout meter
 		return r
+#if WITH_CONCURRENTOUTPUT
+	go size (ConcurrentOutput _) = withProgressRegion $ \r -> do
+		(progress, meter) <- mkmeter size
+		a $ \n -> liftIO $ do
+			setP progress $ fromBytesProcessed n
+			s <- renderMeter meter
+			Regions.setConsoleRegion r ("\n" ++ s)
+			maybe noop (\m -> m n) combinemeterupdate
+#else
+	go _ (ConcurrentOutput _) = nometer
 #endif
 
-#if 0
+	mkmeter size = do
-	pupdate pg n = do
+		progress <- liftIO $ newProgress "" size
-		let i = fromBytesProcessed n
+		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
-		sofar <- stCompleted <$> getProgressStats pg
+		return (progress, meter)
-		when (i > sofar) $
-			tickN pg (i - sofar)
-		threadDelay 100
-#else
-	pupdate meter progress n = do
-		setP progress $ fromBytesProcessed n
-		displayMeter stdout meter
-#endif
-		maybe noop (\m -> m n) combinemeterupdate
 
 	nometer = a (const noop)
 
@@ -139,6 +112,6 @@ mkStderrEmitter :: Annex (String -> IO ())
 mkStderrEmitter = withOutputType go
   where
 #ifdef WITH_CONCURRENTOUTPUT
-	go (ConcurrentOutput _) = return errorConcurrent
+	go (ConcurrentOutput _) = return Console.errorConcurrent
 #endif
 	go _ = return (hPutStrLn stderr)

debian/changelog

@@ -6,6 +6,8 @@ git-annex (5.20151102.2) UNRELEASED; urgency=medium
     fsck, drop, add, addurl, import
   * import: Avoid very ugly error messages when the directory files
     are imported to is not a directort, but perhaps an annexed file.
+  * Concurrent progress bars are now displayed when using -J with a command
+    that moves file contents around.
 
  -- Joey Hess <id@joeyh.name>  Wed, 04 Nov 2015 12:50:20 -0400