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

8 files changed, 154 insertions, 55 deletions

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