drop incremental json object display; clean up code

This gets rid of quite a lot of ugly hacks around json generation.

I doubt that any real-world json parsers can parse incomplete objects, so
while it's not as nice to need to wait for the complete object, especially
for commands like `git annex info` that take a while, it doesn't seem worth
the added complexity.

This also causes the order of fields within the json objects to be
reordered. Since any real json parser shouldn't care, the only possible
problem would be with ad-hoc parsers of the old json output.

2 files changed, 62 insertions, 51 deletions

diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 2c9a461a5..7ea8ee067 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -13,44 +13,39 @@ import Types.Messages
 import Messages.Concurrent
 import Messages.JSON
 
-import qualified Data.ByteString.Lazy as B
 
 withMessageState :: (MessageState -> Annex a) -> Annex a
 withMessageState a = Annex.getState Annex.output >>= a
 
-outputMessage :: JSONChunk -> String -> Annex ()
-outputMessage = outputMessage' False
-
-outputMessageFinal :: JSONChunk -> String -> Annex ()
-outputMessageFinal = outputMessage' True
-
-outputMessage' :: Bool -> JSONChunk -> String -> Annex ()
-outputMessage' endmessage json msg = withMessageState $ \s -> case outputType s of
+outputMessage :: JSONBuilder -> String -> Annex ()
+outputMessage jsonbuilder msg = withMessageState $ \s -> case outputType s of
 	NormalOutput
 		| concurrentOutputEnabled s -> concurrentMessage s False msg q
 		| otherwise -> liftIO $ flushed $ putStr msg
-	JSONOutput _ -> void $ outputJSON json endmessage s
+	JSONOutput _ -> void $ outputJSON jsonbuilder s
 	QuietOutput -> q
 
-outputJSON :: JSONChunk -> Bool -> MessageState -> Annex Bool
-outputJSON json endmessage s = case outputType s of
-	JSONOutput withprogress
-		| withprogress || concurrentOutputEnabled s -> do
-			-- Buffer json fragments until end is reached.
-			if endmessage
-				then do
-					Annex.changeState $ \st -> 
-						st { Annex.output = s { jsonBuffer = none } }
-					liftIO $ flushed $ emit b
-				else Annex.changeState $ \st ->
-				        st { Annex.output = s { jsonBuffer = b } }
+-- Buffer changes to JSON until end is reached and then emit it.
+outputJSON :: JSONBuilder -> MessageState -> Annex Bool
+outputJSON jsonbuilder s = case outputType s of
+	JSONOutput _
+		| endjson -> do
+			Annex.changeState $ \st -> 
+				st { Annex.output = s { jsonBuffer = Nothing } }
+			maybe noop (liftIO . flushed . emit) json
 			return True
 		| otherwise -> do
-			liftIO $ flushed $ emit json
+			Annex.changeState $ \st ->
+			        st { Annex.output = s { jsonBuffer = json } }
 			return True
 	_ -> return False
   where
-	b = jsonBuffer s `B.append` json
+	(json, endjson) = case jsonbuilder i of
+		Nothing -> (jsonBuffer s, False)
+		(Just (j, e)) -> (Just j, e)
+	i = case jsonBuffer s of
+		Nothing -> Nothing
+		Just b -> Just (b, False)
 
 outputError :: String -> Annex ()
 outputError msg = withMessageState $ \s ->
diff --git a/Messages/JSON.hs b/Messages/JSON.hs
index e8491c691..6c22d9537 100644
--- a/Messages/JSON.hs
+++ b/Messages/JSON.hs
@@ -5,10 +5,11 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, GADTs #-}
 
 module Messages.JSON (
-	JSONChunk,
+	JSONBuilder,
+	JSONChunk(..),
 	emit,
 	none,
 	start,
@@ -27,6 +28,7 @@ import Control.Applicative
 import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.ByteString.Lazy as B
+import qualified Data.HashMap.Strict as HM
 import System.IO
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
@@ -34,29 +36,31 @@ import Data.Maybe
 import Data.Monoid
 import Prelude
 
-import qualified Utility.JSONStream as Stream
 import Types.Key
 import Utility.Metered
 import Utility.Percentage
 
-type JSONChunk = B.ByteString
-
 -- A global lock to avoid concurrent threads emitting json at the same time.
 {-# NOINLINE emitLock #-}
 emitLock :: MVar ()
 emitLock = unsafePerformIO $ newMVar ()
 
-emit :: JSONChunk -> IO ()
-emit v = do
+emit :: Object -> IO ()
+emit o = do
 	takeMVar emitLock
-	B.hPut stdout v
+	B.hPut stdout (encode o)
+	putStr "\n"
 	putMVar emitLock ()
 
-none :: JSONChunk
-none = B.empty
+-- Building up a JSON object can be done by first using start,
+-- then add and note any number of times, and finally complete.
+type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)
+
+none :: JSONBuilder
+none = id
 
-start :: String -> Maybe FilePath -> Maybe Key -> JSONChunk
-start command file key = Stream.start $ Stream.AesonObject o
+start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder
+start command file key _ = Just (o, False)
   where
 	Object o = toJSON $ JSONActionItem
 		{ itemCommand = Just command
@@ -65,24 +69,36 @@ start command file key = Stream.start $ Stream.AesonObject o
 		, itemAdded = Nothing
 		}
 
-end :: Bool -> JSONChunk
-end b =Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end
+end :: Bool -> JSONBuilder
+end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True)
+end _ Nothing = Nothing
 
-note :: String -> JSONChunk
-note s = add (Stream.JSONChunk [("note", s)])
+note :: String -> JSONBuilder
+note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e)
+note _ Nothing = Nothing
 
-add :: Stream.JSONChunk a -> JSONChunk
-add = Stream.add
+data JSONChunk v where
+	AesonObject :: Object -> JSONChunk Object
+	JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)]
 
-complete :: Stream.JSONChunk a -> JSONChunk
-complete v = Stream.start v `B.append` Stream.end
-
-progress :: B.ByteString -> Integer -> BytesProcessed -> IO ()
-progress jsonbuffer size bytesprocessed = emit $ B.concat
-	[ Stream.start $ Stream.AesonObject o
-	, Stream.addNestedObject "action" jsonbuffer
-	, Stream.end
-	]
+add :: JSONChunk v -> JSONBuilder
+add v (Just (o, e)) = Just (HM.union o' o, e)
+  where
+	Object o' = case v of
+		AesonObject ao -> Object ao
+		JSONChunk l -> object (map mkPair l)
+	mkPair (s, d) = (T.pack s, toJSON d)
+add _ Nothing = Nothing
+
+complete :: JSONChunk v -> JSONBuilder
+complete v _ = add v (Just (HM.empty, True))
+
+-- Show JSON formatted progress, including the current state of the JSON 
+-- object for the action being performed.
+progress :: Maybe Object -> Integer -> BytesProcessed -> IO ()
+progress maction size bytesprocessed = emit $ case maction of
+	Just action -> HM.insert "action" (Object action) o
+	Nothing -> o
   where
 	n = fromBytesProcessed bytesprocessed :: Integer
 	Object o = object