use built-in progress meters for git when in parallel mode

5 files changed, 22 insertions, 9 deletions

diff --git a/Messages.hs b/Messages.hs
index 0e83a7243..d8be718cc 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -190,6 +190,6 @@ disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE
 commandProgressDisabled :: Annex Bool
 commandProgressDisabled = withOutputType $ \t -> return $ case t of
 	QuietOutput -> True
-	ProgressOutput -> True
+	ParallelOutput _ -> True
 	JSONOutput -> True
 	NormalOutput -> False
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 1dd856b5e..2495f4fd3 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -17,7 +17,7 @@ handleMessage json normal = withOutputType go
   where
 	go NormalOutput = liftIO normal
 	go QuietOutput = q
-	go ProgressOutput = q
+	go (ParallelOutput _) = q
 	go JSONOutput = liftIO $ flushed json
 
 q :: Monad m => m ()
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index c563ffa6f..70ed96c5a 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -26,6 +26,14 @@ metered combinemeterupdate key a = go (keySize key)
 	go (Just size) = meteredBytes combinemeterupdate size a
 	go _ = a (const noop)
 
+{- Use when the progress meter is only desired for parallel
+ - mode; as when a command's own progress output is preferred. -}
+parallelMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
+parallelMetered combinemeterupdate key a = withOutputType go
+  where
+	go (ParallelOutput _) = metered combinemeterupdate key a
+	go _ = a (fromMaybe (const noop) combinemeterupdate)
+
 {- Shows a progress meter while performing an action on a given number
  - of bytes. -}
 meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
@@ -99,5 +107,5 @@ mkStderrRelayer = do
 mkStderrEmitter :: Annex (String -> IO ())
 mkStderrEmitter = withOutputType go
   where
-	go ProgressOutput = return $ \s -> hPutStrLn stderr ("E: " ++ s)
+	go (ParallelOutput _) = return $ \s -> hPutStrLn stderr ("E: " ++ s)
 	go _ = return (hPutStrLn stderr)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index abefc113e..b04d381a8 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -52,6 +52,7 @@ import qualified Remote.GCrypt
 import Annex.Path
 import Creds
 import Annex.CatFile
+import Messages.Progress
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
@@ -354,9 +355,11 @@ dropKey r key
 
 {- Tries to copy a key's content from a remote's annex to a file. -}
 copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-copyFromRemote r key file dest _p = copyFromRemote' r key file dest
-copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
-copyFromRemote' r key file dest
+copyFromRemote r key file dest p = metered (Just p) key $
+	copyFromRemote' r key file dest
+
+copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
+copyFromRemote' r key file dest meterupdate
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do
 		params <- Ssh.rsyncParams r Download
 		u <- getUUID
@@ -434,7 +437,9 @@ copyFromRemote' r key file dest
 			send bytes
 			forever $
 				send =<< readSV v
-		let feeder = writeSV v . fromBytesProcessed
+		let feeder = \n -> do
+			meterupdate n
+			writeSV v (fromBytesProcessed n)
 		let cleanup = do
 			void $ tryIO $ killThread tid
 			tryNonAsync $
@@ -451,7 +456,7 @@ copyFromRemoteCheap r key file
 		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
 	| Git.repoIsSsh (repo r) =
 		ifM (Annex.Content.preseedTmp key file)
-			( copyFromRemote' r key Nothing file
+			( metered Nothing key $ copyFromRemote' r key Nothing file
 			, return False
 			)
 	| otherwise = return False
diff --git a/Types/Messages.hs b/Types/Messages.hs
index a437d86ef..c3696c015 100644
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -9,7 +9,7 @@ module Types.Messages where
 
 import Data.Default
 
-data OutputType = NormalOutput | QuietOutput | ProgressOutput | JSONOutput
+data OutputType = NormalOutput | QuietOutput | ParallelOutput Int | JSONOutput
 
 data SideActionBlock = NoBlock | StartBlock | InBlock
 	deriving (Eq)