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 ...@@ -266,8 +266,7 @@ compileOne' m_tc_result mHscMessage
prevailing_dflags = hsc_dflags hsc_env0 prevailing_dflags = hsc_dflags hsc_env0
dflags = dflags =
dflags1 { includePaths = addQuoteInclude old_paths [current_dir] dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
, log_action = log_action prevailing_dflags , log_action = log_action prevailing_dflags }
, log_finaliser = log_finaliser prevailing_dflags }
-- use the prevailing log_action / log_finaliser, -- use the prevailing log_action / log_finaliser,
-- not the one cached in the summary. This is so -- not the one cached in the summary. This is so
-- that we can change the log_action without having -- that we can change the log_action without having
......
...@@ -24,7 +24,7 @@ module DynFlags ( ...@@ -24,7 +24,7 @@ module DynFlags (
WarningFlag(..), WarnReason(..), WarningFlag(..), WarnReason(..),
Language(..), Language(..),
PlatformConstants(..), PlatformConstants(..),
FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..), FatalMessager, LogAction, FlushOut(..), FlushErr(..),
ProfAuto(..), ProfAuto(..),
glasgowExtsFlags, glasgowExtsFlags,
warningGroups, warningHierarchies, warningGroups, warningHierarchies,
...@@ -203,7 +203,7 @@ import Outputable ...@@ -203,7 +203,7 @@ import Outputable
import Foreign.C ( CInt(..) ) import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO ) import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
, getCaretDiagnostic, dumpSDoc ) , getCaretDiagnostic )
import Json import Json
import SysTools.Terminal ( stderrSupportsAnsiColors ) import SysTools.Terminal ( stderrSupportsAnsiColors )
import SysTools.BaseDir ( expandToolDir, expandTopDir ) import SysTools.BaseDir ( expandToolDir, expandTopDir )
...@@ -1036,9 +1036,7 @@ data DynFlags = DynFlags { ...@@ -1036,9 +1036,7 @@ data DynFlags = DynFlags {
ghciHistSize :: Int, ghciHistSize :: Int,
-- | MsgDoc output action: use "ErrUtils" instead of this if you can -- | MsgDoc output action: use "ErrUtils" instead of this if you can
initLogAction :: IO (Maybe LogOutput),
log_action :: LogAction, log_action :: LogAction,
log_finaliser :: LogFinaliser,
flushOut :: FlushOut, flushOut :: FlushOut,
flushErr :: FlushErr, flushErr :: FlushErr,
...@@ -1872,10 +1870,7 @@ defaultDynFlags mySettings myLlvmTargets = ...@@ -1872,10 +1870,7 @@ defaultDynFlags mySettings myLlvmTargets =
-- Logging -- Logging
initLogAction = defaultLogOutput,
log_action = defaultLogAction, log_action = defaultLogAction,
log_finaliser = \ _ -> return (),
flushOut = defaultFlushOut, flushOut = defaultFlushOut,
flushErr = defaultFlushErr, flushErr = defaultFlushErr,
...@@ -1936,9 +1931,10 @@ interpreterDynamic dflags ...@@ -1936,9 +1931,10 @@ interpreterDynamic dflags
-- Note [JSON Error Messages] -- Note [JSON Error Messages]
-- --
-- When the user requests the compiler output to be dumped as json -- 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 -- we used to collect them all in an IORef and then print them at the end.
-- and then finally in GHC.withCleanupSession the log_finaliser is -- This doesn't work very well with GHCi. (See #14078) So instead we now
-- called which prints out the messages together. -- 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` -- Before the compiler calls log_action, it has already turned the `ErrMsg`
-- into a formatted message. This means that we lose some possible -- into a formatted message. This means that we lose some possible
...@@ -1948,14 +1944,6 @@ interpreterDynamic dflags ...@@ -1948,14 +1944,6 @@ interpreterDynamic dflags
type FatalMessager = String -> IO () type FatalMessager = String -> IO ()
data LogOutput = LogOutput
{ getLogAction :: LogAction
, getLogFinaliser :: LogFinaliser
}
defaultLogOutput :: IO (Maybe LogOutput)
defaultLogOutput = return $ Nothing
type LogAction = DynFlags type LogAction = DynFlags
-> WarnReason -> WarnReason
-> Severity -> Severity
...@@ -1964,41 +1952,24 @@ type LogAction = DynFlags ...@@ -1964,41 +1952,24 @@ type LogAction = DynFlags
-> MsgDoc -> MsgDoc
-> IO () -> IO ()
type LogFinaliser = DynFlags -> IO ()
defaultFatalMessager :: FatalMessager defaultFatalMessager :: FatalMessager
defaultFatalMessager = hPutStrLn stderr defaultFatalMessager = hPutStrLn stderr
-- See Note [JSON Error Messages] -- See Note [JSON Error Messages]
jsonLogOutput :: IO (Maybe LogOutput) --
jsonLogOutput = do jsonLogAction :: LogAction
ref <- newIORef [] jsonLogAction dflags reason severity srcSpan _style msg
return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref)
jsonLogAction :: IORef [SDoc] -> LogAction
jsonLogAction iref dflags reason severity srcSpan style msg
= do = do
addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $ defaultLogActionHPutStrDoc dflags stdout (doc $$ text "")
JSObject [ ( "span", json srcSpan ) (mkCodeStyle CStyle)
, ( "doc" , JSString (showSDoc dflags msg) ) where
, ( "severity", json severity ) doc = renderJSON $
, ( "reason" , json reason ) JSObject [ ( "span", json srcSpan )
] , ( "doc" , JSString (showSDoc dflags msg) )
defaultLogAction dflags reason severity srcSpan style msg , ( "severity", json severity )
where , ( "reason" , json reason )
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 :: LogAction
...@@ -2395,7 +2366,7 @@ setDynOutputFile f d = d { dynOutputFile = f} ...@@ -2395,7 +2366,7 @@ setDynOutputFile f d = d { dynOutputFile = f}
setOutputHi f d = d { outputHi = f} setOutputHi f d = d { outputHi = f}
setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction :: DynFlags -> DynFlags
setJsonLogAction d = d { initLogAction = jsonLogOutput } setJsonLogAction d = d { log_action = jsonLogAction }
thisComponentId :: DynFlags -> ComponentId thisComponentId :: DynFlags -> ComponentId
thisComponentId dflags = thisComponentId dflags =
...@@ -2614,27 +2585,11 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do ...@@ -2614,27 +2585,11 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
Just x -> liftIO (setHeapSize x) Just x -> liftIO (setHeapSize x)
_ -> return () _ -> return ()
dflags7 <- liftIO $ setLogAction dflags5 liftIO $ setUnsafeGlobalDynFlags dflags5
liftIO $ setUnsafeGlobalDynFlags dflags7
let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)
return (dflags7, leftover, warns' ++ warns) return (dflags5, 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
-- | Write an error or warning to the 'LogOutput'. -- | Write an error or warning to the 'LogOutput'.
putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle
......
...@@ -472,7 +472,6 @@ withCleanupSession ghc = ghc `gfinally` cleanup ...@@ -472,7 +472,6 @@ withCleanupSession ghc = ghc `gfinally` cleanup
cleanTempFiles dflags cleanTempFiles dflags
cleanTempDirs dflags cleanTempDirs dflags
stopIServ hsc_env -- shut down the IServ stopIServ hsc_env -- shut down the IServ
log_finaliser dflags dflags
-- exceptions will be blocked while we clean the temporary files, -- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further -- so there shouldn't be any difficulty if we receive further
-- signals. -- signals.
...@@ -592,12 +591,11 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags ...@@ -592,12 +591,11 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This -- | Set the action taken when the compiler produces a message. This
-- can also be accomplished using 'setProgramDynFlags', but using -- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph. -- 'setLogAction' avoids invalidating the cached module graph.
setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m () setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action finaliser = do setLogAction action = do
dflags' <- getProgramDynFlags dflags' <- getProgramDynFlags
void $ setProgramDynFlags_ False $ void $ setProgramDynFlags_ False $
dflags' { log_action = action dflags' { log_action = action }
, log_finaliser = finaliser }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ invalidate_needed dflags = do setProgramDynFlags_ invalidate_needed dflags = do
......
{"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}
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}]
TYPE SIGNATURES {"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}
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}]
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