Add a flag to emit error messages as JSON

This patch adds the flag `-ddump-json` which dumps all the compiler
output as a JSON array. This allows tooling to more easily parse GHC's
output to display to users.

The flag is currently experimental and will hopefully be refined for the
next release.  In particular I have avoided any changes which involve
significant refactoring and provided what is easy given the current
infrastructure.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: DanielG, gracjan, thomie

Differential Revision: https://phabricator.haskell.org/D3010

GHC Trac Issues: #13190

1 files changed, 54 insertions, 0 deletions

diff --git a/compiler/utils/Json.hs b/compiler/utils/Json.hs
new file mode 100644
index 0000000000..1318ce2611
--- /dev/null
+++ b/compiler/utils/Json.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE GADTs #-}
+module Json where
+
+import Outputable
+import Data.Char
+import Numeric
+
+-- | Simple data type to represent JSON documents.
+data JsonDoc where
+  JSNull :: JsonDoc
+  JSBool :: Bool -> JsonDoc
+  JSInt  :: Int  -> JsonDoc
+  JSString :: String -> JsonDoc
+  JSArray :: [JsonDoc] -> JsonDoc
+  JSObject :: [(String, JsonDoc)] -> JsonDoc
+
+
+-- This is simple and slow as it is only used for error reporting
+renderJSON :: JsonDoc -> SDoc
+renderJSON d =
+  case d of
+    JSNull -> text "null"
+    JSBool b -> text $ if b then "true" else "false"
+    JSInt    n -> ppr n
+    JSString s -> doubleQuotes $ text $ escapeJsonString s
+    JSArray as -> brackets $ pprList renderJSON as
+    JSObject fs -> braces $ pprList renderField fs
+  where
+    renderField :: (String, JsonDoc) -> SDoc
+    renderField (s, j) = doubleQuotes (text s) <>  colon <+> renderJSON j
+
+    pprList pp xs = hcat (punctuate comma (map pp xs))
+
+escapeJsonString :: String -> String
+escapeJsonString = concatMap escapeChar
+  where
+    escapeChar '\b' = "\\b"
+    escapeChar '\f' = "\\f"
+    escapeChar '\n' = "\\n"
+    escapeChar '\r' = "\\r"
+    escapeChar '\t' = "\\t"
+    escapeChar '"'  = "\""
+    escapeChar '\\'  = "\\\\"
+    escapeChar c | isControl c || fromEnum c >= 0x7f  = uni_esc c
+    escapeChar c = [c]
+
+    uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) ""))
+
+    pad n cs  | len < n   = replicate (n-len) '0' ++ cs
+                          | otherwise = cs
+                                   where len = length cs
+
+class ToJson a where
+  json :: a -> JsonDoc