From f138e4868295bc5fb354fbd82d4971b691136597 Mon Sep 17 00:00:00 2001
From: Fendor <power.walross@gmail.com>
Date: Mon, 12 Jul 2021 10:32:01 +0200
Subject: [PATCH] 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.
---
 .../src/Distribution/Simple/ShowBuildInfo.hs  |  3 +-
 Cabal/src/Distribution/Simple/Utils/Json.hs   | 50 --------------
 Cabal/src/Distribution/Utils/Json.hs          | 65 +++++++++++++++++++
 3 files changed, 66 insertions(+), 52 deletions(-)
 delete mode 100644 Cabal/src/Distribution/Simple/Utils/Json.hs
 create mode 100644 Cabal/src/Distribution/Utils/Json.hs

diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs
index 8c75cd7bc91..0ea6f96a7b9 100644
--- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Utils/Json.hs b/Cabal/src/Distribution/Simple/Utils/Json.hs
deleted file mode 100644
index ba918b74880..00000000000
--- a/Cabal/src/Distribution/Simple/Utils/Json.hs
+++ /dev/null
@@ -1,50 +0,0 @@
--- | Extremely simple JSON helper. Don't do anything too fancy with this!
-
-module Distribution.Utils.Json
-    ( Json(..)
-    , (.=)
-    , renderJson
-    ) where
-
-data Json = JsonArray [Json]
-          | JsonBool !Bool
-          | JsonNull
-          | JsonNumber !Int
-          | JsonObject [(String, Json)]
-          | JsonString !String
-
-renderJson :: Json -> ShowS
-renderJson (JsonArray objs)   =
-  surround "[" "]" $ intercalate "," $ map renderJson objs
-renderJson (JsonBool True)    = showString "true"
-renderJson (JsonBool False)   = showString "false"
-renderJson  JsonNull          = showString "null"
-renderJson (JsonNumber n)     = shows n
-renderJson (JsonObject attrs) =
-  surround "{" "}" $ intercalate "," $ map render attrs
-  where
-    render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v
-renderJson (JsonString s)     = surround "\"" "\"" $ showString' s
-
-surround :: String -> String -> ShowS -> ShowS
-surround begin end middle = showString begin . middle . showString end
-
-showString' :: String -> ShowS
-showString' xs = showStringWorker xs
-    where
-        showStringWorker :: String -> ShowS
-        showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as
-        showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as
-        showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as
-        showStringWorker (x:as) = showString [x] . showStringWorker as
-        showStringWorker [] = showString ""
-
-intercalate :: String -> [ShowS] -> ShowS
-intercalate sep = go
-  where
-    go []     = id
-    go [x]    = x
-    go (x:xs) = x . showString' sep . go xs
-
-(.=) :: String -> Json -> (String, Json)
-k .= v = (k, v)
diff --git a/Cabal/src/Distribution/Utils/Json.hs b/Cabal/src/Distribution/Utils/Json.hs
new file mode 100644
index 00000000000..15573c9c05a
--- /dev/null
+++ b/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)