Add diagnostic codes

This MR adds diagnostic codes, assigning unique numeric codes to
error and warnings, e.g.

  error: [GHC-53633]
  Pattern match is redundant

This is achieved as follows:

  - a type family GhcDiagnosticCode that gives the diagnostic code
    for each diagnostic constructor,
  - a type family ConRecursInto that specifies whether to recur into
    an argument of the constructor to obtain a more fine-grained code
    (e.g. different error codes for different 'deriving' errors),
  - generics machinery to generate the value-level function assigning
    each diagnostic its error code; see Note [Diagnostic codes using generics]
    in GHC.Types.Error.Codes.

The upshot is that, to add a new diagnostic code, contributors only need
to modify the two type families mentioned above. All logic relating to
diagnostic codes is thus contained to the GHC.Types.Error.Codes module,
with no code duplication.

This MR also refactors error message datatypes a bit, ensuring we can
derive Generic for them, and cleans up the logic around constraint
solver reports by splitting up 'TcSolverReportInfo' into separate
datatypes (see #20772).

Fixes #21684

4 files changed, 30 insertions, 26 deletions

diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index ea251c2bcb..0f1c9084d7 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -340,14 +340,14 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
 
 -- This makes a convenient place to check
 -- that the C identifier is valid for C
-checkCTarget :: ForeignImport p -> CCallTarget -> TcM ()
+checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
 checkCTarget idecl (StaticTarget _ str _ _) = do
     checkCg (Right idecl) backendValidityOfCImport
     checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
 
 checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
 
-checkMissingAmpersand :: ForeignImport p -> [Type] -> Type -> TcM ()
+checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
 checkMissingAmpersand idecl arg_tys res_ty
   | null arg_tys && isFunPtrTy res_ty
   = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl
@@ -497,7 +497,8 @@ checkSafe, noCheckSafe :: Bool
 checkSafe   = True
 noCheckSafe = False
 
-checkCg :: Either (ForeignExport p) (ForeignImport p) -> (Backend -> Validity' ExpectedBackends) -> TcM ()
+checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
+        -> (Backend -> Validity' ExpectedBackends) -> TcM ()
 checkCg decl check = do
     dflags <- getDynFlags
     let bcknd = backend dflags
@@ -508,7 +509,8 @@ checkCg decl check = do
 
 -- Calling conventions
 
-checkCConv :: Either (ForeignExport p) (ForeignImport p) -> CCallConv -> TcM CCallConv
+checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
+           -> CCallConv -> TcM CCallConv
 checkCConv _ CCallConv    = return CCallConv
 checkCConv _ CApiConv     = return CApiConv
 checkCConv decl StdCallConv = do
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 1c72c877ab..dd67b7f2b2 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1334,7 +1334,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
                                        [getRuntimeRep id_ty, id_ty]
 
                    -- Warning for implicit lift (#17804)
-        ; addDetailedDiagnostic (TcRnImplicitLift id)
+        ; addDetailedDiagnostic (TcRnImplicitLift $ idName id)
 
                    -- Update the pending splices
         ; ps <- readMutVar ps_var
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index e1a0c2401b..94f11dd5ea 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -1159,7 +1159,8 @@ check_match_pats _ (MG { mg_alts = L _ [] })
     = return ()
 check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) })
     | Just bad_matches <- mb_bad_matches
-    = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext match1 bad_matches
+    = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
+                 $ MatchArgMatches match1 bad_matches
     | otherwise
     = return ()
   where
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 251d17c27f..027ae27aff 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -800,7 +800,7 @@ tcTExpTy m_ty exp_ty
        ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }
   where
     err_msg ty
-      = TcRnUnknownMessage $ mkPlainError noHints $
+      = mkTcRnUnknownMessage $ mkPlainError noHints $
       vcat [ text "Illegal polytype:" <+> ppr ty
              , text "The type of a Typed Template Haskell expression must" <+>
                text "not have any quantification." ]
@@ -1256,7 +1256,7 @@ runMeta' show_code ppr_hs run_and_convert expr
                                                 -- see where this splice is
              do { mb_result <- run_and_convert expr_span hval
                 ; case mb_result of
-                    Left err     -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)
+                    Left err     -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
                                        ; return $! result } }
 
@@ -1274,7 +1274,7 @@ runMeta' show_code ppr_hs run_and_convert expr
         let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
                         nest 2 (text exn_msg),
                         if show_code then text "Code:" <+> ppr expr else empty]
-        failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
+        failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
 
 {-
 Note [Running typed splices in the zonker]
@@ -1390,10 +1390,11 @@ instance TH.Quasi TcM where
 
   -- 'msg' is forced to ensure exceptions don't escape,
   -- see Note [Exceptions in TH]
-  qReport True msg  = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg)
-  qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $
+  qReport True msg  = seqList msg $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (text msg)
+  qReport False msg = seqList msg $ addDiagnostic $ mkTcRnUnknownMessage $
     mkPlainDiagnostic WarningWithoutFlag noHints (text msg)
 
+  qLocation :: TcM TH.Loc
   qLocation = do { m <- getModule
                  ; l <- getSrcSpanM
                  ; r <- case l of
@@ -1444,7 +1445,7 @@ instance TH.Quasi TcM where
       th_origin <- getThSpliceOrigin
       let either_hval = convertToHsDecls th_origin l thds
       ds <- case either_hval of
-              Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
+              Left exn -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
                 hang (text "Error in a declaration passed to addTopDecls:")
                    2 exn
               Right ds -> return ds
@@ -1462,7 +1463,7 @@ instance TH.Quasi TcM where
       checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
         = bindName name
       checkTopDecl _
-        = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+        = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
           text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
 
       bindName :: RdrName -> TcM ()
@@ -1472,7 +1473,7 @@ instance TH.Quasi TcM where
              }
 
       bindName name =
-          addErr $ TcRnUnknownMessage $ mkPlainError noHints $
+          addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
           hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")
              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
 
@@ -1499,8 +1500,8 @@ instance TH.Quasi TcM where
             2
             (text "Plugins in the current package can't be specified.")
       case r of
-        Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err
-        FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err
+        Found {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err
+        FoundMultiple {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err
         _ -> return ()
       th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
       updTcRef th_coreplugins_var (plugin:)
@@ -1525,7 +1526,7 @@ instance TH.Quasi TcM where
     th_doc_var <- tcg_th_docs <$> getGblEnv
     resolved_doc_loc <- resolve_loc doc_loc
     is_local <- checkLocalName resolved_doc_loc
-    unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text
+    unless is_local $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text
       "Can't add documentation to" <+> ppr_loc doc_loc <+>
       text "as it isn't inside the current module"
     let ds = mkGeneratedHsDocString s
@@ -1615,7 +1616,7 @@ lookupThInstName th_type = do
     Right (_, (inst:_)) -> return $ getName inst
     Right (_, [])       -> noMatches
   where
-    noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
+    noMatches = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
       text "Couldn't find any instances of"
         <+> ppr_th th_type
         <+> text "to add documentation to"
@@ -1654,7 +1655,7 @@ lookupThInstName th_type = do
     inst_cls_name TH.WildCardT               = inst_cls_name_err
     inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err
 
-    inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
+    inst_cls_name_err = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
       text "Couldn't work out what instance"
         <+> ppr_th th_type
         <+> text "is supposed to be"
@@ -1945,7 +1946,7 @@ reifyInstances' th_nm th_tys
                      ; let matches = lookupFamInstEnv inst_envs tc tys
                      ; traceTc "reifyInstances'2" (ppr matches)
                      ; return $ Right (tc, map fim_instance matches) }
-            _  -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $
+            _  -> bale_out $ mkTcRnUnknownMessage $ mkPlainError noHints $
                   (hang (text "reifyInstances:" <+> quotes (ppr ty))
                       2 (text "is not a class constraint or type family application")) }
   where
@@ -1954,7 +1955,7 @@ reifyInstances' th_nm th_tys
 
     cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
     cvt origin loc th_ty = case convertToHsType origin loc th_ty of
-      Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
+      Left msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
       Right ty -> return ty
 
 {-
@@ -2055,17 +2056,17 @@ tcLookupTh name
      do { mb_thing <- tcLookupImported_maybe name
         ; case mb_thing of
             Succeeded thing -> return (AGlobal thing)
-            Failed msg      -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
+            Failed msg      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
     }}}}
 
 notInScope :: TH.Name -> TcRnMessage
-notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $
+notInScope th_name = mkTcRnUnknownMessage $ mkPlainError noHints $
   quotes (text (TH.pprint th_name)) <+>
           text "is not in scope at a reify"
         -- Ugh! Rather an indirect way to display the name
 
 notInEnv :: Name -> TcRnMessage
-notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $
+notInEnv name = mkTcRnUnknownMessage $ mkPlainError noHints $
   quotes (ppr name) <+> text "is not in the type environment at a reify"
 
 ------------------------------
@@ -2074,7 +2075,7 @@ reifyRoles th_name
   = do { thing <- getThing th_name
        ; case thing of
            AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
-           _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))
+           _ -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))
        }
   where
     reify_role Nominal          = TH.NominalR
@@ -2868,7 +2869,7 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
 mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
 
 noTH :: SDoc -> SDoc -> TcM a
-noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
+noTH s d = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
   (hsep [text "Can't represent" <+> s <+>
          text "in Template Haskell:",
            nest 2 d])