diff options
Diffstat (limited to 'compiler/GHC/Tc/Errors/Ppr.hs')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 36 |
1 files changed, 29 insertions, 7 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 578c182a7d..837672c4d1 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE RecordWildCards #-} module GHC.Tc.Errors.Ppr ( formatLevPolyErr @@ -16,18 +17,24 @@ import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Driver.Flags import GHC.Hs import GHC.Utils.Outputable +import GHC.Unit.State (pprWithUnitState, UnitState) + instance Diagnostic TcRnMessage where diagnosticMessage = \case TcRnUnknownMessage m -> diagnosticMessage m - TcLevityPolyInType ty prov (ErrInfo extra) - -> mkDecorated [pprLevityPolyInType ty prov, extra] - TcRnImplicitLift id_or_name errInfo - -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+> - text "is implicitly lifted in the TH quotation" - , getErrInfo errInfo - ] + TcLevityPolyInType ty prov (ErrInfo extra supplementary) + -> mkDecorated [pprLevityPolyInType ty prov, extra, supplementary] + TcRnMessageWithInfo unit_state msg_with_info + -> case msg_with_info of + TcRnMessageDetailed err_info msg + -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) + TcRnImplicitLift id_or_name ErrInfo{..} + -> mkDecorated $ + ( text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + ) : [errInfoContext, errInfoSupplementary] TcRnUnusedPatternBinds bind -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] TcRnDodgyImports name @@ -48,6 +55,9 @@ instance Diagnostic TcRnMessage where -> diagnosticReason m TcLevityPolyInType{} -> ErrorWithoutFlag + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticReason m TcRnImplicitLift{} -> WarningWithFlag Opt_WarnImplicitLift TcRnUnusedPatternBinds{} @@ -68,6 +78,9 @@ instance Diagnostic TcRnMessage where -> diagnosticHints m TcLevityPolyInType{} -> noHints + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticHints m TcRnImplicitLift{} -> noHints TcRnUnusedPatternBinds{} @@ -83,6 +96,15 @@ instance Diagnostic TcRnMessage where TcRnModMissingRealSrcSpan{} -> noHints +messageWithInfoDiagnosticMessage :: UnitState + -> ErrInfo + -> DecoratedSDoc + -> DecoratedSDoc +messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important = + let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary] + in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` + mkDecorated err_info' + dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc dodgy_msg kind tc ie = sep [ text "The" <+> kind <+> text "item" |