addurl, get: Added --json-progress option, which adds progress objects to the json output.

This doesn't work right when used with -J yet, and there is some really
ugly hand-crafting of part of the json output.

1 files changed, 7 insertions, 1 deletions

diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index fa11c1304..a48e7b07e 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -16,6 +16,7 @@ import Utility.Metered
 import Types
 import Types.Messages
 import Types.Key
+import qualified Messages.JSON as JSON
 
 #ifdef WITH_CONCURRENTOUTPUT
 import Messages.Concurrent
@@ -35,7 +36,6 @@ metered othermeter key a = case keySize key of
 	Just size -> withMessageState (go $ fromInteger size)
   where
 	go _ (MessageState { outputType = QuietOutput }) = nometer
-	go _ (MessageState { outputType = JSONOutput }) = nometer
 	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
 		showOutput
 		(progress, meter) <- mkmeter size
@@ -57,6 +57,12 @@ metered othermeter key a = case keySize key of
 #else
 		nometer
 #endif
+	go _ (MessageState { outputType = JSONOutput False }) = nometer
+	go size (MessageState { outputType = JSONOutput True }) = do
+		buf <- withMessageState $ return . showJSONBuffer
+		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $
+			JSON.progress buf size
+		a (combinemeter m)
 
 	mkmeter size = do
 		progress <- liftIO $ newProgress "" size