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

16 files changed, 220 insertions, 4 deletions

diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 06f42cc8de..f71dac6273 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE DeriveFoldable     #-}
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE RecordWildCards    #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
    -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
    -- When the earliest compiler we want to boostrap with is
@@ -81,6 +82,7 @@ module SrcLoc (
     ) where
 
 import Util
+import Json
 import Outputable
 import FastString
 
@@ -246,6 +248,18 @@ data SrcSpan =
   deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
                            -- derive Show for Token
 
+instance ToJson SrcSpan where
+  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
+  json (RealSrcSpan rss)  = json rss
+
+instance ToJson RealSrcSpan where
+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
+                                     , ("startLine", JSInt srcSpanSLine)
+                                     , ("startCol", JSInt srcSpanSCol)
+                                     , ("endLine", JSInt srcSpanELine)
+                                     , ("endCol", JSInt srcSpanECol)
+                                     ]
+
 instance NFData SrcSpan where
   rnf x = x `seq` ()
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index dea0be5ad1..1da783dff3 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -490,6 +490,7 @@ Library
         GraphOps
         GraphPpr
         IOEnv
+        Json
         ListSetOps
         ListT
         Maybes
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 37a026c722..d8e3a52008 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -493,6 +493,7 @@ compiler_stage2_dll0_MODULES = \
 	IdInfo \
 	IfaceSyn \
 	IfaceType \
+	Json 		\
 	ToIface \
 	InstEnv \
 	Kind \
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c504deebbd..4c4002d83e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -177,7 +177,8 @@ import Outputable
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
-                               , getCaretDiagnostic )
+                               , getCaretDiagnostic, dumpSDoc )
+import Json
 import SysTools.Terminal ( stderrSupportsAnsiColors )
 
 import System.IO.Unsafe ( unsafePerformIO )
@@ -379,6 +380,7 @@ data DumpFlag
    | Opt_D_dump_view_pattern_commoning
    | Opt_D_verbose_core2core
    | Opt_D_dump_debug
+   | Opt_D_dump_json
 
    deriving (Eq, Show, Enum)
 
@@ -569,6 +571,10 @@ data WarnReason = NoReason | Reason !WarningFlag
 instance Outputable WarnReason where
   ppr = text . show
 
+instance ToJson WarnReason where
+  json NoReason = JSNull
+  json (Reason wf) = JSString (show wf)
+
 data WarningFlag =
 -- See Note [Updating flag description in the User's Guide]
      Opt_WarnDuplicateExports
@@ -862,7 +868,9 @@ data DynFlags = DynFlags {
   ghciHistSize          :: Int,
 
   -- | MsgDoc output action: use "ErrUtils" instead of this if you can
+  initLogAction         :: IO (Maybe LogOutput),
   log_action            :: LogAction,
+  log_finaliser         :: LogFinaliser,
   flushOut              :: FlushOut,
   flushErr              :: FlushErr,
 
@@ -1629,7 +1637,13 @@ defaultDynFlags mySettings =
 
         ghciHistSize = 50, -- keep a log of length 50 by default
 
+        -- Logging
+
+        initLogAction = defaultLogOutput,
+
         log_action = defaultLogAction,
+        log_finaliser = \ _ -> return (),
+
         flushOut = defaultFlushOut,
         flushErr = defaultFlushErr,
         pprUserLength = 5,
@@ -1682,9 +1696,30 @@ interpreterDynamic dflags
   | otherwise = dynamicGhc
 
 --------------------------------------------------------------------------
+--
+-- Note [JSON Error Messages]
+--
+-- When the user requests the compiler output to be dumped as json
+-- we modify the log_action to collect all the messages in an IORef
+-- and then finally in GHC.withCleanupSession the log_finaliser is
+-- called which prints out the messages together.
+--
+-- Before the compiler calls log_action, it has already turned the `ErrMsg`
+-- into a formatted message. This means that we lose some possible
+-- information to provide to the user but refactoring log_action is quite
+-- invasive as it is called in many places. So, for now I left it alone
+-- and we can refine its behaviour as users request different output.
 
 type FatalMessager = String -> IO ()
 
+data LogOutput = LogOutput
+               { getLogAction :: LogAction
+               , getLogFinaliser :: LogFinaliser
+               }
+
+defaultLogOutput :: IO (Maybe LogOutput)
+defaultLogOutput = return $ Nothing
+
 type LogAction = DynFlags
               -> WarnReason
               -> Severity
@@ -1693,9 +1728,43 @@ type LogAction = DynFlags
               -> MsgDoc
               -> IO ()
 
+type LogFinaliser = DynFlags -> IO ()
+
 defaultFatalMessager :: FatalMessager
 defaultFatalMessager = hPutStrLn stderr
 
+
+-- See Note [JSON Error Messages]
+jsonLogOutput :: IO (Maybe LogOutput)
+jsonLogOutput = do
+  ref <- newIORef []
+  return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref)
+
+jsonLogAction :: IORef [SDoc] -> LogAction
+jsonLogAction iref dflags reason severity srcSpan style msg
+  = do
+      addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $
+        JSObject [ ( "span", json srcSpan )
+                 , ( "doc" , JSString (showSDoc dflags msg) )
+                 , ( "severity", json severity )
+                 , ( "reason" ,   json reason )
+                ]
+      defaultLogAction dflags reason severity srcSpan style msg
+  where
+    addMessage m = modifyIORef iref (m:)
+
+
+jsonLogFinaliser :: IORef [SDoc] -> DynFlags -> IO ()
+jsonLogFinaliser iref dflags = do
+  msgs <- readIORef iref
+  let fmt_msgs = brackets $ pprWithCommas (blankLine $$) msgs
+  output fmt_msgs
+  where
+    -- dumpSDoc uses log_action to output the dump
+    dflags' = dflags { log_action = defaultLogAction }
+    output doc = dumpSDoc dflags' neverQualify Opt_D_dump_json "" doc
+
+
 defaultLogAction :: LogAction
 defaultLogAction dflags reason severity srcSpan style msg
     = case severity of
@@ -2063,6 +2132,9 @@ setOutputFile f d = d { outputFile = f}
 setDynOutputFile f d = d { dynOutputFile = f}
 setOutputHi   f d = d { outputHi   = f}
 
+setJsonLogAction :: DynFlags -> DynFlags
+setJsonLogAction d = d { initLogAction = jsonLogOutput }
+
 thisComponentId :: DynFlags -> ComponentId
 thisComponentId dflags =
   case thisComponentId_ dflags of
@@ -2286,9 +2358,26 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
     Just x -> liftIO (setHeapSize x)
     _      -> return ()
 
-  liftIO $ setUnsafeGlobalDynFlags dflags6
+  dflags7 <- liftIO $ setLogAction dflags6
+
+  liftIO $ setUnsafeGlobalDynFlags dflags7
+
+  return (dflags7, leftover, consistency_warnings ++ sh_warns ++ warns)
+
+setLogAction :: DynFlags -> IO DynFlags
+setLogAction dflags = do
+ mlogger <- initLogAction dflags
+ return $
+    maybe
+         dflags
+         (\logger ->
+            dflags
+              { log_action    = getLogAction logger
+              , log_finaliser = getLogFinaliser logger
+              , initLogAction = return $ Nothing -- Don't initialise it twice
+              })
+         mlogger
 
-  return (dflags6, leftover, consistency_warnings ++ sh_warns ++ warns)
 
 updateWays :: DynFlags -> DynFlags
 updateWays dflags
@@ -2891,6 +2980,9 @@ dynamic_flags_deps = [
         (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag
   , make_ord_flag defGhcFlag "ddump-debug"        (setDumpFlag Opt_D_dump_debug)
 
+  , make_ord_flag defGhcFlag "ddump-json"
+        (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )
+
         ------ Machine dependent (-m<blah>) stuff ---------------------------
 
   , make_ord_flag defGhcFlag "msse"         (noArg (\d ->
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 7d1adc0ab9..9e6a0d477d 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -5,6 +5,7 @@ import Platform
 
 data DynFlags
 data OverridingBool
+data DumpFlag
 
 targetPlatform       :: DynFlags -> Platform
 pprUserLength        :: DynFlags -> Int
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index c410f06099..2aeddc26a7 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -6,6 +6,7 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module ErrUtils (
         -- * Basic types
@@ -63,6 +64,7 @@ import SrcLoc
 import DynFlags
 import FastString (unpackFS)
 import StringBuffer (hGetStringBuffer, len, lexemeToString)
+import Json
 
 import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
@@ -127,6 +129,7 @@ data ErrMsg = ErrMsg {
         }
         -- The SrcSpan is used for sorting errors into line-number order
 
+
 -- | Categorise error msgs by their importance.  This is so each section can
 -- be rendered visually distinct.  See Note [Error report] for where these come
 -- from.
@@ -164,6 +167,11 @@ data Severity
     --     plus "warning:" or "error:",
     --     added by mkLocMessags
     --   o Output is intended for end users
+  deriving Show
+
+
+instance ToJson Severity where
+  json s = JSString (show s)
 
 
 instance Show ErrMsg where
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index f6ce45395d..bbbf74e197 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -1,7 +1,9 @@
 module ErrUtils where
 
-import Outputable (SDoc)
+import Outputable (SDoc, PrintUnqualified )
 import SrcLoc (SrcSpan)
+import Json
+import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag )
 
 data Severity
   = SevOutput
@@ -18,3 +20,6 @@ type MsgDoc = SDoc
 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
+dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
+
+instance ToJson Severity
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 031bd155fa..25c1484770 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -459,6 +459,7 @@ withCleanupSession ghc = ghc `gfinally` cleanup
           cleanTempFiles dflags
           cleanTempDirs dflags
           stopIServ hsc_env -- shut down the IServ
+          log_finaliser dflags dflags
           --  exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
           -- signals.
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
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index e654f20399..ae156cb110 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -125,6 +125,10 @@ Compiler
   :ghc-flag:`-Wmissing-methods` will now warn that ``_Bar`` is not implemented
   in the ``Foo Int`` instance.
 
+- A new flag :ghc-flag:`-ddump-json` has been added. This flag dumps compiler
+  output as JSON documents. It is experimental and will be refined depending
+  on feedback from tooling authors for the next release.
+
 GHCi
 ~~~~
 
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index 9994ef9d6a..8191048b92 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -170,6 +170,12 @@ Dumping out compiler intermediate structures
 
         dump foreign export stubs
 
+    .. ghc-flag:: -ddump-json
+
+         Dump error messages as JSON documents. This is intended to be consumed
+         by external tooling. A good way to use it is in conjunction with
+         :ghc-flag:`-ddump-to-file`.
+
 .. ghc-flag:: -ddump-simpl-iterations
 
     Show the output of each *iteration* of the simplifier (each run of
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 17b1206288..e03d4dfdc2 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -261,3 +261,5 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
 test('T12955', normal, run_command, ['$MAKE -s --no-print-directory T12955'])
 
 test('T12971', ignore_stdout, run_command, ['$MAKE -s --no-print-directory T12971'])
+test('json', normal, compile_fail, ['-ddump-json'])
+test('json2', normal, compile, ['-ddump-types -ddump-json'])
diff --git a/testsuite/tests/driver/json.hs b/testsuite/tests/driver/json.hs
new file mode 100644
index 0000000000..1a727fd7cc
--- /dev/null
+++ b/testsuite/tests/driver/json.hs
@@ -0,0 +1,6 @@
+module Foo where
+
+import Data.List
+
+id1 :: a -> a
+id1 = 5
diff --git a/testsuite/tests/driver/json.stderr b/testsuite/tests/driver/json.stderr
new file mode 100644
index 0000000000..ff3915a654
--- /dev/null
+++ b/testsuite/tests/driver/json.stderr
@@ -0,0 +1,8 @@
+
+json.hs:6:7: error:
+    • No instance for (Num (a -> a)) arising from the literal ‘5’
+        (maybe you haven't applied a function to enough arguments?)
+    • In the expression: 5
+      In an equation for ‘id1’: id1 = 5
+[
+ {"span": {"file": "json.hs","startLine": 6,"startCol": 7,"endLine": 6,"endCol": 8},"doc": "\u2022 No instance for (Num (a -> a)) arising from the literal \u20185\u2019\n    (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n  In an equation for \u2018id1\u2019: id1 = 5","severity": "SevError","reason": null}]
diff --git a/testsuite/tests/driver/json2.hs b/testsuite/tests/driver/json2.hs
new file mode 100644
index 0000000000..0a64a58965
--- /dev/null
+++ b/testsuite/tests/driver/json2.hs
@@ -0,0 +1,4 @@
+module JSON where
+
+foo :: a -> a
+foo = id
diff --git a/testsuite/tests/driver/json2.stderr b/testsuite/tests/driver/json2.stderr
new file mode 100644
index 0000000000..33901c68be
--- /dev/null
+++ b/testsuite/tests/driver/json2.stderr
@@ -0,0 +1,9 @@
+TYPE SIGNATURES
+  foo :: forall a. a -> a
+TYPE CONSTRUCTORS
+COERCION AXIOMS
+Dependent modules: []
+Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0,
+                     integer-gmp-1.0.0.1]
+[
+ {"span": null,"doc": "TYPE SIGNATURES\n  foo :: forall a. a -> a\nTYPE CONSTRUCTORS\nCOERCION AXIOMS\nDependent modules: []\nDependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0,\n                     integer-gmp-1.0.0.1]","severity": "SevOutput","reason": null}]