Convert Diagnostics in GHC.Tc.Gen.Splice (#20116)

Replaces uses of `TcRnUnknownMessage` in `GHC.Tc.Gen.Splice` with
structured diagnostics.

closes #20116

5 files changed, 538 insertions, 79 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 0c152b27b7..84338000b9 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -96,6 +97,7 @@ import Data.List ( groupBy, sortBy, tails
 import Data.Ord ( comparing )
 import Data.Bifunctor
 import GHC.Types.Name.Env
+import qualified Language.Haskell.TH as TH
 
 data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
                                        }
@@ -1046,6 +1048,108 @@ instance Diagnostic TcRnMessage where
           sneaky_eq_spec
             = any (\eq -> any (( == eqSpecTyVar eq) . binderVar) invisible_binders)
                 $ dataConEqSpec con
+    TcRnTypedTHWithPolyType ty
+      -> mkSimpleDecorated $
+        vcat [ text "Illegal polytype:" <+> ppr ty
+             , text "The type of a Typed Template Haskell expression must" <+>
+               text "not have any quantification." ]
+    TcRnSpliceThrewException phase _exn exn_msg expr show_code
+      -> mkSimpleDecorated $
+           vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:"
+                , nest 2 (text exn_msg)
+                , if show_code then text "Code:" <+> ppr expr else empty]
+         where phaseStr =
+                 case phase of
+                   SplicePhase_Run -> "run"
+                   SplicePhase_CompileAndLink -> "compile and link"
+    TcRnInvalidTopDecl _decl
+      -> mkSimpleDecorated $
+         text "Only function, value, annotation, and foreign import declarations may be added with addTopDecls"
+    TcRnNonExactName name
+      -> mkSimpleDecorated $
+         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.")
+    TcRnAddInvalidCorePlugin plugin
+      -> mkSimpleDecorated $
+         hang
+           (text "addCorePlugin: invalid plugin module "
+              <+> text (show plugin)
+           )
+           2
+           (text "Plugins in the current package can't be specified.")
+    TcRnAddDocToNonLocalDefn doc_loc
+      -> mkSimpleDecorated $
+         text "Can't add documentation to" <+> ppr_loc doc_loc <+>
+         text "as it isn't inside the current module"
+      where
+        ppr_loc (TH.DeclDoc n) = text $ TH.pprint n
+        ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n
+        ppr_loc (TH.InstDoc t) = text $ TH.pprint t
+        ppr_loc TH.ModuleDoc = text "the module header"
+
+    TcRnFailedToLookupThInstName th_type reason
+      -> mkSimpleDecorated $
+         case reason of
+           NoMatchesFound ->
+             text "Couldn't find any instances of"
+               <+> text (TH.pprint th_type)
+               <+> text "to add documentation to"
+           CouldNotDetermineInstance ->
+             text "Couldn't work out what instance"
+               <+> text (TH.pprint th_type)
+               <+> text "is supposed to be"
+    TcRnCannotReifyInstance ty
+      -> mkSimpleDecorated $
+         hang (text "reifyInstances:" <+> quotes (ppr ty))
+            2 (text "is not a class constraint or type family application")
+    TcRnCannotReifyOutOfScopeThing th_name
+      -> mkSimpleDecorated $
+         quotes (text (TH.pprint th_name)) <+>
+                 text "is not in scope at a reify"
+               -- Ugh! Rather an indirect way to display the name
+    TcRnCannotReifyThingNotInTypeEnv name
+      -> mkSimpleDecorated $
+         quotes (ppr name) <+> text "is not in the type environment at a reify"
+    TcRnNoRolesAssociatedWithThing thing
+      -> mkSimpleDecorated $
+         text "No roles associated with" <+> (ppr thing)
+    TcRnCannotRepresentType sort ty
+      -> mkSimpleDecorated $
+         hsep [text "Can't represent" <+> sort_doc <+>
+               text "in Template Haskell:",
+                 nest 2 (ppr ty)]
+       where
+         sort_doc = text $
+           case sort of
+             LinearInvisibleArgument -> "linear invisible argument"
+             CoercionsInTypes -> "coercions in types"
+    TcRnRunSpliceFailure mCallingFnName (ConversionFail what reason)
+      -> mkSimpleDecorated
+           . addCallingFn
+           . addSpliceInfo
+           $ pprConversionFailReason reason
+      where
+        addCallingFn rest =
+          case mCallingFnName of
+            Nothing -> rest
+            Just callingFn ->
+              hang (text ("Error in a declaration passed to " ++ callingFn ++ ":"))
+                 2 rest
+        addSpliceInfo = case what of
+          ConvDec d -> addSliceInfo' "declaration" d
+          ConvExp e -> addSliceInfo' "expression" e
+          ConvPat p -> addSliceInfo' "pattern" p
+          ConvType t -> addSliceInfo' "type" t
+        addSliceInfo' what item reasonErr = reasonErr $$ descr
+          where
+                -- Show the item in pretty syntax normally,
+                -- but with all its constructors if you say -dppr-debug
+            descr = hang (text "When splicing a TH" <+> text what <> colon)
+                       2 (getPprDebug $ \case
+                           True  -> text (show item)
+                           False -> text (TH.pprint item))
+    TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
+    TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1382,6 +1486,36 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnIllegalNewtype{}
       -> ErrorWithoutFlag
+    TcRnTypedTHWithPolyType{}
+      -> ErrorWithoutFlag
+    TcRnSpliceThrewException{}
+      -> ErrorWithoutFlag
+    TcRnInvalidTopDecl{}
+      -> ErrorWithoutFlag
+    TcRnNonExactName{}
+      -> ErrorWithoutFlag
+    TcRnAddInvalidCorePlugin{}
+      -> ErrorWithoutFlag
+    TcRnAddDocToNonLocalDefn{}
+      -> ErrorWithoutFlag
+    TcRnFailedToLookupThInstName{}
+      -> ErrorWithoutFlag
+    TcRnCannotReifyInstance{}
+      -> ErrorWithoutFlag
+    TcRnCannotReifyOutOfScopeThing{}
+      -> ErrorWithoutFlag
+    TcRnCannotReifyThingNotInTypeEnv{}
+      -> ErrorWithoutFlag
+    TcRnNoRolesAssociatedWithThing{}
+      -> ErrorWithoutFlag
+    TcRnCannotRepresentType{}
+      -> ErrorWithoutFlag
+    TcRnRunSpliceFailure{}
+      -> ErrorWithoutFlag
+    TcRnReportCustomQuasiError isError _
+      -> if isError then ErrorWithoutFlag else WarningWithoutFlag
+    TcRnInterfaceLookupError{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -1720,6 +1854,36 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnIllegalNewtype{}
       -> noHints
+    TcRnTypedTHWithPolyType{}
+      -> noHints
+    TcRnSpliceThrewException{}
+      -> noHints
+    TcRnInvalidTopDecl{}
+      -> noHints
+    TcRnNonExactName{}
+      -> noHints
+    TcRnAddInvalidCorePlugin{}
+      -> noHints
+    TcRnAddDocToNonLocalDefn{}
+      -> noHints
+    TcRnFailedToLookupThInstName{}
+      -> noHints
+    TcRnCannotReifyInstance{}
+      -> noHints
+    TcRnCannotReifyOutOfScopeThing{}
+      -> noHints
+    TcRnCannotReifyThingNotInTypeEnv{}
+      -> noHints
+    TcRnNoRolesAssociatedWithThing{}
+      -> noHints
+    TcRnCannotRepresentType{}
+      -> noHints
+    TcRnRunSpliceFailure{}
+      -> noHints
+    TcRnReportCustomQuasiError{}
+      -> noHints
+    TcRnInterfaceLookupError{}
+      -> noHints
 
   diagnosticCode = constructorCode
 
@@ -3610,3 +3774,79 @@ pprHsDocContext (ConDeclCtx [name])
    = text "the definition of data constructor" <+> quotes (ppr name)
 pprHsDocContext (ConDeclCtx names)
    = text "the definition of data constructors" <+> interpp'SP names
+
+pprConversionFailReason :: ConversionFailReason -> SDoc
+pprConversionFailReason = \case
+  IllegalOccName ctxt_ns occ ->
+    text "Illegal" <+> pprNameSpace ctxt_ns
+    <+> text "name:" <+> quotes (text occ)
+  SumAltArityExceeded alt arity ->
+    text "Sum alternative" <+> text (show alt)
+    <+> text "exceeds its arity," <+> text (show arity)
+  IllegalSumAlt alt ->
+    vcat [ text "Illegal sum alternative:" <+> text (show alt)
+         , nest 2 $ text "Sum alternatives must start from 1" ]
+  IllegalSumArity arity ->
+    vcat [ text "Illegal sum arity:" <+> text (show arity)
+         , nest 2 $ text "Sums must have an arity of at least 2" ]
+  MalformedType typeOrKind ty ->
+    text "Malformed " <> text ty_str <+> text (show ty)
+    where ty_str = case typeOrKind of
+                     TypeLevel -> "type"
+                     KindLevel -> "kind"
+  IllegalLastStatement do_or_lc stmt ->
+    vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon
+         , nest 2 $ ppr stmt
+         , text "(It should be an expression.)" ]
+  KindSigsOnlyAllowedOnGADTs ->
+    text "Kind signatures are only allowed on GADTs"
+  IllegalDeclaration declDescr bad_decls ->
+    sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon
+        , nest 2 bads ]
+    where
+      (what, bads) = case bad_decls of
+        IllegalDecls (NE.toList -> decls) ->
+            (text "declaration" <> plural decls, vcat $ map ppr decls)
+        IllegalFamDecls (NE.toList -> decls) ->
+            ( text "family declaration" <> plural decls, vcat $ map ppr decls)
+      descrDoc = text $ case declDescr of
+                   InstanceDecl -> "an instance declaration"
+                   WhereClause -> "a where clause"
+                   LetBinding -> "a let expression"
+                   LetExpression -> "a let expression"
+                   ClssDecl -> "a class declaration"
+  CannotMixGADTConsWith98Cons ->
+    text "Cannot mix GADT constructors with Haskell 98"
+    <+> text "constructors"
+  EmptyStmtListInDoBlock ->
+    text "Empty stmt list in do-block"
+  NonVarInInfixExpr ->
+    text "Non-variable expression is not allowed in an infix expression"
+  MultiWayIfWithoutAlts ->
+    text "Multi-way if-expression with no alternatives"
+  CasesExprWithoutAlts ->
+    text "\\cases expression with no alternatives"
+  ImplicitParamsWithOtherBinds ->
+    text "Implicit parameters mixed with other bindings"
+  InvalidCCallImpent from ->
+    text (show from) <+> text "is not a valid ccall impent"
+  RecGadtNoCons ->
+    text "RecGadtC must have at least one constructor name"
+  GadtNoCons ->
+    text "GadtC must have at least one constructor name"
+  InvalidTypeInstanceHeader tys ->
+    text "Invalid type instance header:"
+    <+> text (show tys)
+  InvalidTyFamInstLHS lhs ->
+    text "Invalid type family instance LHS:"
+    <+> text (show lhs)
+  InvalidImplicitParamBinding ->
+    text "Implicit parameter binding only allowed in let or where"
+  DefaultDataInstDecl adts ->
+    (text "Default data instance declarations"
+    <+> text "are not allowed:")
+      $$ ppr adts
+  FunBindLacksEquations nm ->
+    text "Function binding for"
+    <+> quotes (text (TH.pprint nm))
+    <+> text "has no equations"
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index fdf7c3d665..e3b3ade094 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -77,6 +77,14 @@ module GHC.Tc.Errors.Types (
   , ExpectedBackends
   , ArgOrResult(..)
   , MatchArgsContext(..), MatchArgBadMatches(..)
+  , ConversionFailReason(..)
+  , UnrepresentableTypeDescr(..)
+  , LookupTHInstNameErrReason(..)
+  , SplicePhase(..)
+  , THDeclDescriptor(..)
+  , RunSpliceFailReason(..)
+  , ThingBeingConverted(..)
+  , IllegalDecls(..)
   ) where
 
 import GHC.Prelude
@@ -95,6 +103,7 @@ import GHC.Types.Error
 import GHC.Types.Hint (UntickedPromotedThing(..))
 import GHC.Types.ForeignCall (CLabelString)
 import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan)
+import qualified GHC.Types.Name.Occurrence as OccName
 import GHC.Types.Name.Reader
 import GHC.Types.SrcLoc
 import GHC.Types.TyThing (TyThing)
@@ -119,12 +128,14 @@ import GHC.Types.Basic
 import GHC.Utils.Misc (capitalise, filterOut)
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Data.FastString (FastString)
+import GHC.Exception.Type (SomeException)
 
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import qualified Data.List.NonEmpty as NE
 import           Data.Typeable (Typeable)
 import GHC.Unit.Module.Warnings (WarningTxt)
+import qualified Language.Haskell.TH.Syntax as TH
 
 import GHC.Generics ( Generic )
 
@@ -2344,6 +2355,190 @@ data TcRnMessage where
   -}
   TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage
 
+  {-| TcRnTypedTHWithPolyType is an error that signifies the illegal use
+      of a polytype in a typed template haskell expression.
+
+      Example(s):
+      bad :: (forall a. a -> a) -> ()
+      bad = $$( [|| \_ -> () ||] )
+
+     Test cases: th/T11452
+  -}
+  TcRnTypedTHWithPolyType :: !TcType -> TcRnMessage
+
+  {-| TcRnSpliceThrewException is an error that occurrs when running a template
+      haskell splice throws an exception.
+
+      Example(s):
+
+     Test cases: annotations/should_fail/annfail12
+                 perf/compiler/MultiLayerModulesTH_Make
+                 perf/compiler/MultiLayerModulesTH_OneShot
+                 th/T10796b
+                 th/T19470
+                 th/T19709d
+                 th/T5358
+                 th/T5976
+                 th/T7276a
+                 th/T8987
+                 th/TH_exn1
+                 th/TH_exn2
+                 th/TH_runIO
+  -}
+  TcRnSpliceThrewException
+    :: !SplicePhase
+    -> !SomeException
+    -> !String -- ^ Result of showing the exception (cannot be done safely outside IO)
+    -> !(LHsExpr GhcTc)
+    -> !Bool -- True <=> Print the expression
+    -> TcRnMessage
+
+  {-| TcRnInvalidTopDecl is a template haskell error occurring when one of the 'Dec's passed to
+      'addTopDecls' is not a function, value, annotation, or foreign import declaration.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnInvalidTopDecl :: !(HsDecl GhcPs) -> TcRnMessage
+
+  {-| TcRnNonExactName is a template haskell error for when a declaration being
+      added is bound to a name that is not fully known.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnNonExactName :: !RdrName -> TcRnMessage
+
+  {-| TcRnAddInvalidCorePlugin is a template haskell error indicating that a
+      core plugin being added has an invalid module due to being in the current package.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnAddInvalidCorePlugin
+    :: !String -- ^ Module name
+    -> TcRnMessage
+
+  {-| TcRnAddDocToNonLocalDefn is a template haskell error for documentation being added to a
+      definition which is not in the current module.
+
+      Example(s):
+
+     Test cases: showIface/should_fail/THPutDocExternal
+  -}
+  TcRnAddDocToNonLocalDefn :: !TH.DocLoc -> TcRnMessage
+
+  {-| TcRnFailedToLookupThInstName is a template haskell error that occurrs when looking up an
+      instance fails.
+
+      Example(s):
+
+     Test cases: showIface/should_fail/THPutDocNonExistent
+  -}
+  TcRnFailedToLookupThInstName :: !TH.Type -> !LookupTHInstNameErrReason -> TcRnMessage
+
+  {-| TcRnCannotReifyInstance is a template haskell error for when an instance being reified
+      via `reifyInstances` is not a class constraint or type family application.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnCannotReifyInstance :: !Type -> TcRnMessage
+
+  {-| TcRnCannotReifyOutOfScopeThing is a template haskell error indicating
+      that the given name is not in scope and therefore cannot be reified.
+
+      Example(s):
+
+     Test cases: th/T16976f
+  -}
+  TcRnCannotReifyOutOfScopeThing :: !TH.Name -> TcRnMessage
+
+  {-| TcRnCannotReifyThingNotInTypeEnv is a template haskell error occurring
+      when the given name is not in the type environment and therefore cannot be reified.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnCannotReifyThingNotInTypeEnv :: !Name -> TcRnMessage
+
+  {-| TcRnNoRolesAssociatedWithName is a template haskell error for when the user
+      tries to reify the roles of a given name but it is not something that has
+      roles associated with it.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnNoRolesAssociatedWithThing :: !TcTyThing -> TcRnMessage
+
+  {-| TcRnCannotRepresentThing is a template haskell error indicating that a
+      type cannot be reified because it does not have a representation in template haskell.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnCannotRepresentType :: !UnrepresentableTypeDescr -> !Type -> TcRnMessage
+
+  {-| TcRnRunSpliceFailure is an error indicating that a template haskell splice
+      failed to be converted into a valid expression.
+
+      Example(s):
+
+     Test cases: th/T10828a
+                 th/T10828b
+                 th/T12478_4
+                 th/T15270A
+                 th/T15270B
+                 th/T16895a
+                 th/T16895b
+                 th/T16895c
+                 th/T16895d
+                 th/T16895e
+                 th/T17379a
+                 th/T17379b
+                 th/T18740d
+                 th/T2597b
+                 th/T2674
+                 th/T3395
+                 th/T7484
+                 th/T7667a
+                 th/TH_implicitParamsErr1
+                 th/TH_implicitParamsErr2
+                 th/TH_implicitParamsErr3
+                 th/TH_invalid_add_top_decl
+  -}
+  TcRnRunSpliceFailure
+    :: !(Maybe String) -- ^ Name of the function used to run the splice
+    -> !RunSpliceFailReason
+    -> TcRnMessage
+
+  {-| TcRnUserErrReported is an error or warning thrown using 'qReport' from
+      the 'Quasi' instance of 'TcM'.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnReportCustomQuasiError
+    :: !Bool -- True => Error, False => Warning
+    -> !String -- Error body
+    -> TcRnMessage
+
+  {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file.
+
+      Example(s):
+
+     Test cases:
+  -}
+  TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -2361,6 +2556,55 @@ instance Outputable TypeDataForbids where
   ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags"
   ppr TypeDataForbidsDerivingClauses       = text "Deriving clauses"
 
+data RunSpliceFailReason
+  = ConversionFail !ThingBeingConverted !ConversionFailReason
+  deriving Generic
+
+-- | Identifies the TH splice attempting to be converted
+data ThingBeingConverted
+  = ConvDec !TH.Dec
+  | ConvExp !TH.Exp
+  | ConvPat !TH.Pat
+  | ConvType !TH.Type
+
+-- | The reason a TH splice could not be converted to a Haskell expression
+data ConversionFailReason
+  = IllegalOccName !OccName.NameSpace !String
+  | SumAltArityExceeded !TH.SumAlt !TH.SumArity
+  | IllegalSumAlt !TH.SumAlt
+  | IllegalSumArity !TH.SumArity
+  | MalformedType !TypeOrKind !TH.Type
+  | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs))
+  | KindSigsOnlyAllowedOnGADTs
+  | IllegalDeclaration !THDeclDescriptor !IllegalDecls
+  | CannotMixGADTConsWith98Cons
+  | EmptyStmtListInDoBlock
+  | NonVarInInfixExpr
+  | MultiWayIfWithoutAlts
+  | CasesExprWithoutAlts
+  | ImplicitParamsWithOtherBinds
+  | InvalidCCallImpent !String -- ^ Source
+  | RecGadtNoCons
+  | GadtNoCons
+  | InvalidTypeInstanceHeader !TH.Type
+  | InvalidTyFamInstLHS !TH.Type
+  | InvalidImplicitParamBinding
+  | DefaultDataInstDecl ![LDataFamInstDecl GhcPs]
+  | FunBindLacksEquations !TH.Name
+  deriving Generic
+
+data IllegalDecls
+  = IllegalDecls    !(NE.NonEmpty (LHsDecl GhcPs))
+  | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs))
+
+-- | Label for a TH declaration
+data THDeclDescriptor
+  = InstanceDecl
+  | WhereClause
+  | LetBinding
+  | LetExpression
+  | ClssDecl
+
 -- | Specifies which back ends can handle a requested foreign import or export
 type ExpectedBackends = [Backend]
 
@@ -3473,3 +3717,16 @@ data MatchArgBadMatches where
     ::  { matchArgFirstMatch :: LocatedA (Match GhcRn body)
         , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }
     -> MatchArgBadMatches
+
+-- | The phase in which an exception was encountered when dealing with a TH splice
+data SplicePhase
+  = SplicePhase_Run
+  | SplicePhase_CompileAndLink
+
+data LookupTHInstNameErrReason
+  = NoMatchesFound
+  | CouldNotDetermineInstance
+
+data UnrepresentableTypeDescr
+  = LinearInvisibleArgument
+  | CoercionsInTypes
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index f4490244f8..1ac3882d50 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -124,7 +124,7 @@ import GHC.Utils.Panic.Plain
 import GHC.Utils.Lexeme
 import GHC.Utils.Outputable
 import GHC.Utils.Logger
-import GHC.Utils.Exception (throwIO, ErrorCall(..))
+import GHC.Utils.Exception (throwIO, ErrorCall(..), SomeException(..))
 
 import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) )
 
@@ -794,16 +794,10 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
 -- Takes a m and tau and returns the type m (TExp tau)
 tcTExpTy :: TcType -> TcType -> TcM TcType
 tcTExpTy m_ty exp_ty
-  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
+  = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType exp_ty)
        ; codeCon <- tcLookupTyCon codeTyConName
        ; let rep = getRuntimeRep exp_ty
        ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }
-  where
-    err_msg ty
-      = mkTcRnUnknownMessage $ mkPlainError noHints $
-      vcat [ text "Illegal polytype:" <+> ppr ty
-             , text "The type of a Typed Template Haskell expression must" <+>
-               text "not have any quantification." ]
 
 quotationCtxtDoc :: LHsExpr GhcRn -> SDoc
 quotationCtxtDoc br_body
@@ -1023,15 +1017,15 @@ runAnnotation target expr = do
                ann_value = serialized
            }
 
-convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized)
+convertAnnotationWrapper :: ForeignHValue -> TcM Serialized
 convertAnnotationWrapper fhv = do
   interp <- tcGetInterp
   case interpInstance interp of
-    ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv
+    ExternalInterp {} -> runTH THAnnWrapper fhv
 #if defined(HAVE_INTERNAL_INTERPRETER)
     InternalInterp    -> do
       annotation_wrapper <- liftIO $ wormhole interp fhv
-      return $ Right $
+      return $
         case unsafeCoerce annotation_wrapper of
            AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
                -- Got the value and dictionaries: build the serialized value and
@@ -1118,7 +1112,7 @@ defaultRunMeta (MetaT r)
 defaultRunMeta (MetaD r)
   = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
 defaultRunMeta (MetaAW r)
-  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
+  = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper)
     -- We turn off showing the code in meta-level exceptions because doing so exposes
     -- the toAnnotationWrapper function that we slap around the user's code
 
@@ -1188,7 +1182,7 @@ Previously, we failed to abort in cases (b) and (c), leading to #19709.
 ---------------
 runMeta' :: Bool                 -- Whether code should be printed in the exception message
          -> (hs_syn -> SDoc)                                    -- how to print the code
-         -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn))        -- How to run x
+         -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x
          -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or
                                  --    something like that
          -> TcM hs_syn           -- Of type t
@@ -1236,7 +1230,7 @@ runMeta' show_code ppr_hs run_and_convert expr
         ; either_hval <- tryM $ liftIO $
                          GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr
         ; case either_hval of {
-            Left exn   -> fail_with_exn "compile and link" exn ;
+            Left exn   -> fail_with_exn SplicePhase_CompileAndLink exn ;
             Right (hval, needed_mods, needed_pkgs) -> do
 
         {       -- Coerce it to Q t, and run it
@@ -1257,7 +1251,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 (mkTcRnUnknownMessage $ mkPlainError noHints err)
+                    Left err     -> failWithTc (TcRnRunSpliceFailure Nothing err)
                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
                                        ; return $! result } }
 
@@ -1265,17 +1259,15 @@ runMeta' show_code ppr_hs run_and_convert expr
             Right v -> return v
             Left se -> case fromException se of
                          Just IOEnvFailure -> failM -- Error already in Tc monad
-                         _ -> fail_with_exn "run" se -- Exception
+                         _ -> fail_with_exn SplicePhase_Run se -- Exception
         }}}
   where
     -- see Note [Concealed TH exceptions]
-    fail_with_exn :: Exception e => String -> e -> TcM a
+    fail_with_exn :: Exception e => SplicePhase -> e -> TcM a
     fail_with_exn phase exn = do
         exn_msg <- liftIO $ Panic.safeShowException exn
-        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 (mkTcRnUnknownMessage $ mkPlainError noHints msg)
+        failWithTc
+          $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code
 
 {-
 Note [Running typed splices in the zonker]
@@ -1391,9 +1383,8 @@ 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 $ mkTcRnUnknownMessage $ mkPlainError noHints (text msg)
-  qReport False msg = seqList msg $ addDiagnostic $ mkTcRnUnknownMessage $
-    mkPlainDiagnostic WarningWithoutFlag noHints (text msg)
+  qReport True msg  = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg
+  qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg
 
   qLocation :: TcM TH.Loc
   qLocation = do { m <- getModule
@@ -1446,9 +1437,8 @@ instance TH.Quasi TcM where
       th_origin <- getThSpliceOrigin
       let either_hval = convertToHsDecls th_origin l thds
       ds <- case either_hval of
-              Left exn -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                hang (text "Error in a declaration passed to addTopDecls:")
-                   2 exn
+              Left exn -> failWithTc
+                            $ TcRnRunSpliceFailure (Just "addTopDecls") exn
               Right ds -> return ds
       mapM_ (checkTopDecl . unLoc) ds
       th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
@@ -1463,9 +1453,8 @@ instance TH.Quasi TcM where
         = return ()
       checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
         = bindName name
-      checkTopDecl _
-        = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-          text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
+      checkTopDecl d
+        = addErr $ TcRnInvalidTopDecl d
 
       bindName :: RdrName -> TcM ()
       bindName (Exact n)
@@ -1473,10 +1462,7 @@ instance TH.Quasi TcM where
              ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
              }
 
-      bindName name =
-          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.")
+      bindName name = addErr $ TcRnNonExactName name
 
   qAddForeignFilePath lang fp = do
     var <- fmap tcg_th_foreign_files getGblEnv
@@ -1494,15 +1480,10 @@ instance TH.Quasi TcM where
       let dflags    = hsc_dflags hsc_env
       let fopts     = initFinderOpts dflags
       r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
-      let err = hang
-            (text "addCorePlugin: invalid plugin module "
-               <+> text (show plugin)
-            )
-            2
-            (text "Plugins in the current package can't be specified.")
+      let err = TcRnAddInvalidCorePlugin plugin
       case r of
-        Found {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err
-        FoundMultiple {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err
+        Found {} -> addErr err
+        FoundMultiple {} -> addErr err
         _ -> return ()
       th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
       updTcRef th_coreplugins_var (plugin:)
@@ -1527,9 +1508,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 $ mkTcRnUnknownMessage $ mkPlainError noHints $ text
-      "Can't add documentation to" <+> ppr_loc doc_loc <+>
-      text "as it isn't inside the current module"
+    unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc
     let ds = mkGeneratedHsDocString s
         hd = lexHsDoc parseIdentifier ds
     hd' <- rnHsDoc hd
@@ -1540,11 +1519,6 @@ instance TH.Quasi TcM where
       resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)
       resolve_loc TH.ModuleDoc = pure ModuleDoc
 
-      ppr_loc (TH.DeclDoc n) = ppr_th n
-      ppr_loc (TH.ArgDoc n _) = ppr_th n
-      ppr_loc (TH.InstDoc t) = ppr_th t
-      ppr_loc TH.ModuleDoc = text "the module header"
-
       -- It doesn't make sense to add documentation to something not inside
       -- the current module. So check for it!
       checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
@@ -1617,10 +1591,8 @@ lookupThInstName th_type = do
     Right (_, (inst:_)) -> return $ getName inst
     Right (_, [])       -> noMatches
   where
-    noMatches = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      text "Couldn't find any instances of"
-        <+> ppr_th th_type
-        <+> text "to add documentation to"
+    noMatches = failWithTc $
+      TcRnFailedToLookupThInstName th_type NoMatchesFound
 
     -- Get the name of the class for the instance we are documenting
     -- > inst_cls_name (Monad Maybe) == Monad
@@ -1656,10 +1628,8 @@ 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 $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      text "Couldn't work out what instance"
-        <+> ppr_th th_type
-        <+> text "is supposed to be"
+    inst_cls_name_err = failWithTc $
+      TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance
 
     -- Basically does the opposite of 'mkThAppTs'
     -- > inst_arg_types (Monad Maybe) == [Maybe]
@@ -1947,16 +1917,14 @@ 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 $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                  (hang (text "reifyInstances:" <+> quotes (ppr ty))
-                      2 (text "is not a class constraint or type family application")) }
+            _  -> bale_out $ TcRnCannotReifyInstance ty }
   where
     doc = ClassInstanceCtx
     bale_out msg = failWithTc msg
 
     cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
     cvt origin loc th_ty = case convertToHsType origin loc th_ty of
-      Left msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
+      Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg)
       Right ty -> return ty
 
 {-
@@ -2057,18 +2025,15 @@ tcLookupTh name
      do { mb_thing <- tcLookupImported_maybe name
         ; case mb_thing of
             Succeeded thing -> return (AGlobal thing)
-            Failed msg      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
+            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)
     }}}}
 
 notInScope :: TH.Name -> TcRnMessage
-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
+notInScope th_name =
+  TcRnCannotReifyOutOfScopeThing th_name
 
 notInEnv :: Name -> TcRnMessage
-notInEnv name = mkTcRnUnknownMessage $ mkPlainError noHints $
-  quotes (ppr name) <+> text "is not in the type environment at a reify"
+notInEnv name = TcRnCannotReifyThingNotInTypeEnv name
 
 ------------------------------
 reifyRoles :: TH.Name -> TcM [TH.Role]
@@ -2076,7 +2041,7 @@ reifyRoles th_name
   = do { thing <- getThing th_name
        ; case thing of
            AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
-           _ -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))
+           _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing)
        }
   where
     reify_role Nominal          = TH.NominalR
@@ -2609,11 +2574,11 @@ reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 })
   | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2]
                         ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
 reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })
-  | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty)
+  | InvisArg <- af = noTH LinearInvisibleArgument ty
   | otherwise      = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]
                         ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) }
 reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH
-reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty)
+reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty
 
 reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type
 -- Arg of reify_for_all is always ForAllTy or a predicate FunTy
@@ -2869,11 +2834,8 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
 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 $ mkTcRnUnknownMessage $ mkPlainError noHints $
-  (hsep [text "Can't represent" <+> s <+>
-         text "in Template Haskell:",
-           nest 2 d])
+noTH :: UnrepresentableTypeDescr -> Type -> TcM a
+noTH s d = failWithTc $ TcRnCannotRepresentType s d
 
 ppr_th :: TH.Ppr a => a -> SDoc
 ppr_th x = text (TH.pprint x)
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 4cba3f20b1..7e5f339d3f 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -170,7 +170,7 @@ checkHsigIface tcg_env gr sig_iface
         -- tcg_env (TODO: but maybe this isn't relevant anymore).
         r <- tcLookupImported_maybe name
         case r of
-          Failed err -> addErr (mkTcRnUnknownMessage $ mkPlainError noHints err)
+          Failed err -> addErr (TcRnInterfaceLookupError name err)
           Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
 
       -- The hsig did NOT define this function; that means it must
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 5f73a56724..dec144f5bd 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -257,7 +257,7 @@ tcLookupGlobal name
     do  { mb_thing <- tcLookupImported_maybe name
         ; case mb_thing of
             Succeeded thing -> return thing
-            Failed msg      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)
+            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)
         }}}
 
 -- Look up only in this module's global env't. Don't look in imports, etc.