From c8564c639a9889d4d19c68f4b96c092f670b092c Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 12 Apr 2021 14:21:20 +0200 Subject: Add some TcRn diagnostic messages This commit converts some TcRn diagnostic into proper structured errors. Ported by this commit: * Add TcRnImplicitLift This commit adds the TcRnImplicitLift diagnostic message and a prototype API to be able to log messages which requires additional err info. * Add TcRnUnusedPatternBinds * Add TcRnDodgyExports * Add TcRnDodgyImports message * Add TcRnMissingImportList --- compiler/GHC/Rename/Bind.hs | 9 ++--- compiler/GHC/Rename/Names.hs | 31 ++--------------- compiler/GHC/Rename/Splice.hs | 5 ++- compiler/GHC/Tc/Errors/Ppr.hs | 56 +++++++++++++++++++++++++++++-- compiler/GHC/Tc/Errors/Types.hs | 74 ++++++++++++++++++++++++++++++++++++++--- compiler/GHC/Tc/Gen/Export.hs | 8 ++--- compiler/GHC/Tc/Gen/Head.hs | 5 ++- compiler/GHC/Tc/Utils/Monad.hs | 21 +++++++++++- 8 files changed, 154 insertions(+), 55 deletions(-) (limited to 'compiler') diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 0dcd51637b..352ede60dd 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -35,6 +35,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts ) import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Rename.HsType import GHC.Rename.Pat @@ -500,8 +501,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- See Note [Pattern bindings that bind no variables] ; whenWOptM Opt_WarnUnusedPatternBinds $ when (null bndrs && not ok_nobind_pat) $ - addDiagnostic (WarningWithFlag Opt_WarnUnusedPatternBinds) $ - unusedPatBindWarn bind' + addTcRnDiagnostic (TcRnUnusedPatternBinds bind') ; fvs' `seq` -- See Note [Free-variable space leak] return (bind', bndrs, all_fvs) } @@ -1345,11 +1345,6 @@ nonStdGuardErr guards = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") 4 (interpp'SP guards) -unusedPatBindWarn :: HsBind GhcRn -> SDoc -unusedPatBindWarn bind - = hang (text "This pattern-binding binds no variables:") - 2 (ppr bind) - dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) = addErrAt (locA loc) $ diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index b747f73987..8daf355ab4 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -22,8 +22,6 @@ module GHC.Rename.Names ( checkConName, mkChildEnv, findChildren, - dodgyMsg, - dodgyMsgInsert, findImportUsage, getMinimalImports, printMinimalImports, @@ -40,6 +38,7 @@ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -1162,9 +1161,9 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where -- Warn when importing T(..) if T was exported abstractly emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (dodgyImportWarn n) + addTcRnDiagnostic (TcRnDodgyImports n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addDiagnostic (WarningWithFlag Opt_WarnMissingImportList) (missingImportListItem ieRdr) + addTcRnDiagnostic (TcRnMissingImportList ieRdr) emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) @@ -2003,26 +2002,6 @@ badImportItemErr iface decl_spec ie avails illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item - = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) - -dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc -dodgyMsg kind tc ie - = sep [ text "The" <+> kind <+> text "item" - -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) - <+> quotes (ppr ie) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - -dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) -dodgyMsgInsert tc = IEThingAll noAnn ii - where - ii :: LIEWrappedName (IdP (GhcPass p)) - ii = noLocA (IEName $ noLocA tc) - - addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _) @@ -2046,10 +2025,6 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -missingImportListItem :: IE GhcPs -> SDoc -missingImportListItem ie - = text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list" - moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) <> colon, diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 98e8cb2899..d8bead6645 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -17,6 +17,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Driver.Env.Types @@ -910,9 +911,7 @@ check_cross_stage_lifting top_lvl name ps_var pend_splice = PendingRnSplice UntypedExpSplice name lift_expr -- Warning for implicit lift (#17804) - ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) - (text "The variable" <+> quotes (ppr name) <+> - text "is implicitly lifted in the TH quotation") + ; addDetailedDiagnostic (TcRnImplicitLift name) -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index c6da9f1b9b..ffabf0f69c 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,10 +1,60 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage -module GHC.Tc.Errors.Ppr where +module GHC.Tc.Errors.Ppr ( + ) where + +import GHC.Prelude import GHC.Tc.Errors.Types import GHC.Types.Error +import GHC.Driver.Flags +import GHC.Hs +import GHC.Utils.Outputable instance Diagnostic TcRnMessage where - diagnosticMessage (TcRnUnknownMessage m) = diagnosticMessage m - diagnosticReason (TcRnUnknownMessage m) = diagnosticReason m + diagnosticMessage = \case + TcRnUnknownMessage m + -> diagnosticMessage m + TcRnImplicitLift id_or_name errInfo + -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + , getErrInfo errInfo + ] + TcRnUnusedPatternBinds bind + -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] + TcRnDodgyImports name + -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)] + TcRnDodgyExports name + -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)] + TcRnMissingImportList ie + -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> + text "does not have an explicit import list" + ] + diagnosticReason = \case + TcRnUnknownMessage m + -> diagnosticReason m + TcRnImplicitLift{} + -> WarningWithFlag Opt_WarnImplicitLift + TcRnUnusedPatternBinds{} + -> WarningWithFlag Opt_WarnUnusedPatternBinds + TcRnDodgyImports{} + -> WarningWithFlag Opt_WarnDodgyImports + TcRnDodgyExports{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + +dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgy_msg kind tc ie + = sep [ text "The" <+> kind <+> text "item" + <+> quotes (ppr ie) + <+> text "suggests that", + quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", + text "but it has none" ] + +dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) +dodgy_msg_insert tc = IEThingAll noAnn ii + where + ii :: LIEWrappedName (IdP (GhcPass p)) + ii = noLocA (IEName $ noLocA tc) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 1241735191..6da4cd6613 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,12 +1,78 @@ +{-# LANGUAGE GADTs #-} module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) + , ErrInfo(..) ) where +import GHC.Hs import GHC.Types.Error +import GHC.Types.Name (Name) +import GHC.Types.Name.Reader +import GHC.Utils.Outputable +import Data.Typeable + +-- The majority of TcRn messages come with extra context about the error, +-- and this newtype captures it. +newtype ErrInfo = ErrInfo { getErrInfo :: SDoc } -- | An error which might arise during typechecking/renaming. -data TcRnMessage - = TcRnUnknownMessage !DiagnosticMessage - -- ^ Simply rewraps a generic 'DiagnosticMessage'. More - -- constructors will be added in the future (#18516). +data TcRnMessage where + {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins + to provide custom diagnostic messages originated during typechecking/renaming. + -} + TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage + {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when + a Template Haskell quote implicitly uses 'lift'. + + Example: + warning1 :: Lift t => t -> Q Exp + warning1 x = [| x |] + + Test cases: th/T17804 + -} + TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage + {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) + that occurs if a pattern binding binds no variables at all, unless it is a + lone wild-card pattern, or a banged pattern. + + Example: + Just _ = rhs3 -- Warning: unused pattern binding + (_, _) = rhs4 -- Warning: unused pattern binding + _ = rhs3 -- No warning: lone wild-card pattern + !() = rhs4 -- No warning: banged pattern; behaves like seq + + Test cases: rename/{T13646,T17c,T17e,T7085} + -} + TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage + {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when + a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported + abstractly, i.e. 'T'. + + Test cases: rename/should_compile/T7167 + -} + TcRnDodgyImports :: RdrName -> TcRnMessage + {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype + 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a + type/data family. + + Example: + module Foo ( + T(..) -- Warning: T is a type synonym + , A(..) -- Warning: A is a type family + , C(..) -- Warning: C is a data family + ) where + + type T = Int + type family A :: * -> * + data family C :: * -> * + + Test cases: warnings/should_compile/DodgyExports01 + -} + TcRnDodgyExports :: Name -> TcRnMessage + {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when + an import declaration does not explicitly list all the names brought into scope. + + Test cases: rename/should_compile/T4489 + -} + TcRnMissingImportList :: IE GhcPs -> TcRnMessage diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index a874e04fd7..18924c39d5 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Hs import GHC.Types.FieldLabel import GHC.Builtin.Names +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType @@ -394,8 +395,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod addUsedKids (ieWrappedName rdr) gres when (null gres) $ if isTyConName name - then addDiagnostic (WarningWithFlag Opt_WarnDodgyExports) - (dodgyExportWarn name) + then addTcRnDiagnostic (TcRnDodgyExports name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) @@ -759,10 +759,6 @@ missingModuleExportWarn mod text "is missing an export list"] -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item - = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) - exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp = text "In the" <+> text (herald ++ ":") <+> ppr exp diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 1f0fce7f4e..b800583416 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -45,6 +45,7 @@ import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core.UsageEnv ( unitUE ) import GHC.Rename.Env ( addUsedGRE ) import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) +import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Zonk ( hsLitType ) @@ -1136,9 +1137,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) [getRuntimeRep id_ty, id_ty] -- Warning for implicit lift (#17804) - ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) - (text "The variable" <+> quotes (ppr id) <+> - text "is implicitly lifted in the TH quotation") + ; addDetailedDiagnostic (TcRnImplicitLift id) -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index f1a5425b6f..730e666a2a 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -92,7 +92,7 @@ module GHC.Tc.Utils.Monad( failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, - warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, + warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, addDetailedDiagnostic, addTcRnDiagnostic, addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic, mkErrInfo, @@ -1548,6 +1548,25 @@ addDiagnosticTcM reason (env0, msg) addDiagnostic :: DiagnosticReason -> SDoc -> TcRn () addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty +-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' +-- given some additional context about the diagnostic. +addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM () +addDetailedDiagnostic mkMsg = do + loc <- getSrcSpanM + printer <- getPrintUnqualified + dflags <- getDynFlags + env0 <- tcInitTidyEnv + ctxt <- getErrCtxt + err_info <- mkErrInfo env0 ctxt + reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info))) + +addTcRnDiagnostic :: TcRnMessage -> TcM () +addTcRnDiagnostic msg = do + loc <- getSrcSpanM + printer <- getPrintUnqualified + dflags <- getDynFlags + reportDiagnostic (mkMsgEnvelope dflags loc printer msg) + -- | Display a diagnostic for a given source location. addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn () addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty -- cgit v1.2.1