Commit 6ab7cf99 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Simplify -ddump-json implementation

This patch takes the much simpler route of whenever the compiler tries
to output something. We just dump a JSON document there and then.

I think this should be sufficient to work with and anything more refined
quickly got complicated as it was necessary to demarcate message scopes
and so on.

Reviewers: bgamari, dfeuer

Reviewed By: bgamari

Subscribers: Phyx, dfeuer, rwbarton, thomie, carter

GHC Trac Issues: #14078

Differential Revision: https://phabricator.haskell.org/D4532
parent 00049e2d
......@@ -266,8 +266,7 @@ compileOne' m_tc_result mHscMessage
prevailing_dflags = hsc_dflags hsc_env0
dflags =
dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
, log_action = log_action prevailing_dflags
, log_finaliser = log_finaliser prevailing_dflags }
, log_action = log_action prevailing_dflags }
-- use the prevailing log_action / log_finaliser,
-- not the one cached in the summary. This is so
-- that we can change the log_action without having
......
......@@ -24,7 +24,7 @@ module DynFlags (
WarningFlag(..), WarnReason(..),
Language(..),
PlatformConstants(..),
FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..),
FatalMessager, LogAction, FlushOut(..), FlushErr(..),
ProfAuto(..),
glasgowExtsFlags,
warningGroups, warningHierarchies,
......@@ -203,7 +203,7 @@ import Outputable
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
, getCaretDiagnostic, dumpSDoc )
, getCaretDiagnostic )
import Json
import SysTools.Terminal ( stderrSupportsAnsiColors )
import SysTools.BaseDir ( expandToolDir, expandTopDir )
......@@ -1036,9 +1036,7 @@ 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,
......@@ -1872,10 +1870,7 @@ defaultDynFlags mySettings myLlvmTargets =
-- Logging
initLogAction = defaultLogOutput,
log_action = defaultLogAction,
log_finaliser = \ _ -> return (),
flushOut = defaultFlushOut,
flushErr = defaultFlushErr,
......@@ -1936,9 +1931,10 @@ interpreterDynamic dflags
-- 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.
-- we used to collect them all in an IORef and then print them at the end.
-- This doesn't work very well with GHCi. (See #14078) So instead we now
-- use the simpler method of just outputting a JSON document inplace to
-- stdout.
--
-- Before the compiler calls log_action, it has already turned the `ErrMsg`
-- into a formatted message. This means that we lose some possible
......@@ -1948,14 +1944,6 @@ interpreterDynamic dflags
type FatalMessager = String -> IO ()
data LogOutput = LogOutput
{ getLogAction :: LogAction
, getLogFinaliser :: LogFinaliser
}
defaultLogOutput :: IO (Maybe LogOutput)
defaultLogOutput = return $ Nothing
type LogAction = DynFlags
-> WarnReason
-> Severity
......@@ -1964,41 +1952,24 @@ 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
--
jsonLogAction :: LogAction
jsonLogAction dflags reason severity srcSpan _style msg
= do
addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $
defaultLogActionHPutStrDoc dflags stdout (doc $$ text "")
(mkCodeStyle CStyle)
where
doc = 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
......@@ -2395,7 +2366,7 @@ setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f}
setJsonLogAction :: DynFlags -> DynFlags
setJsonLogAction d = d { initLogAction = jsonLogOutput }
setJsonLogAction d = d { log_action = jsonLogAction }
thisComponentId :: DynFlags -> ComponentId
thisComponentId dflags =
......@@ -2614,27 +2585,11 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
Just x -> liftIO (setHeapSize x)
_ -> return ()
dflags7 <- liftIO $ setLogAction dflags5
liftIO $ setUnsafeGlobalDynFlags dflags7
liftIO $ setUnsafeGlobalDynFlags dflags5
let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)
return (dflags7, leftover, 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 (dflags5, leftover, warns' ++ warns)
-- | Write an error or warning to the 'LogOutput'.
putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle
......
......@@ -472,7 +472,6 @@ 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.
......@@ -592,12 +591,11 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
-- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph.
setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()
setLogAction action finaliser = do
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action = do
dflags' <- getProgramDynFlags
void $ setProgramDynFlags_ False $
dflags' { log_action = action
, log_finaliser = finaliser }
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ invalidate_needed dflags = do
......
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}]
{"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}
TYPE SIGNATURES
foo :: forall a. a -> a
TYPE CONSTRUCTORS
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.2.1,
integer-gmp-1.0.2.0]
[
{"span": null,"doc": "TYPE SIGNATURES\n foo :: forall a. a -> a\nTYPE CONSTRUCTORS\nCOERCION AXIOMS\nDependent modules: []\nDependent packages: [base-4.12.0.0, ghc-prim-0.5.2.1,\n integer-gmp-1.0.2.0]","severity": "SevOutput","reason": null}]
{"span": null,"doc": "TYPE SIGNATURES/n foo :: forall a. a -> a/nTYPE CONSTRUCTORS/nCOERCION AXIOMS/nDependent modules: []/nDependent packages: [base-4.12.0.0, ghc-prim-0.5.2.1,/n integer-<IMPL>-<VERSION>]","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