Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 6188871b by Simon Hengel at 2025-08-22T22:29:11+07:00 Add SrcSpan to MCDiagnostic - - - - - a05761aa by Simon Hengel at 2025-08-22T22:29:19+07:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - b11ad603 by Simon Hengel at 2025-08-22T22:29:19+07:00 Get rid of mkLocMessage - - - - - a45d2551 by Simon Hengel at 2025-08-22T22:30:01+07:00 Add Message data type - - - - - 97bb1ca0 by Simon Hengel at 2025-08-22T22:41:01+07:00 Get rid of MessageClass - - - - - 19596062 by Simon Hengel at 2025-08-22T22:48:55+07:00 Remove JSON logging - - - - - 21 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - testsuite/tests/ghc-api/T7478/T7478.hs - testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -26,6 +26,7 @@ module GHC.Core.Lint ( -- ** Debug output EndPassConfig (..), endPassIO, + lintMessage, displayLintResults, dumpPassResult ) where @@ -309,11 +310,6 @@ path does not result in allocation in the hot path. This can be surprisingly impactful. Changing `lint_app` reduced allocations for one test program I was looking at by ~4%. -Note [MCInfo for Lint] -~~~~~~~~~~~~~~~~~~~~~~ -When printing a Lint message, use the MCInfo severity so that the -message is printed on stderr rather than stdout (#13342). - ************************************************************************ * * Beginning and ending passes @@ -321,6 +317,12 @@ message is printed on stderr rather than stdout (#13342). ************************************************************************ -} +lintMessage :: Logger -> SDoc -> IO () +lintMessage logger = + -- Note: Use logInfo when printing a Lint message, so that the message is + -- printed on stderr rather than stdout (#13342). + logInfo logger . withPprStyle defaultDumpStyle + -- | Configuration for boilerplate operations at the end of a -- compilation pass producing Core. data EndPassConfig = EndPassConfig @@ -436,8 +438,7 @@ displayLintResults :: Logger -> IO () displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle + = do { lintMessage logger (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" , pp_pgm @@ -447,8 +448,7 @@ displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag warns) , log_enable_debug (logFlags logger) , display_warnings - = logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle + = lintMessage logger (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -362,19 +362,22 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: MessageClass -> SDoc -> CoreM () -msg msg_class doc = do +msg :: Message -> CoreM () +msg msg = do logger <- getLogger - loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx - let sty = case msg_class of - MCDiagnostic _ _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle name_ppr_ctx - user_sty = mkUserStyle name_ppr_ctx AllTheWay - dump_sty = mkDumpStyle name_ppr_ctx - liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) + let m = case msg of + MCDump doc -> MCDump (dump_sty doc) + UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic + MCOutput doc -> MCOutput (user_sty doc) + MCFatal doc -> MCFatal (user_sty doc) + MCInteractive doc -> MCInteractive (user_sty doc) + MCInfo doc -> MCInfo (user_sty doc) + + err_sty = withPprStyle $ mkErrStyle name_ppr_ctx + user_sty = withPprStyle $ mkUserStyle name_ppr_ctx AllTheWay + dump_sty = withPprStyle $ mkDumpStyle name_ppr_ctx + liftIO $ logMsg logger m -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -382,7 +385,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg MCInfo +putMsg = msg . MCInfo diagnostic :: DiagnosticReason -> SDoc -> CoreM () diagnostic reason doc = do @@ -407,7 +410,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg MCFatal +fatalErrorMsg = msg . MCFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -415,4 +418,4 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg MCDump +debugTraceMsg = msg . MCDump ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang import GHC.Data.FastString +import GHC.Core.Lint ( lintMessage ) import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -55,7 +56,6 @@ import GHC.Utils.Panic.Plain ( pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) -import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.DSM @@ -109,10 +109,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { logMsg logger - MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint" - noSrcSpan - $ withPprStyle defaultDumpStyle err + Just err -> do { lintMessage logger err ; ghcExit logger 1 } Nothing -> return () ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -46,19 +46,16 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages = sortMsgBag (Just opts) . getMessages printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () -printMessage logger msg_opts opts message - | log_diags_as_json = do - decorated <- decorateDiagnostic logflags messageClass location doc - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message +printMessage logger msg_opts opts message = do + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated - logJsonMsg logger messageClass jsonMessage + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message - | otherwise = logMsg logger messageClass location doc + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: MessageClass - messageClass = UnsafeMCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,8 +93,22 @@ printMessage logger msg_opts opts message hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret + where + -- Pretty print the warning flag, if any (#10752) + message :: SDoc + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc + + addCaret :: IO SDoc + addCaret = do + caretDiagnostic <- + if log_show_caret logflags + then getCaretDiagnostic severity span + else pure empty + return $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic $+$ blankLine) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1835,7 +1835,7 @@ markUnsafeInfer tcg_env whyUnsafe = do ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer badFlag df (ext,loc,on,_) - | on df = [mkLocMessage MCOutput (loc df) $ + | on df = [formatLocMessage (loc df) $ text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1844,9 +1844,10 @@ markUnsafeInfer tcg_env whyUnsafe = do checkOverlap _ = True badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ + = [formatLocMessage (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] + text "overlap mode isn't allowed in Safe Haskell" + ] | otherwise = [] -- | Figure out the final correct safe haskell mode ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1442,14 +1442,14 @@ withDeferredDiagnostics f = do fatals <- liftIO $ newIORef [] logger <- getLogger - let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = logMsg logger msgClass srcSpan msg - case msgClass of - MCDiagnostic SevWarning _reason _code + let deferDiagnostics _dflags !msg = do + let action = logMsg logger msg + case msg of + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) - MCFatal + MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) _ -> action ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -47,7 +45,6 @@ import GHC.Utils.Exception import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Types.SrcLoc import GHC.Types.SourceError import Control.Monad @@ -123,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook -pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () -pushJsonLogHookM = modifyLogger . pushJsonLogHook - -popJsonLogHookM :: GhcMonad m => m () -popJsonLogHookM = modifyLogger popJsonLogHook - -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do @@ -136,10 +127,10 @@ putMsgM doc = do liftIO $ putMsg logger doc -- | Put a log message -putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () -putLogMsgM msg_class loc doc = do +putLogMsgM :: GhcMonad m => Message -> m () +putLogMsgM message = do logger <- getLogger - liftIO $ logMsg logger msg_class loc doc + liftIO $ logMsg logger message -- | Time an action withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -1162,7 +1162,7 @@ getHCFilePackages filename = linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - logMsg logger MCInfo noSrcSpan + logInfo logger $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") ===================================== compiler/GHC/Driver/Pipeline/LogQueue.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Prelude import Control.Concurrent import Data.IORef import GHC.Types.Error -import GHC.Types.SrcLoc import GHC.Utils.Logger import qualified Data.IntMap as IM import Control.Concurrent.STM @@ -30,7 +29,7 @@ import Control.Monad -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. data LogQueue = LogQueue { logQueueId :: !Int - , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]) + , logQueueMessages :: !(IORef [Maybe (Message, LogFlags)]) , logQueueSemaphore :: !(MVar ()) } @@ -45,12 +44,12 @@ finishLogQueue lq = do writeLogQueueInternal lq Nothing -writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueue :: LogQueue -> (Message, LogFlags) -> IO () writeLogQueue lq msg = do writeLogQueueInternal lq (Just msg) -- | Internal helper for writing log messages -writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueueInternal :: LogQueue -> Maybe (Message, LogFlags) -> IO () writeLogQueueInternal (LogQueue _n ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -59,8 +58,8 @@ writeLogQueueInternal (LogQueue _n ref sem) msg = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction -parLogAction log_queue log_flags !msgClass !srcSpan !msg = - writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags) +parLogAction log_queue log_flags !msg = + writeLogQueue log_queue (msg, log_flags) -- Print each message from the log_queue using the global logger printLogs :: Logger -> LogQueue -> IO () @@ -72,8 +71,8 @@ printLogs !logger (LogQueue _n ref sem) = read_msgs print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (msgClass,srcSpan,msg,flags) -> do - logMsg (setLogFlags logger flags) msgClass srcSpan msg + Just (msg,flags) -> do + logMsg (setLogFlags logger flags) msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -94,7 +94,6 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv import GHC.Types.Unique.DSet -import GHC.Types.SrcLoc import GHC.Types.TyThing import GHC.Types.PkgQual @@ -1105,7 +1104,7 @@ For some background on this choice see #15269. showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () showIface logger dflags unit_state name_cache filename = do let profile = targetProfile dflags - printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = logOutput logger . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1119,7 +1118,7 @@ showIface logger dflags unit_state name_cache filename = do neverQualifyModules neverQualifyPackages alwaysPrintPromTick - logMsg logger MCDump noSrcSpan + logMsg logger $ MCDump $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -25,6 +25,7 @@ import GHC.Linker.Types import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Types.Error (formatFatalLocMessage) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -231,7 +232,7 @@ splice point about what we would prefer. -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a -dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) +dieWith opts span msg = throwProgramError opts (formatFatalLocMessage span msg) throwProgramError :: LinkDepsOpts -> SDoc -> IO a throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -507,7 +507,7 @@ classifyLdInput logger platform f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - logMsg logger MCInfo noSrcSpan + logInfo logger $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing @@ -1638,9 +1638,8 @@ addEnvPaths name list maybePutSDoc :: Logger -> SDoc -> IO () maybePutSDoc logger s = when (logVerbAtLeast logger 2) $ - logMsg logger + logMsg logger $ MCInteractive - noSrcSpan $ withPprStyle defaultUserStyle s maybePutStr :: Logger -> String -> IO () ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -209,7 +209,7 @@ showTerm term = do setSession new_env -- this disables logging of errors - let noop_log _ _ _ _ = return () + let noop_log _ _ = return () pushLogHookM (const noop_log) return (hsc_env, bname) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -104,6 +104,7 @@ import GHC.Stg.Utils import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type +import GHC.Core.Lint ( lintMessage ) import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) @@ -148,8 +149,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w Nothing -> return () Just msg -> do - logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] in "GHC.Core.Lint" - $ withPprStyle defaultDumpStyle + lintMessage logger (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunit <+> text "***", msg, ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -864,7 +864,7 @@ wrapDocLoc doc = do if logHasDumpFlag logger Opt_D_ppr_debug then do loc <- getSrcSpanM - return (mkLocMessage MCOutput loc doc) + return (formatLocMessage loc doc) else return doc @@ -2343,8 +2343,7 @@ failIfM msg = do env <- getLclEnv let full_msg = (if_loc env <> colon) $$ nest 2 msg logger <- getLogger - liftIO (logMsg logger MCFatal - noSrcSpan $ withPprStyle defaultErrStyle full_msg) + liftIO $ fatalErrorMsg logger full_msg failM -------------------- @@ -2376,10 +2375,7 @@ forkM doc thing_inside logger <- getLogger let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ logMsg logger - MCFatal - noSrcSpan - $ withPprStyle defaultErrStyle msg + liftIO $ fatalErrorMsg logger msg ; traceIf (text "} ending fork (badly)" <+> doc) ; pgmError "Cannot continue after interface file error" } } ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Types.Error -- * Classifying Messages - , MessageClass (MCDiagnostic, ..) + , Message (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -70,8 +70,8 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessage - , mkLocMessageWarningGroups + , formatLocMessage + , formatFatalLocMessage , formatDiagnostic , getCaretDiagnostic @@ -479,22 +479,22 @@ data MsgEnvelope e = MsgEnvelope -- | The class for a diagnostic message. The main purpose is to classify a -- message within GHC, to distinguish it from a debug/dump message vs a proper -- diagnostic, for which we include a 'DiagnosticReason'. -data MessageClass - = MCOutput - | MCFatal - | MCInteractive +data Message + = MCOutput SDoc + | MCFatal SDoc + | MCInteractive SDoc - | MCDump + | MCDump SDoc -- ^ Log message intended for compiler developers -- No file\/line\/column stuff - | MCInfo + | MCInfo SDoc -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as - -- it allows the construction of a 'MessageClass' with a completely + -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, -- users are encouraged to use higher level primitives -- instead. Use this constructor directly only if you need to construct @@ -508,8 +508,8 @@ data MessageClass -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass -pattern MCDiagnostic severity reason code <- UnsafeMCDiagnostic severity reason code +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -538,9 +538,6 @@ the "SevIgnore one" for a number of reasons: -- | Used to describe warnings and errors --- o The message has a file\/line\/column heading, --- plus "warning:" or "error:", --- added by mkLocMessage -- o With 'SevIgnore' the message is suppressed -- o Output is intended for end users data Severity @@ -637,35 +634,14 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -mkLocMessage - :: MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessage = mkLocMessageWarningGroups True - --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg_class locn msg - = case msg_class of - MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg - _ -> sdocOption sdocColScheme $ \col_scheme -> - let - msg_colour = getMessageClassColour msg_class col_scheme - - msg_title = coloured msg_colour $ - case msg_class of - MCFatal -> text "fatal" - _ -> empty - +formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc +formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg +formatLocMessage :: SrcSpan -> SDoc -> SDoc +formatLocMessage span = formatLocMessageWarningGroups span empty empty empty + formatDiagnostic :: Bool -- ^ Print warning groups? -> SrcSpan -- ^ location @@ -775,13 +751,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) - (hang (coloured (Col.sHeader col_scheme) header) 4 - msg) - -getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty + $ hang (coloured (Col.sHeader col_scheme) header) 4 msg getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of @@ -789,9 +759,9 @@ getSeverityColour severity = case severity of SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -824,7 +794,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg_class col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Utils.Error ( -- * Messages Diagnostic(..), MsgEnvelope(..), - MessageClass(..), + Message(..), SDoc, DecoratedSDoc(unDecorated), Messages, @@ -28,7 +28,7 @@ module GHC.Utils.Error ( -- ** Construction DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, + emptyMessages, mkDecorated, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkLintWarning, diagReasonSeverity, @@ -282,9 +282,8 @@ unsafePprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgContext = name_ppr_ctx , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ - mkLocMessage - (UnsafeMCDiagnostic sev reason (diagnosticCode e)) - s + formatDiagnostic True + s sev reason (diagnosticCode e) (formatBulleted $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] @@ -314,7 +313,7 @@ ghcExit logger val fatalErrorMsg :: Logger -> SDoc -> IO () fatalErrorMsg logger msg = - logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg + logMsg logger $ MCFatal (withPprStyle defaultErrStyle msg) compilationProgressMsg :: Logger -> SDoc -> IO () compilationProgressMsg logger msg = do @@ -475,11 +474,11 @@ printOutputForUser logger name_ppr_ctx msg = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () -logInfo logger msg = logMsg logger MCInfo noSrcSpan msg +logInfo logger = logMsg logger . MCInfo -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput :: Logger -> SDoc -> IO () -logOutput logger msg = logMsg logger MCOutput noSrcSpan msg +logOutput logger = logMsg logger . MCOutput prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,15 +52,11 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg - , decorateDiagnostic - -- * Dumping , defaultDumpAction , putDumpFile @@ -85,12 +78,11 @@ where import GHC.Prelude import GHC.Driver.Flags import GHC.Types.Error -import GHC.Types.SrcLoc import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet @@ -181,16 +173,9 @@ setLogFlags logger flags = logger { logFlags = flags } --------------------------------------------------------------- type LogAction = LogFlags - -> MessageClass - -> SrcSpan - -> SDoc + -> Message -> IO () -type LogJsonAction = LogFlags - -> MessageClass - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -228,9 +213,6 @@ data Logger = Logger { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack - , json_log_hook :: [LogJsonAction -> LogJsonAction] - -- ^ Json log hooks stack - , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -266,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -278,10 +259,6 @@ initLogger = do putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) --- | Log a JsonDoc -putJsonLogMsg :: Logger -> LogJsonAction -putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) - -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -306,15 +283,6 @@ popLogHook logger = case log_hook logger of [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } --- | Push a json log hook -pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger -pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } - -popJsonLogHook :: Logger -> Logger -popJsonLogHook logger = case json_log_hook logger of - [] -> panic "popJsonLogHook: empty hook stack" - _:hs -> logger { json_log_hook = hs} - -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -343,8 +311,8 @@ makeThreadSafe logger = do with_lock :: forall a. IO a -> IO a with_lock act = withMVar lock (const act) - log action logflags msg_class loc doc = - with_lock (action logflags msg_class loc doc) + log action logflags message = + with_lock (action logflags message) dmp action logflags sty opts str fmt doc = with_lock (action logflags sty opts str fmt doc) @@ -358,22 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger -defaultLogJsonAction :: LogJsonAction -defaultLogJsonAction logflags msg_class jsdoc = - case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -384,71 +336,24 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- | The default 'LogAction' parametrized over the standard output and standard error handles. -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction -defaultLogActionWithHandles out err logflags msg_class srcSpan msg - = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs +defaultLogActionWithHandles out err logflags message + = case message of + MCOutput msg -> printOut msg + MCDump msg -> printOut (msg $$ blankLine) + MCInteractive msg -> putStrSDoc msg + MCInfo msg -> printErrs msg + MCFatal msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err putStrSDoc = defaultLogActionHPutStrDoc logflags False out --- This function is used by `defaultLogActionWithHandles` for non-JSON output, --- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` --- message on `-fdiagnostics-as-json`. --- --- We would want to eventually consolidate this. However, this is currently --- not feasible for the following reasons: --- --- 1. Some parts of the compiler sidestep `printMessages`, for that reason we --- can not decorate the message in `printMessages`. --- --- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For --- that reason we can not decorate the message in `defaultLogActionWithHandles`. --- --- See also Note [JSON Error Messages]: --- --- `jsonLogAction` should be removed along with -ddump-json --- --- Also note that (1) is the reason why some parts of the compiler produce --- diagnostics that don't respect `-fdiagnostics-as-json`. --- --- The plan as I see it is as follows: --- --- 1. Refactor all places in the compiler that report diagnostics to go --- through `GHC.Driver.Errors.printMessages`. --- --- (It's easy to find all those places by looking for who creates --- MCDiagnostic, either directly or via `mkMCDiagnostic` or --- `errorDiagnostic`.) --- --- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message --- decoration at one place (either `printMessages` or --- `defaultLogActionWithHandles`) --- --- This story is tracked by #24113. -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret - where - -- Pretty print the warning flag, if any (#10752) - message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - - addCaret :: IO SDoc - addCaret = do - caretDiagnostic <- - if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan - else pure empty - return $ getPprStyle $ \style -> - withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic $+$ blankLine) - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d @@ -494,10 +399,10 @@ dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = -- write the dump to stdout writeDump Nothing = do - let (doc', msg_class) - | null hdr = (doc, MCOutput) - | otherwise = (mkDumpDoc hdr doc, MCDump) - log_action logflags msg_class noSrcSpan (withPprStyle sty doc') + let message + | null hdr = MCOutput (withPprStyle sty doc) + | otherwise = MCDump (withPprStyle sty $ mkDumpDoc hdr doc) + log_action logflags message -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a @@ -587,11 +492,8 @@ defaultTraceAction logflags title doc x = -- | Log something -logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () -logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg - -logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc +logMsg :: Logger -> Message -> IO () +logMsg logger = putLogMsg logger (logFlags logger) -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () @@ -603,7 +505,7 @@ logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a -- | Log a dump message (not a dump file) logDumpMsg :: Logger -> String -> SDoc -> IO () -logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan +logDumpMsg logger hdr doc = logMsg logger $ MCDump (withPprStyle defaultDumpStyle (mkDumpDoc hdr doc)) ===================================== ghc/GHCi/UI.hs ===================================== @@ -833,10 +833,10 @@ resetLastErrorLocations = do ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction ghciLogAction lastErrLocations old_log_action - dflags msg_class srcSpan msg = do - old_log_action dflags msg_class srcSpan msg - case msg_class of - MCDiagnostic SevError _reason _code -> case srcSpan of + dflags msg = do + old_log_action dflags msg + case msg of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () ===================================== testsuite/tests/ghc-api/T7478/T7478.hs ===================================== @@ -24,11 +24,11 @@ compileInGhc targets handlerOutput = do flags0 <- getSessionDynFlags let flags = flags0 {verbosity = 1 } setSessionDynFlags flags - let collectSrcError handlerOutput _flags MCOutput _srcspan msg + let collectSrcError _flags (MCOutput msg) = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg - collectSrcError _ _ _ _ _ + collectSrcError _ _ = return () - pushLogHookM (const (collectSrcError handlerOutput)) + pushLogHookM (const collectSrcError) -- Set up targets. oldTargets <- getTargets let oldFiles = map fileFromTarget oldTargets ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs ===================================== @@ -19,6 +19,6 @@ hooksP opts hsc_env = do return hsc_env' logHook :: LogAction -> LogAction -logHook action logFlags messageClass srcSpan msgDoc = do +logHook action logFlags message = do putStrLn "Log hook called" - action logFlags messageClass srcSpan msgDoc + action logFlags message View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95790a5cf4ed5599112f405c29b609b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95790a5cf4ed5599112f405c29b609b... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Simon Hengel (＠sol)