allow using Aeson for streaming JSON output

Keeping Text.JSON use for now, because it seems a better fit for most of
the commands, which don't use very structured JSON objects, but just output
whatever fields suites them. But this lets Aeson be used when a more
structured data type is available to serialize to JSON.

Command/Add.hs

@@ -146,7 +146,7 @@ perform file = do
 
 cleanup :: Key -> Bool -> CommandCleanup
 cleanup key hascontent = do
-	maybeShowJSON [("key", key2file key)]
+	maybeShowJSON $ JSONObject [("key", key2file key)]
 	when hascontent $
 		logStatus key InfoPresent
 	return True

Command/AddUrl.hs

@@ -356,7 +356,7 @@ cleanup u url file key mtmp = case mtmp of
 			)
   where
 	go = do
-		maybeShowJSON [("key", key2file key)]
+		maybeShowJSON $ JSONObject [("key", key2file key)]
 		when (isJust mtmp) $
 			logStatus key InfoPresent
 		setUrlPresent u key url

Command/Find.hs

@@ -66,7 +66,7 @@ start o file key = ifM (limited <||> inAnnex key)
 
 showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex ()
 showFormatted format unformatted vars =
-	unlessM (showFullJSON vars) $
+	unlessM (showFullJSON $ JSONObject vars) $
 		case format of
 			Nothing -> liftIO $ putStrLn unformatted
 			Just formatter -> liftIO $ putStr $

Command/Info.hs

@@ -250,7 +250,7 @@ nostat = return Nothing
 json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
 json fmt a desc = do
 	j <- a
-	lift $ maybeShowJSON [(desc, j)]
+	lift $ maybeShowJSON $ JSONObject [(desc, j)]
 	return $ fmt j
 
 nojson :: StatState String -> String -> StatState String
@@ -374,7 +374,7 @@ transfer_list :: Stat
 transfer_list = stat desc $ nojson $ lift $ do
 	uuidmap <- Remote.remoteMap id
 	ts <- getTransfers
-	maybeShowJSON [(desc, map (uncurry jsonify) ts)]
+	maybeShowJSON $ JSONObject [(desc, map (uncurry jsonify) ts)]
 	return $ if null ts
 		then "none"
 		else multiLine $

Command/MetaData.hs

@@ -96,7 +96,7 @@ perform now o k = case getSet o of
 cleanup :: Key -> CommandCleanup
 cleanup k = do
 	l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k
-	maybeShowJSON l
+	maybeShowJSON (JSONObject l)
 	showLongNote $ unlines $ concatMap showmeta l
 	return True
   where

Command/Status.hs

@@ -43,7 +43,7 @@ displayStatus s  = do
 	let c = statusChar s
 	absf <- fromRepo $ fromTopFilePath (statusFile s)
 	f <- liftIO $ relPathCwdToFile absf
-	unlessM (showFullJSON [("status", [c]), ("file", f)]) $
+	unlessM (showFullJSON $ JSONObject [("status", [c]), ("file", f)]) $
 		liftIO $ putStrLn $ [c] ++ " " ++ f
 
 -- Git thinks that present direct mode files are typechanged.

Messages.hs

@@ -29,6 +29,7 @@ module Messages (
 	earlyWarning,
 	warningIO,
 	indent,
+	JSONChunk(..),
 	maybeShowJSON,
 	showFullJSON,
 	showCustom,
@@ -43,7 +44,6 @@ module Messages (
 	implicitMessage,
 ) where
 
-import Text.JSON
 import System.Log.Logger
 import System.Log.Formatter
 import System.Log.Handler (setFormatter)
@@ -55,6 +55,7 @@ import Types.Messages
 import Git.FilePath
 import Messages.Internal
 import qualified Messages.JSON as JSON
+import Utility.JSONStream (JSONChunk(..))
 import Types.Key
 import qualified Annex
 
@@ -181,15 +182,15 @@ warningIO w = do
 indent :: String -> String
 indent = intercalate "\n" . map (\l -> "  " ++ l) . lines
 
-{- Shows a JSON fragment only when in json mode. -}
-maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
+{- Shows a JSON chunk only when in json mode. -}
+maybeShowJSON :: JSONChunk v -> Annex ()
 maybeShowJSON v = withOutputType $ liftIO . go
   where
 	go JSONOutput = JSON.add v
 	go _ = return ()
 
 {- Shows a complete JSON value, only when in json mode. -}
-showFullJSON :: JSON a => [(String, a)] -> Annex Bool
+showFullJSON :: JSONChunk v -> Annex Bool
 showFullJSON v = withOutputType $ liftIO . go
   where
 	go JSONOutput = JSON.complete v >> return True

Messages/JSON.hs

@@ -1,6 +1,6 @@
-{- git-annex JSON output
+{- git-annex command-line JSON output and input
  -
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -21,7 +21,7 @@ import Types.Key
 import Data.Maybe
 
 start :: String -> Maybe FilePath -> Maybe Key -> IO ()
-start command file key = putStr $ Stream.start $ catMaybes
+start command file key = putStr $ Stream.start $ Stream.JSONObject $ catMaybes
 	[ part "command" (Just command)
 	, part "file" file
 	, part "key" (fmap key2file key)
@@ -31,15 +31,15 @@ start command file key = putStr $ Stream.start $ catMaybes
 	part l (Just v) = Just (l, v)
 
 end :: Bool -> IO ()
-end b = putStr $ Stream.add [("success", b)] ++ Stream.end
+end b = putStr $ Stream.add (Stream.JSONObject [("success", b)]) ++ Stream.end
 
 note :: String -> IO ()
-note s = add [("note", s)]
+note s = add (Stream.JSONObject [("note", s)])
 
-add :: JSON a => [(String, a)] -> IO ()
-add v = putStr $ Stream.add v
+add :: Stream.JSONChunk a -> IO ()
+add = putStr . Stream.add
 
-complete :: JSON a => [(String, a)] -> IO ()
+complete :: Stream.JSONChunk a -> IO ()
 complete v = putStr $ Stream.start v ++ Stream.end
 
 -- A value that can be displayed either normally, or as JSON.

Remote.hs

@@ -72,6 +72,7 @@ import Remote.List
 import Config
 import Git.Types (RemoteName)
 import qualified Git
+import Utility.JSONStream
 
 {- Map from UUIDs of Remotes to a calculated value. -}
 remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
@@ -203,7 +204,7 @@ prettyPrintUUIDsWith
 	-> Annex String
 prettyPrintUUIDsWith optfield header descm showval uuidvals = do
 	hereu <- getUUID
-	maybeShowJSON [(header, map (jsonify hereu) uuidvals)]
+	maybeShowJSON $ JSONObject [(header, map (jsonify hereu) uuidvals)]
 	return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals
   where
 	finddescription u = M.findWithDefault "" u descm

Utility/JSONStream.hs

@@ -1,35 +1,51 @@
 {- Streaming JSON output.
  -
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011, 2016 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
+{-# LANGUAGE GADTs #-}
+
 module Utility.JSONStream (
+	JSONChunk(..),
 	start,
 	add,
 	end
 ) where
 
-import Text.JSON
+import qualified Text.JSON as JSON
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.UTF8 as B
 
-{- Text.JSON does not support building up a larger JSON document piece by
- - piece as a stream. To support streaming, a hack. The JSObject is converted
- - to a string with its final "}" is left off, allowing it to be added to
- - later. -}
-start :: JSON a => [(String, a)] -> String
-start l
+{- Only JSON objects can be used as chunks in the stream, not
+ - other values.
+ -
+ - Both Aeson and Text.Json objects are supported. -}
+data JSONChunk a where
+	JSONObject :: JSON.JSON a => [(String, a)] -> JSONChunk [(String, a)]
+	AesonObject :: Aeson.Object -> JSONChunk Aeson.Object
+
+encodeJSONChunk :: JSONChunk a -> String
+encodeJSONChunk (JSONObject l) = JSON.encodeStrict $ JSON.toJSObject l
+encodeJSONChunk (AesonObject o) = B.toString (Aeson.encode o)
+
+{- Text.JSON and Aeson do not support building up a larger JSON document
+ - piece by piece as a stream. To support streaming, a hack. The final "}" 
+ - is left off the object, allowing it to be added to later. -}
+start :: JSONChunk a -> String
+start a
 	| last s == endchar = init s
 	| otherwise = bad s
   where
-	s = encodeStrict $ toJSObject l
+	s = encodeJSONChunk a
 
-add :: JSON a => [(String, a)] -> String
-add l
+add :: JSONChunk a -> String
+add a
 	| head s == startchar = ',' : drop 1 s
 	| otherwise = bad s
   where
-	s = start l
+	s = start a
 
 end :: String
 end = [endchar, '\n']
@@ -41,4 +57,5 @@ endchar :: Char
 endchar = '}'
 
 bad :: String -> a
-bad s = error $ "Text.JSON returned unexpected string: " ++ s
+bad s = error $ "JSON encoder generated unexpected value: " ++ s
+