From 127e8cbb3529937b4c3e9ea762ae885d92de6d8d Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 15 Jun 2022 11:45:33 +0100 Subject: Add -fsuppress-error-contexts to disable printing error contexts in errors In many development environments, the source span is the primary means of seeing what an error message relates to, and the In the expression: and In an equation for: clauses are not particularly relevant. However, they can grow to be quite long, which can make the message itself both feel overwhelming and interact badly with limited-space areas. It's simple to implement this flag so we might as well do it and give the user control about how they see their messages. Fixes #21722 --- compiler/GHC/Driver/Flags.hs | 3 +++ compiler/GHC/Driver/Session.hs | 3 ++- compiler/GHC/Tc/Errors.hs | 5 ++++- compiler/GHC/Tc/Errors/Ppr.hs | 13 +++++++------ compiler/GHC/Tc/Errors/Types.hs | 2 ++ compiler/GHC/Tc/Gen/Head.hs | 4 ++-- compiler/GHC/Tc/Utils/Monad.hs | 18 ++++++++++++------ docs/users_guide/using.rst | 12 ++++++++++++ testsuite/tests/driver/T21722.hs | 6 ++++++ testsuite/tests/driver/T21722.stderr | 5 +++++ testsuite/tests/driver/all.T | 1 + 11 files changed, 56 insertions(+), 16 deletions(-) create mode 100644 testsuite/tests/driver/T21722.hs create mode 100644 testsuite/tests/driver/T21722.stderr diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 209e6d1776..b6d198789e 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -375,6 +375,9 @@ data GeneralFlag | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- Error message suppression + | Opt_SuppressErrorContext + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 627b2c69b3..9bfcd1a382 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3501,7 +3501,8 @@ fFlagsDeps = [ (\turn_on -> updM (\dflags -> do unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") - return dflags)) + return dflags)), + flagSpec "suppress-error-contexts" Opt_SuppressErrorContext ] ++ fHoleFlags diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 237c6fa4a3..8ca2d2c6da 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1171,9 +1171,12 @@ mkErrorReport tcl_env msg mb_ctxt supplementary ErrInfo (fromMaybe empty mb_context) (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) + ; detailed_msg <- mkDetailedMessage err_info msg ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } + (TcRnMessageWithInfo unit_state $ detailed_msg) } + + -- | Pretty-print supplementary information, to add to an error report. pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 35bfea6ae1..87f482a290 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -97,8 +97,8 @@ instance Diagnostic TcRnMessage where -> diagnosticMessage m TcRnMessageWithInfo unit_state msg_with_info -> case msg_with_info of - TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) + TcRnMessageDetailed err_info suppress_ctx msg + -> messageWithInfoDiagnosticMessage unit_state err_info suppress_ctx (diagnosticMessage msg) TcRnSolverReport msgs _ _ -> mkDecorated $ map pprSolverReportWithCtxt msgs @@ -962,7 +962,7 @@ instance Diagnostic TcRnMessage where -> diagnosticReason m TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticReason m + TcRnMessageDetailed _ _ m -> diagnosticReason m TcRnSolverReport _ reason _ -> reason -- Error, or a Warning if we are deferring type errors TcRnRedundantConstraints {} @@ -1276,7 +1276,7 @@ instance Diagnostic TcRnMessage where -> diagnosticHints m TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticHints m + TcRnMessageDetailed _ _ m -> diagnosticHints m TcRnSolverReport _ _ hints -> hints TcRnRedundantConstraints{} @@ -1679,10 +1679,11 @@ deriveInstanceErrReasonHints cls newtype_deriving = \case messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo + -> Bool -> DecoratedSDoc -> DecoratedSDoc -messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important = - let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary] +messageWithInfoDiagnosticMessage unit_state ErrInfo{..} suppress_ctxt important = + let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | not suppress_ctxt] ++ [errInfoSupplementary]) in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` mkDecorated err_info' diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 62732ed8dd..b257c97fc0 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -166,6 +166,8 @@ data ErrInfo = ErrInfo { data TcRnMessageDetailed = TcRnMessageDetailed !ErrInfo -- ^ Extra info associated with the message + !Bool + -- ^ Suppress extra context information !TcRnMessage -- | An error which might arise during typechecking/renaming. diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index af4575c490..b8309cfa5b 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -1096,8 +1096,8 @@ tc_infer_id id_name hint_msg = vcat $ map ppr hints import_err_msg = vcat $ map ppr import_errs info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } - msg = TcRnMessageWithInfo unit_state - $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False) + msg <- TcRnMessageWithInfo unit_state <$> + mkDetailedMessage info (TcRnIncorrectNameSpace nm False) failWithTc msg get_suggestions ns = do diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 571e02c7cf..efe30fca02 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -70,7 +70,7 @@ module GHC.Tc.Utils.Monad( addErrAt, addErrs, checkErr, addMessages, - discardWarnings, + discardWarnings, mkDetailedMessage, -- * Usage environment tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, @@ -1068,7 +1068,12 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn () addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt - ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + ; detailed_msg <- mkDetailedMessage (ErrInfo err_info Outputable.empty) msg + ; add_long_err_at loc detailed_msg } + +mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcM TcRnMessageDetailed +mkDetailedMessage err_info msg = + TcRnMessageDetailed err_info <$> goptM Opt_SuppressErrorContext <*> pure msg addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs @@ -1601,7 +1606,8 @@ addDiagnosticTcM (env0, msg) = do { ctxt <- getErrCtxt ; extra <- mkErrInfo env0 ctxt ; let err_info = ErrInfo extra Outputable.empty - ; add_diagnostic (TcRnMessageDetailed err_info msg) } + ; detailed_msg <- mkDetailedMessage err_info msg + ; add_diagnostic detailed_msg } -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic. @@ -1623,13 +1629,13 @@ addTcRnDiagnostic msg = do -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn () -addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg) +addDiagnostic msg = add_diagnostic =<< mkDetailedMessage no_err_info msg -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do unit_state <- hsc_units <$> getTopEnv - let dia = TcRnMessageDetailed no_err_info msg + dia <- mkDetailedMessage no_err_info msg mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source @@ -1652,7 +1658,7 @@ add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan -> TcM () add_err_tcm tidy_env msg loc ctxt = do { err_info <- mkErrInfo tidy_env ctxt ; - add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + add_long_err_at loc =<< (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) } mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst index ee61a89ce1..a3ccd2c168 100644 --- a/docs/users_guide/using.rst +++ b/docs/users_guide/using.rst @@ -1360,6 +1360,18 @@ messages and in GHCi: error was detected. This also affects the associated caret symbol that points at the region of code at fault. +.. ghc-flag:: -fsuppress-error-contexts + :shortdesc: Whether to show textual information about error context + :type: dynamic + :reverse: -fno-suppress-error-contexts + :category: verbosity + + :default: off + + Controls whether GHC displays information about the context in which an + error occurred. This controls whether the part of the error message which + says "In the equation..", "In the pattern.." etc is displayed or not. + .. ghc-flag:: -ferror-spans :shortdesc: Output full span in error messages :type: dynamic diff --git a/testsuite/tests/driver/T21722.hs b/testsuite/tests/driver/T21722.hs new file mode 100644 index 0000000000..fe40aadc61 --- /dev/null +++ b/testsuite/tests/driver/T21722.hs @@ -0,0 +1,6 @@ +module T21722 where + +main = print () + where + foo :: Int + foo = "abc" diff --git a/testsuite/tests/driver/T21722.stderr b/testsuite/tests/driver/T21722.stderr new file mode 100644 index 0000000000..7fa43973dd --- /dev/null +++ b/testsuite/tests/driver/T21722.stderr @@ -0,0 +1,5 @@ + +T21722.hs:6:11: error: + Couldn't match type β€˜[Char]’ with β€˜Int’ + Expected: Int + Actual: String diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 624c8305dc..58bbdda1a6 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -309,3 +309,4 @@ test('T16476a', normal, makefile_test, []) test('T16476b', normal, makefile_test, []) test('T20569', extra_files(["T20569/"]), makefile_test, []) test('T21349', extra_files(['T21349']), makefile_test, []) +test('T21722', normal, compile_fail, ['-fsuppress-error-contexts']) -- cgit v1.2.1