diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Driver/Config/Diagnostic.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Make.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 21 |
5 files changed, 27 insertions, 10 deletions
diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs index e8bf0f5926..3a590abc9f 100644 --- a/compiler/GHC/Driver/Config/Diagnostic.hs +++ b/compiler/GHC/Driver/Config/Diagnostic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications #-} + -- | Functions for initialising error message printing configuration from the -- GHC session flags. module GHC.Driver.Config.Diagnostic @@ -21,6 +21,7 @@ import GHC.Driver.Errors.Ppr () import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error +import GHC.Tc.Errors.Ppr -- | Initialise the general configuration for printing diagnostic messages -- For example, this configuration controls things like whether warnings are @@ -47,7 +48,7 @@ initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage initPsMessageOpts _ = NoDiagnosticOpts initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage -initTcMessageOpts _ = NoDiagnosticOpts +initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags } initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage initDsMessageOpts _ = NoDiagnosticOpts diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 83d87b6898..0651e1c475 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -427,6 +427,9 @@ data GeneralFlag | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- Error message suppression + | Opt_ShowErrorContext + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 68a925f901..ff2b73eea3 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -4,7 +4,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index cf6a5da5e3..836ad88005 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3508,7 +3508,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 "show-error-context" Opt_ShowErrorContext ] ++ fHoleFlags @@ -3802,7 +3803,9 @@ defaultFlags settings Opt_VersionMacros, Opt_RPath, Opt_DumpWithWays, - Opt_CompactUnwind + Opt_CompactUnwind, + Opt_ShowErrorContext + ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 993b62a7ea..2842362a8f 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -18,6 +18,7 @@ module GHC.Tc.Errors.Ppr , withHsDocContext , pprHsDocContext , inHsDocContext + , TcRnMessageOpts(..) ) where @@ -96,16 +97,25 @@ import Data.Ord ( comparing ) import Data.Bifunctor import GHC.Types.Name.Env +data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not + } + +defaultTcRnMessageOpts :: TcRnMessageOpts +defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True } + + instance Diagnostic TcRnMessage where - type DiagnosticOpts TcRnMessage = NoDiagnosticOpts - defaultDiagnosticOpts = NoDiagnosticOpts + type DiagnosticOpts TcRnMessage = TcRnMessageOpts + defaultDiagnosticOpts = defaultTcRnMessageOpts diagnosticMessage opts = \case TcRnUnknownMessage (UnknownDiagnostic @e m) -> diagnosticMessage (defaultDiagnosticOpts @e) m TcRnMessageWithInfo unit_state msg_with_info -> case msg_with_info of TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage opts msg) + -> messageWithInfoDiagnosticMessage unit_state err_info + (tcOptsShowContext opts) + (diagnosticMessage opts msg) TcRnSolverReport msg _ _ -> mkSimpleDecorated $ pprSolverReportWithCtxt msg TcRnRedundantConstraints redundants (info, show_info) @@ -1807,10 +1817,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{..} show_ctxt important = + let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | show_ctxt] ++ [errInfoSupplementary]) in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` mkDecorated err_info' |