Add structured error messages for GHC.Tc.Utils.Env

Tracking ticket: #20119

MR: !10129

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

29 files changed, 270 insertions, 115 deletions

diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 7a4dcdc15f..92527851c5 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -7,7 +7,7 @@
 The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.
 -}
 
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
 
 module GHC.Core.InstEnv (
         DFunId, InstMatch, ClsInstLookupResult,
@@ -19,6 +19,7 @@ module GHC.Core.InstEnv (
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
         InstEnvs(..), VisibleOrphanModules, InstEnv,
+        LookupInstanceErrReason (..),
         mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,
         filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,
         anyInstEnv,
@@ -51,6 +52,7 @@ import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Basic
 import GHC.Types.Id
+import GHC.Generics (Generic)
 import Data.Data        ( Data )
 import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
 import qualified Data.List.NonEmpty as NE
@@ -928,18 +930,28 @@ anyone noticing, so it's manifestly not ruining anyone's day.)
 -- yield 'Left errorMessage'.
 lookupUniqueInstEnv :: InstEnvs
                     -> Class -> [Type]
-                    -> Either SDoc (ClsInst, [Type])
+                    -> Either LookupInstanceErrReason (ClsInst, [Type])
 lookupUniqueInstEnv instEnv cls tys
   = case lookupInstEnv False instEnv cls tys of
       ([(inst, inst_tys)], _, _)
              | noFlexiVar -> Right (inst, inst_tys')
-             | otherwise  -> Left $ text "flexible type variable:" <+>
-                                    (ppr $ mkTyConApp (classTyCon cls) tys)
+             | otherwise  -> Left $ LookupInstErrFlexiVar
              where
                inst_tys'  = [ty | Just ty <- inst_tys]
                noFlexiVar = all isJust inst_tys
-      _other -> Left $ text "instance not found" <+>
-                       (ppr $ mkTyConApp (classTyCon cls) tys)
+      _other -> Left $ LookupInstErrNotFound
+
+-- | Why a particular typeclass application couldn't be looked up.
+data LookupInstanceErrReason =
+  -- | Tyvars aren't an exact match.
+  LookupInstErrNotExact
+  |
+  -- | One of the tyvars is flexible.
+  LookupInstErrFlexiVar
+  |
+  -- | No matching instance was found.
+  LookupInstErrNotFound
+  deriving (Generic)
 
 data Coherence = IsCoherent | IsIncoherent
 
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index e657141358..ff52727716 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -915,7 +915,7 @@ checkThLocalName name
              Nothing -> return () ;  -- Not a locally-bound thing
              Just (top_lvl, bind_lvl, use_stage) ->
     do  { let use_lvl = thLevel use_stage
-        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
+        ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
         ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
                                                <+> ppr use_stage
                                                <+> ppr use_lvl)
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index f0f5b426b7..91f79af520 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -43,7 +43,7 @@ import GHC.Core.Type
 import GHC.Hs
 import GHC.Types.Name.Reader
 import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env
+-- import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Monad
 import GHC.Types.Error
 import GHC.Types.Name
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index edb30d6e98..3de952f2d8 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -20,6 +20,7 @@ module GHC.Tc.Errors.Ppr
   , pprHsDocContext
   , inHsDocContext
   , TcRnMessageOpts(..)
+  , pprTyThingUsedWrong
   )
   where
 
@@ -51,7 +52,7 @@ import GHC.Hs
 
 import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Constraint
-import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
+import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode, TcTyThing )
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType
@@ -100,6 +101,7 @@ import Data.Ord ( comparing )
 import Data.Bifunctor
 import GHC.Types.Name.Env
 import qualified Language.Haskell.TH as TH
+import {-# SOURCE #-} GHC.Tc.Types (pprTcTyThingCategory)
 
 data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
                                        }
@@ -665,6 +667,10 @@ instance Diagnostic TcRnMessage where
     TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason
       -> mkSimpleDecorated $
            derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason
+    TcRnLookupInstance cls tys reason
+      -> mkSimpleDecorated $
+          text "Couldn't match instance:" <+>
+           lookupInstanceErrDiagnosticMessage cls tys reason
     TcRnLazyGADTPattern
       -> mkSimpleDecorated $
            hang (text "An existential or GADT data constructor cannot be used")
@@ -1433,6 +1439,20 @@ instance Diagnostic TcRnMessage where
       hsep [ text "Unknown type variable" <> plural errorVars
            , text "on the RHS of injectivity condition:"
            , interpp'SP errorVars ]
+    TcRnBadlyStaged reason bind_lvl use_lvl
+      -> mkSimpleDecorated $
+         text "Stage error:" <+> pprStageCheckReason reason <+>
+         hsep [text "is bound at stage" <+> ppr bind_lvl,
+               text "but used at stage" <+> ppr use_lvl]
+    TcRnStageRestriction reason
+      -> mkSimpleDecorated $
+         sep [ text "GHC stage restriction:"
+             , nest 2 (vcat [ pprStageCheckReason reason <+>
+                              text "is used in a top-level splice, quasi-quote, or annotation,"
+                            , text "and must be imported, not defined locally"])]
+    TcRnTyThingUsedWrong sort thing name
+      -> mkSimpleDecorated $
+         pprTyThingUsedWrong sort thing name
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1655,6 +1675,8 @@ instance Diagnostic TcRnMessage where
            DerivErrBadConstructor{}                -> ErrorWithoutFlag
            DerivErrGenerics{}                      -> ErrorWithoutFlag
            DerivErrEnumOrProduct{}                 -> ErrorWithoutFlag
+    TcRnLookupInstance _ _ _
+      -> ErrorWithoutFlag
     TcRnLazyGADTPattern
       -> ErrorWithoutFlag
     TcRnArrowProcGADTPattern
@@ -1903,6 +1925,12 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnUnknownTyVarsOnRhsOfInjCond{}
       -> ErrorWithoutFlag
+    TcRnBadlyStaged{}
+      -> ErrorWithoutFlag
+    TcRnStageRestriction{}
+      -> ErrorWithoutFlag
+    TcRnTyThingUsedWrong{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -2123,6 +2151,8 @@ instance Diagnostic TcRnMessage where
              -> noHints
     TcRnCannotDeriveInstance cls _ _ newtype_deriving rea
       -> deriveInstanceErrReasonHints cls newtype_deriving rea
+    TcRnLookupInstance _ _ _
+      -> noHints
     TcRnLazyGADTPattern
       -> noHints
     TcRnArrowProcGADTPattern
@@ -2391,6 +2421,12 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnUnknownTyVarsOnRhsOfInjCond{}
       -> noHints
+    TcRnBadlyStaged{}
+      -> noHints
+    TcRnStageRestriction{}
+      -> noHints
+    TcRnTyThingUsedWrong{}
+      -> noHints
 
   diagnosticCode = constructorCode
 
@@ -2770,6 +2806,18 @@ derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \cas
        in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
           (ppr1 $$ text "  or" $$ ppr2)
 
+lookupInstanceErrDiagnosticMessage :: Class
+                                   -> [Type]
+                                   -> LookupInstanceErrReason
+                                   -> SDoc
+lookupInstanceErrDiagnosticMessage cls tys = \case
+  LookupInstErrNotExact
+    -> text "Not an exact match (i.e., some variables get instantiated)"
+  LookupInstErrFlexiVar
+    -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys)
+  LookupInstErrNotFound
+    -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys)
+
 {- *********************************************************************
 *                                                                      *
               Outputable SolverReportErrCtxt (for debugging)
@@ -3833,6 +3881,10 @@ pprScopeError rdr_name scope_err =
         2 (what <+> quotes (ppr rdr_name) <+> text "in this module")
     UnknownSubordinate doc ->
       quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc
+    NotInScopeTc env ->
+      vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+>
+      text "is not in scope during type checking, but it passed the renamer",
+      text "tcl_env of environment:" <+> ppr env]
   where
     what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
 
@@ -3845,6 +3897,7 @@ scopeErrorHints scope_err =
     MissingBinding _ hints -> hints
     NoTopLevelBinding      -> noHints
     UnknownSubordinate {}  -> noHints
+    NotInScopeTc _         -> noHints
 
 {- *********************************************************************
 *                                                                      *
@@ -4429,3 +4482,26 @@ pprConversionFailReason = \case
     text "Function binding for"
     <+> quotes (text (TH.pprint nm))
     <+> text "has no equations"
+
+pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc
+pprTyThingUsedWrong sort thing name =
+  pprTcTyThingCategory thing <+> quotes (ppr name) <+>
+  text "used as a" <+> pprWrongThingSort sort
+
+pprWrongThingSort :: WrongThingSort -> SDoc
+pprWrongThingSort =
+  text . \case
+    WrongThingType -> "type"
+    WrongThingDataCon -> "data constructor"
+    WrongThingPatSyn -> "pattern synonym"
+    WrongThingConLike -> "constructor-like thing"
+    WrongThingClass -> "class"
+    WrongThingTyCon -> "type constructor"
+    WrongThingAxiom -> "axiom"
+
+pprStageCheckReason :: StageCheckReason -> SDoc
+pprStageCheckReason = \case
+  StageCheckInstance _ t ->
+    text "instance for" <+> quotes (ppr t)
+  StageCheckSplice t ->
+    quotes (ppr t)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 85e7a18377..aa43f6f581 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -92,6 +92,8 @@ module GHC.Tc.Errors.Types (
   , NonStandardGuards(..)
   , RuleLhsErrReason(..)
   , HsigShapeMismatchReason(..)
+  , WrongThingSort(..)
+  , StageCheckReason(..)
   ) where
 
 import GHC.Prelude
@@ -103,7 +105,7 @@ import GHC.Tc.Types.Constraint
 import GHC.Tc.Types.Evidence (EvBindsVar)
 import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
                            , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing
-                           , FixedRuntimeRepOrigin(..) )
+                           , FixedRuntimeRepOrigin(..), InstanceWhat )
 import GHC.Tc.Types.Rank (Rank)
 import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
 import GHC.Types.Avail (AvailInfo)
@@ -125,7 +127,7 @@ import GHC.Core.Coercion.Axiom (CoAxBranch)
 import GHC.Core.ConLike (ConLike)
 import GHC.Core.DataCon (DataCon)
 import GHC.Core.FamInstEnv (FamInst)
-import GHC.Core.InstEnv (ClsInst)
+import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst)
 import GHC.Core.PatSyn (PatSyn)
 import GHC.Core.Predicate (EqRel, predTypeEqRel)
 import GHC.Core.TyCon (TyCon, TyConFlavour)
@@ -146,6 +148,7 @@ import GHC.Unit.Module.Warnings (WarningTxt)
 import qualified Language.Haskell.TH.Syntax as TH
 
 import GHC.Generics ( Generic )
+import GHC.Types.Name.Env (NameEnv)
 
 {-
 Note [Migrating TcM Messages]
@@ -3209,6 +3212,51 @@ data TcRnMessage where
   -}
   TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage
 
+  {-| TcRnLookupInstance groups several errors emitted when looking up class instances.
+
+    Test cases:
+      none
+  -}
+  TcRnLookupInstance
+    :: !Class
+    -> ![Type]
+    -> !LookupInstanceErrReason
+    -> TcRnMessage
+
+  {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an
+    invalid stage.
+
+    Test cases:
+      T17820d
+  -}
+  TcRnBadlyStaged
+    :: !StageCheckReason -- ^ The binding being spliced.
+    -> !Int -- ^ The binding stage.
+    -> !Int -- ^ The stage at which the binding is used.
+    -> TcRnMessage
+
+  {-| TcRnStageRestriction is an error that occurs when a top level splice refers to
+    a local name.
+
+    Test cases:
+      T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}
+  -}
+  TcRnStageRestriction
+    :: !StageCheckReason -- ^ The binding being spliced.
+    -> TcRnMessage
+
+  {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another
+    thing was expected.
+
+    Test cases:
+      none
+  -}
+  TcRnTyThingUsedWrong
+    :: !WrongThingSort -- ^ Expected thing.
+    -> !TcTyThing -- ^ Thing used wrongly.
+    -> !Name -- ^ Name of the thing used wrongly.
+    -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -4173,6 +4221,12 @@ data NotInScopeError
   -- or, a class doesn't have an associated type with this name,
   -- or, a record doesn't have a record field with this name.
   | UnknownSubordinate SDoc
+
+  -- | A name is not in scope during type checking but passed the renamer.
+  --
+  -- Test cases:
+  --   none
+  | NotInScopeTc (NameEnv TcTyThing)
   deriving Generic
 
 -- | Create a @"not in scope"@ error message for the given 'RdrName'.
@@ -4471,3 +4525,16 @@ data HsigShapeMismatchReason =
   -}
   HsigShapeNotUnifiable !Name !Name !Bool
   deriving (Generic)
+
+data WrongThingSort
+  = WrongThingType
+  | WrongThingDataCon
+  | WrongThingPatSyn
+  | WrongThingConLike
+  | WrongThingClass
+  | WrongThingTyCon
+  | WrongThingAxiom
+
+data StageCheckReason
+  = StageCheckInstance !InstanceWhat !PredType
+  | StageCheckSplice !Name
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 222755f6c9..374567ce69 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1994,7 +1994,7 @@ tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
 
            APromotionErr err -> promotionErr name err
 
-           _  -> wrongThingErr "type" thing name }
+           _  -> wrongThingErr WrongThingType thing name }
 
 {-
 Note [Recursion through the kinds]
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 4019b44278..71dd30638b 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -4,7 +4,7 @@
 module GHC.Tc.Instance.Class (
      matchGlobalInst,
      ClsInstResult(..),
-     InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
+     safeOverlap, instanceReturnsDictCon,
      AssocInstInfo(..), isNotAssociated,
   ) where
 
@@ -21,6 +21,7 @@ import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType)
 import GHC.Tc.Instance.Typeable
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
 import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
 import GHC.Rename.Env( addUsedGRE )
 
@@ -31,7 +32,7 @@ import GHC.Builtin.Names
 import GHC.Types.FieldLabel
 import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )
 import GHC.Types.SafeHaskell
-import GHC.Types.Name   ( Name, pprDefinedAt )
+import GHC.Types.Name   ( Name )
 import GHC.Types.Var.Env ( VarEnv )
 import GHC.Types.Id
 import GHC.Types.Var
@@ -86,13 +87,6 @@ isNotAssociated (InClsInst {})     = False
 *                                                                    *
 **********************************************************************-}
 
--- | Indicates if Instance met the Safe Haskell overlapping instances safety
--- check.
---
--- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
-type SafeOverlapping = Bool
-
 data ClsInstResult
   = NoInstance   -- Definitely no instance
 
@@ -103,23 +97,6 @@ data ClsInstResult
 
   | NotSure      -- Multiple matches and/or one or more unifiers
 
-data InstanceWhat  -- How did we solve this constraint?
-  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
-                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
-  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)
-                         -- See Note [Well-staged instance evidence]
-
-  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is
-                         --   KnownNat, .. etc (classes with no top-level evidence)
-
-  | LocalInstance        -- Solved by a quantified constraint
-                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
-  | TopLevInstance       -- Solved by a top-level instance decl
-      { iw_dfun_id   :: DFunId
-      , iw_safe_over :: SafeOverlapping }
-
 instance Outputable ClsInstResult where
   ppr NoInstance = text "NoInstance"
   ppr NotSure    = text "NotSure"
@@ -127,15 +104,6 @@ instance Outputable ClsInstResult where
                , cir_what = what })
     = text "OneInst" <+> vcat [ppr ev, ppr what]
 
-instance Outputable InstanceWhat where
-  ppr BuiltinInstance   = text "a built-in instance"
-  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"
-  ppr BuiltinEqInstance = text "a built-in equality instance"
-  ppr LocalInstance     = text "a locally-quantified instance"
-  ppr (TopLevInstance { iw_dfun_id = dfun })
-      = hang (text "instance" <+> pprSigmaType (idType dfun))
-           2 (text "--" <+> pprDefinedAt (idName dfun))
-
 safeOverlap :: InstanceWhat -> Bool
 safeOverlap (TopLevInstance { iw_safe_over = so }) = so
 safeOverlap _                                      = True
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index d92dca7e3d..703efdf786 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -16,7 +16,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )
 import GHC.Tc.Instance.FunDeps
 import GHC.Tc.Instance.Family
-import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap )
+import GHC.Tc.Instance.Class ( safeOverlap )
 
 import GHC.Tc.Types.Evidence
 import GHC.Utils.Outputable
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 5fdd4df702..73eea460bc 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -134,7 +134,7 @@ import qualified GHC.Tc.Utils.Env      as TcM
 
 import GHC.Driver.Session
 
-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )
+import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Solver.Types
 import GHC.Tc.Solver.InertSet
@@ -1420,11 +1420,9 @@ checkWellStagedDFun loc what pred
         Just bind_lvl | bind_lvl > impLevel ->
           wrapTcS $ TcM.setCtLocM loc $ do
               { use_stage <- TcM.getStage
-              ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+              ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) }
         _ ->
           return ()
-  where
-    pp_thing = text "instance for" <+> quotes (ppr pred)
 
 -- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)
 -- See Note [Well-staged instance evidence]
diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot
index 405374a06b..68902e98ae 100644
--- a/compiler/GHC/Tc/Types.hs-boot
+++ b/compiler/GHC/Tc/Types.hs-boot
@@ -22,3 +22,4 @@ setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv
 getLclEnvLoc :: TcLclEnv -> RealSrcSpan
 
 lclEnvInGeneratedCode :: TcLclEnv -> Bool
+pprTcTyThingCategory :: TcTyThing -> SDoc
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index ae6a618c37..bc1842e368 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -35,6 +35,8 @@ module GHC.Tc.Types.Origin (
   FRRArrowContext(..), pprFRRArrowContext,
   ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,
 
+  -- InstanceWhat
+  InstanceWhat(..), SafeOverlapping
   ) where
 
 import GHC.Prelude
@@ -1401,3 +1403,42 @@ pprExpectedFunTyHerald (ExpectedFunTyLam match)
 pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)
   = sep [ text "The function" <+> quotes (ppr expr)
         , text "requires" ]
+
+{- *******************************************************************
+*                                                                    *
+                       InstanceWhat
+*                                                                    *
+**********************************************************************-}
+
+-- | Indicates if Instance met the Safe Haskell overlapping instances safety
+-- check.
+--
+-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
+type SafeOverlapping = Bool
+
+data InstanceWhat  -- How did we solve this constraint?
+  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
+
+  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)
+                         -- See Note [Well-staged instance evidence]
+
+  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is
+                         --   KnownNat, .. etc (classes with no top-level evidence)
+
+  | LocalInstance        -- Solved by a quantified constraint
+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
+
+  | TopLevInstance       -- Solved by a top-level instance decl
+      { iw_dfun_id   :: DFunId
+      , iw_safe_over :: SafeOverlapping }
+
+instance Outputable InstanceWhat where
+  ppr BuiltinInstance   = text "a built-in instance"
+  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"
+  ppr BuiltinEqInstance = text "a built-in equality instance"
+  ppr LocalInstance     = text "a locally-quantified instance"
+  ppr (TopLevInstance { iw_dfun_id = dfun })
+      = hang (text "instance" <+> pprSigmaType (idType dfun))
+           2 (text "--" <+> pprDefinedAt (idName dfun))
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index da72eee97a..43263450ac 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -60,6 +60,7 @@ module GHC.Tc.Utils.Env(
         tcGetDefaultTys,
 
         -- Template Haskell stuff
+        StageCheckReason(..),
         checkWellStaged, tcMetaTy, thLevel,
         topIdLvl, isBrackStage,
 
@@ -67,7 +68,7 @@ module GHC.Tc.Utils.Env(
         newDFunName,
         newFamInstTyConName, newFamInstAxiomName,
         mkStableIdFromString, mkStableIdFromName,
-        mkWrapperName
+        mkWrapperName,
   ) where
 
 import GHC.Prelude
@@ -129,8 +130,8 @@ import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Name.Reader
 import GHC.Types.TyThing
-import GHC.Types.Error
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Tc.Errors.Ppr (pprTyThingUsedWrong)
 
 import Data.IORef
 import Data.List (intercalate)
@@ -192,21 +193,22 @@ importDecl_maybe hsc_env name
   | otherwise
   = initIfaceLoad hsc_env (importDecl name)
 
+-- | A 'TyThing'... except it's not the right sort.
+type WrongTyThing = TyThing
+
 ioLookupDataCon :: HscEnv -> Name -> IO DataCon
 ioLookupDataCon hsc_env name = do
   mb_thing <- ioLookupDataCon_maybe hsc_env name
   case mb_thing of
     Succeeded thing -> return thing
-    Failed msg      -> pprPanic "lookupDataConIO" msg
+    Failed thing    -> pprPanic "lookupDataConIO" (pprTyThingUsedWrong WrongThingDataCon (AGlobal thing) name)
 
-ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr WrongTyThing DataCon)
 ioLookupDataCon_maybe hsc_env name = do
     thing <- lookupGlobal hsc_env name
     return $ case thing of
         AConLike (RealDataCon con) -> Succeeded con
-        _                          -> Failed $
-          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
-                text "used as a data constructor"
+        _                          -> Failed thing
 
 addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
 addTypecheckedBinds tcg_env binds
@@ -274,42 +276,42 @@ tcLookupDataCon name = do
     thing <- tcLookupGlobal name
     case thing of
         AConLike (RealDataCon con) -> return con
-        _                          -> wrongThingErr "data constructor" (AGlobal thing) name
+        _                          -> wrongThingErr WrongThingDataCon (AGlobal thing) name
 
 tcLookupPatSyn :: Name -> TcM PatSyn
 tcLookupPatSyn name = do
     thing <- tcLookupGlobal name
     case thing of
         AConLike (PatSynCon ps) -> return ps
-        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name
+        _                       -> wrongThingErr WrongThingPatSyn (AGlobal thing) name
 
 tcLookupConLike :: Name -> TcM ConLike
 tcLookupConLike name = do
     thing <- tcLookupGlobal name
     case thing of
         AConLike cl -> return cl
-        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name
+        _           -> wrongThingErr WrongThingConLike (AGlobal thing) name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name = do
     thing <- tcLookupGlobal name
     case thing of
         ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
-        _                                           -> wrongThingErr "class" (AGlobal thing) name
+        _                                           -> wrongThingErr WrongThingClass (AGlobal thing) name
 
 tcLookupTyCon :: Name -> TcM TyCon
 tcLookupTyCon name = do
     thing <- tcLookupGlobal name
     case thing of
         ATyCon tc -> return tc
-        _         -> wrongThingErr "type constructor" (AGlobal thing) name
+        _         -> wrongThingErr WrongThingTyCon (AGlobal thing) name
 
 tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
 tcLookupAxiom name = do
     thing <- tcLookupGlobal name
     case thing of
         ACoAxiom ax -> return ax
-        _           -> wrongThingErr "axiom" (AGlobal thing) name
+        _           -> wrongThingErr WrongThingAxiom (AGlobal thing) name
 
 tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
 tcLookupLocatedGlobalId = addLocMA tcLookupId
@@ -326,17 +328,13 @@ tcLookupLocatedTyCon = addLocMA tcLookupTyCon
 tcLookupInstance :: Class -> [Type] -> TcM ClsInst
 tcLookupInstance cls tys
   = do { instEnv <- tcGetInstEnvs
-       ; case lookupUniqueInstEnv instEnv cls tys of
-           Left err             ->
-             failWithTc $ mkTcRnUnknownMessage
-                        $ mkPlainError noHints (text "Couldn't match instance:" <+> err)
-           Right (inst, tys)
-             | uniqueTyVars tys -> return inst
-             | otherwise        -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact)
+       ; let inst = lookupUniqueInstEnv instEnv cls tys >>= \ (inst, tys) ->
+                    if uniqueTyVars tys then Right inst else Left LookupInstErrNotExact
+        ; case inst of
+          Right i -> return i
+          Left err -> failWithTc (TcRnLookupInstance cls tys err)
        }
   where
-    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
-
     uniqueTyVars tys = all isTyVarTy tys
                     && hasNoDups (map getTyVar tys)
 
@@ -886,7 +884,7 @@ tcExtendRules lcl_rules thing_inside
 ************************************************************************
 -}
 
-checkWellStaged :: SDoc         -- What the stage check is for
+checkWellStaged :: StageCheckReason -- What the stage check is for
                 -> ThLevel      -- Binding level (increases inside brackets)
                 -> ThLevel      -- Use stage
                 -> TcM ()       -- Fail if badly staged, adding an error
@@ -895,22 +893,11 @@ checkWellStaged pp_thing bind_lvl use_lvl
   = return ()                   -- E.g.  \x -> [| $(f x) |]
 
   | bind_lvl == outerLevel      -- GHC restriction on top level splices
-  = stageRestrictionError pp_thing
+  = failWithTc (TcRnStageRestriction pp_thing)
 
   | otherwise                   -- Badly staged
   = failWithTc $                -- E.g.  \x -> $(f x)
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Stage error:" <+> pp_thing <+>
-        hsep   [text "is bound at stage" <+> ppr bind_lvl,
-                text "but used at stage" <+> ppr use_lvl]
-
-stageRestrictionError :: SDoc -> TcM a
-stageRestrictionError pp_thing
-  = failWithTc $
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [ text "GHC stage restriction:"
-        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
-                       , text "and must be imported, not defined locally"])]
+    TcRnBadlyStaged pp_thing bind_lvl use_lvl
 
 topIdLvl :: Id -> ThLevel
 -- Globals may either be imported, or may be from an earlier "chunk"
@@ -1173,12 +1160,9 @@ notFound name
            Splice {}
              | isUnboundName name -> failM  -- If the name really isn't in scope
                                             -- don't report it again (#11941)
-             | otherwise -> stageRestrictionError (quotes (ppr name))
+             | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))
            _ -> failWithTc $
-                mkTcRnUnknownMessage $ mkPlainError noHints $
-                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
-                     text "is not in scope during type checking, but it passed the renamer",
-                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
+                mkTcRnNotInScope (getRdrName name) (NotInScopeTc (tcl_env lcl_env))
                        -- Take care: printing the whole gbl env can
                        -- cause an infinite loop, in the case where we
                        -- are in the middle of a recursive TyCon/Class group;
@@ -1186,12 +1170,9 @@ notFound name
                        -- very unhelpful, because it hides one compiler bug with another
        }
 
-wrongThingErr :: String -> TcTyThing -> Name -> TcM a
-wrongThingErr expected thing name
-  = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-          (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
-                     text "used as a" <+> text expected)
-  in failWithTc msg
+wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
+wrongThingErr expected thing name =
+  failWithTc (TcRnTyThingUsedWrong expected thing name)
 
 {- Note [Out of scope might be a staging error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index dcbe78cf31..f088a7e6ab 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -27,7 +27,7 @@ import GHC.Data.Maybe
 -- friends:
 import GHC.Tc.Utils.Unify    ( tcSubTypeAmbiguity )
 import GHC.Tc.Solver         ( simplifyAmbiguityCheck )
-import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
+import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) )
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Rank
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index bc991393c4..1f9fb29905 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -37,6 +37,7 @@ import GHC.Exts     ( proxy# )
 import GHC.Generics
 import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) )
 import GHC.TypeNats ( Nat, KnownNat, natVal' )
+import GHC.Core.InstEnv (LookupInstanceErrReason)
 
 {- Note [Diagnostic codes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -535,6 +536,9 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult"              = 99412
   GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond"              = 88333
   GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond"               = 48254
+  GhcDiagnosticCode "TcRnBadlyStaged"                               = 28914
+  GhcDiagnosticCode "TcRnStageRestriction"                          = 18157
+  GhcDiagnosticCode "TcRnTyThingUsedWrong"                          = 10969
 
   -- IllegalNewtypeReason
   GhcDiagnosticCode "DoesNotHaveSingleField"                        = 23517
@@ -595,6 +599,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "MissingBinding"                                = 44432
   GhcDiagnosticCode "NoTopLevelBinding"                             = 10173
   GhcDiagnosticCode "UnknownSubordinate"                            = 54721
+  GhcDiagnosticCode "NotInScopeTc"                                  = 76329
 
   -- Diagnostic codes for deriving
   GhcDiagnosticCode "DerivErrNotWellKinded"                         = 62016
@@ -625,6 +630,11 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "DerivErrGenerics"                              = 30367
   GhcDiagnosticCode "DerivErrEnumOrProduct"                         = 58291
 
+  -- Diagnostic codes for instance lookup
+  GhcDiagnosticCode "LookupInstErrNotExact"                         = 10372
+  GhcDiagnosticCode "LookupInstErrFlexiVar"                         = 10373
+  GhcDiagnosticCode "LookupInstErrNotFound"                         = 10374
+
   -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason
   GhcDiagnosticCode "EmptyStmtsGroupInParallelComp"                 = 41242
   GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp"            = 92693
@@ -693,6 +703,7 @@ type family ConRecursInto con where
   ConRecursInto "TcRnWithHsDocContext"     = 'Just TcRnMessage
 
   ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason
+  ConRecursInto "TcRnLookupInstance"       = 'Just LookupInstanceErrReason
   ConRecursInto "TcRnPragmaWarning"        = 'Just (WarningTxt GhcRn)
   ConRecursInto "TcRnNotInScope"           = 'Just NotInScopeError
   ConRecursInto "TcRnIllegalNewtype"       = 'Just IllegalNewtypeReason
diff --git a/testsuite/tests/annotations/should_fail/annfail03.stderr b/testsuite/tests/annotations/should_fail/annfail03.stderr
index 625b5d1b47..77362f800e 100644
--- a/testsuite/tests/annotations/should_fail/annfail03.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail03.stderr
@@ -1,5 +1,5 @@
 
-annfail03.hs:17:11:
+annfail03.hs:17:11: [GHC-18157]
     GHC stage restriction:
       ‘InModule’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/annotations/should_fail/annfail04.stderr b/testsuite/tests/annotations/should_fail/annfail04.stderr
index 0226a40134..4130717a1e 100644
--- a/testsuite/tests/annotations/should_fail/annfail04.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail04.stderr
@@ -1,5 +1,5 @@
 
-annfail04.hs:14:12:
+annfail04.hs:14:12: [GHC-18157]
     GHC stage restriction:
       instance for ‘Thing
                       Int’ is used in a top-level splice, quasi-quote, or annotation,
diff --git a/testsuite/tests/annotations/should_fail/annfail06.stderr b/testsuite/tests/annotations/should_fail/annfail06.stderr
index 7a7f715fe4..8c17b71103 100644
--- a/testsuite/tests/annotations/should_fail/annfail06.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail06.stderr
@@ -1,5 +1,5 @@
 
-annfail06.hs:22:1:
+annfail06.hs:22:1: [GHC-18157]
     GHC stage restriction:
       instance for ‘Data
                       InstancesInWrongModule’ is used in a top-level splice, quasi-quote, or annotation,
diff --git a/testsuite/tests/annotations/should_fail/annfail09.stderr b/testsuite/tests/annotations/should_fail/annfail09.stderr
index 35bdaf7b48..22fe13193e 100644
--- a/testsuite/tests/annotations/should_fail/annfail09.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail09.stderr
@@ -1,5 +1,5 @@
 
-annfail09.hs:11:11:
+annfail09.hs:11:11: [GHC-18157]
     GHC stage restriction:
       ‘g’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/quasiquotation/qq001/qq001.stderr b/testsuite/tests/quasiquotation/qq001/qq001.stderr
index 350dd418c0..d1fdbdf62e 100644
--- a/testsuite/tests/quasiquotation/qq001/qq001.stderr
+++ b/testsuite/tests/quasiquotation/qq001/qq001.stderr
@@ -1,5 +1,5 @@
 
-qq001.hs:7:16:
+qq001.hs:7:16: [GHC-18157]
     GHC stage restriction:
       ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/quasiquotation/qq002/qq002.stderr b/testsuite/tests/quasiquotation/qq002/qq002.stderr
index 12ab3751dd..984ce45272 100644
--- a/testsuite/tests/quasiquotation/qq002/qq002.stderr
+++ b/testsuite/tests/quasiquotation/qq002/qq002.stderr
@@ -1,5 +1,5 @@
 
-qq002.hs:8:10:
+qq002.hs:8:10: [GHC-18157]
     GHC stage restriction:
       ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/quasiquotation/qq003/qq003.stderr b/testsuite/tests/quasiquotation/qq003/qq003.stderr
index dd7fa8c872..ad6972ada4 100644
--- a/testsuite/tests/quasiquotation/qq003/qq003.stderr
+++ b/testsuite/tests/quasiquotation/qq003/qq003.stderr
@@ -1,5 +1,5 @@
 
-qq003.hs:5:26:
+qq003.hs:5:26: [GHC-18157]
     GHC stage restriction:
       ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/quasiquotation/qq004/qq004.stderr b/testsuite/tests/quasiquotation/qq004/qq004.stderr
index 7cd33e1e6f..97a0bb0b1a 100644
--- a/testsuite/tests/quasiquotation/qq004/qq004.stderr
+++ b/testsuite/tests/quasiquotation/qq004/qq004.stderr
@@ -1,5 +1,5 @@
 
-qq004.hs:8:21:
+qq004.hs:8:21: [GHC-18157]
     GHC stage restriction:
       ‘parse’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820a.stderr b/testsuite/tests/th/T17820a.stderr
index 2a4b5c2f25..81126d1aa5 100644
--- a/testsuite/tests/th/T17820a.stderr
+++ b/testsuite/tests/th/T17820a.stderr
@@ -1,5 +1,5 @@
 
-T17820a.hs:7:17: error:
+T17820a.hs:7:17: error: [GHC-18157]
     GHC stage restriction:
       ‘C’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820b.stderr b/testsuite/tests/th/T17820b.stderr
index 941a3b1e49..4ebe1f60b9 100644
--- a/testsuite/tests/th/T17820b.stderr
+++ b/testsuite/tests/th/T17820b.stderr
@@ -1,5 +1,5 @@
 
-T17820b.hs:7:17: error:
+T17820b.hs:7:17: error: [GHC-18157]
     GHC stage restriction:
       ‘f’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820c.stderr b/testsuite/tests/th/T17820c.stderr
index 469a94352c..d6d0bcd42f 100644
--- a/testsuite/tests/th/T17820c.stderr
+++ b/testsuite/tests/th/T17820c.stderr
@@ -1,5 +1,5 @@
 
-T17820c.hs:8:18: error:
+T17820c.hs:8:18: error: [GHC-18157]
     GHC stage restriction:
       ‘meth’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/th/T17820d.stderr b/testsuite/tests/th/T17820d.stderr
index 3d624c7104..526228094d 100644
--- a/testsuite/tests/th/T17820d.stderr
+++ b/testsuite/tests/th/T17820d.stderr
@@ -1,5 +1,5 @@
 
-T17820d.hs:6:38: error:
+T17820d.hs:6:38: error: [GHC-28914]
     • Stage error: ‘foo’ is bound at stage 2 but used at stage 1
     • In the untyped splice: $(const [| 0 |] foo)
       In the Template Haskell quotation
diff --git a/testsuite/tests/th/T17820e.stderr b/testsuite/tests/th/T17820e.stderr
index 2c74b263e2..a1984c126a 100644
--- a/testsuite/tests/th/T17820e.stderr
+++ b/testsuite/tests/th/T17820e.stderr
@@ -1,5 +1,5 @@
 
-T17820e.hs:9:17: error:
+T17820e.hs:9:17: error: [GHC-18157]
     GHC stage restriction:
       ‘C’ is used in a top-level splice, quasi-quote, or annotation,
       and must be imported, not defined locally
diff --git a/testsuite/tests/th/T21547.stderr b/testsuite/tests/th/T21547.stderr
index a37b98aa85..60b76cf424 100644
--- a/testsuite/tests/th/T21547.stderr
+++ b/testsuite/tests/th/T21547.stderr
@@ -1,5 +1,5 @@
 
-T21547.hs:9:14: error:
+T21547.hs:9:14: error: [GHC-18157]
     • GHC stage restriction:
         instance for ‘base-4.16.0.0:Data.Typeable.Internal.Typeable
                         T’ is used in a top-level splice, quasi-quote, or annotation,
diff --git a/testsuite/tests/th/T5795.stderr b/testsuite/tests/th/T5795.stderr
index 95af718c98..bc0dd2ef0f 100644
--- a/testsuite/tests/th/T5795.stderr
+++ b/testsuite/tests/th/T5795.stderr
@@ -1,5 +1,5 @@
 
-T5795.hs:9:7: error:
+T5795.hs:9:7: error: [GHC-18157]
     • GHC stage restriction:
         ‘ty’ is used in a top-level splice, quasi-quote, or annotation,
         and must be imported, not defined locally