Commit 91691117 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari
Browse files

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
parent 7363d538
......@@ -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` ()
......
......@@ -490,6 +490,7 @@ Library
GraphOps
GraphPpr
IOEnv
Json
ListSetOps
ListT
Maybes
......
......@@ -493,6 +493,7 @@ compiler_stage2_dll0_MODULES = \
IdInfo \
IfaceSyn \
IfaceType \
Json \
ToIface \
InstEnv \
Kind \
......
......@@ -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 ->
......
......@@ -5,6 +5,7 @@ import Platform
data DynFlags
data OverridingBool
data DumpFlag
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
......
......@@ -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
......
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
......@@ -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.
......
{-# 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
......@@ -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
~~~~
......
......@@ -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
......
......@@ -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'])
module Foo where
import Data.List
id1 :: a -> a
id1 = 5
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}]
module JSON where
foo :: a -> a
foo = id
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}]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment