Port JSON module to Text based implementation

Changes the internal representation of JSON to Text rather than
String, and introduces the buildinfo-components-only flag in the Cabal
part to make it easier to stitch back the JSON into an array in
cabal-install.

Cabal/src/Distribution/Simple/ShowBuildInfo.hs

@@ -79,7 +79,6 @@ import Distribution.Utils.Json
 import Distribution.Types.TargetInfo
 import Distribution.Text
 import Distribution.Pretty
-import Distribution.Utils.Path
 
 -- | Construct a JSON document describing the build information for a
 -- package.
@@ -133,7 +132,7 @@ mkComponentInfo wdir pkg_descr lbi clbi = JsonObject $
   , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
   , "modules"       .= JsonArray (map (JsonString . T.pack . display) modules)
   , "src-files"     .= JsonArray (map (JsonString . T.pack) sourceFiles)
-  , "hs-src-dirs"   .= JsonArray (map (JsonString . T.pack) $ hsSourceDirs bi)
+  , "hs-src-dirs"   .= JsonArray (map (JsonString . T.pack . prettyShow) $ hsSourceDirs bi)
   , "src-dir"       .= JsonString (T.pack wdir)
   ] <> cabalFile
   where

Cabal/src/Distribution/Utils/Json.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Extremely simple JSON helper. Don't do anything too fancy with this!
+module Distribution.Utils.Json
+    ( Json(..)
+    , (.=)
+    , renderJson
+    ) where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+data Json = JsonArray [Json]
+          | JsonBool !Bool
+          | JsonNull
+          | JsonNumber !Int
+          | JsonObject [(Text, Json)]
+          | JsonRaw !Text
+          | JsonString !Text
+
+-- | A type to mirror 'ShowS'
+type ShowT = Text -> Text
+
+renderJson :: Json -> ShowT
+renderJson (JsonArray objs)   =
+  surround "[" "]" $ intercalate "," $ map renderJson objs
+renderJson (JsonBool True)    = showText "true"
+renderJson (JsonBool False)   = showText "false"
+renderJson  JsonNull          = showText "null"
+renderJson (JsonNumber n)     = showText $ Text.pack (show n)
+renderJson (JsonObject attrs) =
+  surround "{" "}" $ intercalate "," $ map render attrs
+  where
+    render (k,v) = (surround "\"" "\"" $ showText' k) . showText ":" . renderJson v
+renderJson (JsonString s)     = surround "\"" "\"" $ showText' s
+renderJson (JsonRaw s)        = showText s
+
+surround :: Text -> Text -> ShowT -> ShowT
+surround begin end middle = showText begin . middle . showText end
+
+showText :: Text -> ShowT
+showText = (<>)
+
+showText' :: Text -> ShowT
+showText' xs = showStringWorker xs
+  where
+      showStringWorker :: Text -> ShowT
+      showStringWorker t =
+        case Text.uncons t of
+          Just ('\r', as) -> showText "\\r" . showStringWorker as
+          Just ('\n', as) -> showText "\\n" . showStringWorker as
+          Just ('\"', as) -> showText "\\\"" . showStringWorker as
+          Just ('\\', as) -> showText "\\\\" . showStringWorker as
+          Just (x,    as) -> showText (Text.singleton x) . showStringWorker as
+          Nothing         -> showText ""
+
+intercalate :: Text -> [ShowT] -> ShowT
+intercalate sep = go
+  where
+    go []     = id
+    go [x]    = x
+    go (x:xs) = x . showText' sep . go xs
+
+(.=) :: Text -> Json -> (Text, Json)
+k .= v = (k, v)