Port HsToCore messages to new infrastructure

This commit converts a bunch of HsToCore (Ds) messages to use the new
GHC's diagnostic message infrastructure. In particular the DsMessage
type has been expanded with a lot of type constructors, each
encapsulating a particular error and warning emitted during desugaring.

Due to the fact that levity polymorphism checking can happen both at the
Ds and at the TcRn level, a new `TcLevityCheckDsMessage` constructor has
been added to the `TcRnMessage` type.

40 files changed, 1016 insertions, 469 deletions

diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 409d0ff6d3..e61be3dd69 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -431,7 +431,7 @@ dsRule (L loc (HsRule { rd_name = name
         -- and take the body apart into a (f args) form
         ; dflags <- getDynFlags
         ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
-                Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ;
+                Left msg -> do { diagnosticDs msg; return Nothing } ;
                 Right (final_bndrs, fn_id, args) -> do
 
         { let is_local = isLocalId fn_id
@@ -466,26 +466,10 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
       | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
                        -- If imported with no unfolding, no worries
       , idInlineActivation lhs_id `competesWith` rule_act
-      = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing)
-                     (vcat [ hang (text "Rule" <+> pprRuleName rule_name
-                                     <+> text "may never fire")
-                                  2 (text "because" <+> quotes (ppr lhs_id)
-                                     <+> text "might inline first")
-                           , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
-                             <+> quotes (ppr lhs_id)
-                           , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
-
+      = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)
       | check_rules_too
       , bad_rule : _ <- get_bad_rules lhs_id
-      = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing)
-                     (vcat [ hang (text "Rule" <+> pprRuleName rule_name
-                                     <+> text "may never fire")
-                                  2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
-                                     <+> text "for"<+> quotes (ppr lhs_id)
-                                     <+> text "might fire first")
-                            , text "Probable fix: add phase [n] or [~n] to the competing rule"
-                            , whenPprDebug (ppr bad_rule) ])
-
+      = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)
       | otherwise
       = return ()
 
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 9183a4f8ed..cad3e82154 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -33,6 +33,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalB
 import GHC.Tc.Utils.TcType
 import GHC.Core.Type( splitPiTy )
 import GHC.Core.Multiplicity
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import GHC.Tc.Types.Evidence
 import GHC.Core
 import GHC.Core.FVs
@@ -40,6 +41,7 @@ import GHC.Core.Utils
 import GHC.Core.Make
 import GHC.HsToCore.Binds (dsHsWrapper)
 
+
 import GHC.Types.Id
 import GHC.Core.ConLike
 import GHC.Builtin.Types
@@ -121,8 +123,7 @@ mkCmdEnv tc_meths
                    -> Maybe Id -> DsM ()
     check_lev_poly _     Nothing = return ()
     check_lev_poly arity (Just id)
-      = dsNoLevPoly (nTimes arity res_type (idType id))
-          (text "In the result of the function" <+> quotes (ppr id))
+      = dsNoLevPoly (nTimes arity res_type (idType id)) (LevityCheckMkCmdEnv id)
 
 
 -- arr :: forall b c. (b -> c) -> a b c
@@ -631,8 +632,7 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
                                                (L loc stmts))
                                                                    env_ids = do
     putSrcSpanDsA loc $
-      dsNoLevPoly stmts_ty
-        (text "In the do-command:" <+> ppr do_block)
+      dsNoLevPoly stmts_ty (LevityCheckDoCmd do_block)
     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
     let env_ty = mkBigCoreVarTupTy env_ids
     core_fst <- mkFstExpr env_ty stack_ty
@@ -702,8 +702,7 @@ dsfixCmd
                 DIdSet,         -- subset of local vars that occur free
                 [Id])           -- the same local vars as a list, fed back
 dsfixCmd ids local_vars stk_ty cmd_ty cmd
-  = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty
-           (text "When desugaring the command:" <+> ppr cmd)
+  = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty (LevityCheckDesugaringCmd cmd)
        ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
 
 -- Feed back the list of local variables actually used a command,
@@ -792,8 +791,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 --              ---> premap (\ (xs) -> ((xs), ())) c
 
 dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
-    putSrcSpanDsA loc $ dsNoLevPoly res_ty
-                         (text "In the command:" <+> ppr body)
+    putSrcSpanDsA loc $ dsNoLevPoly res_ty (LevityCheckInCmd body)
     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
     let env_ty = mkBigCoreVarTupTy env_ids
     env_var <- newSysLocalDs Many env_ty
@@ -861,7 +859,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
         out_ty = mkBigCoreVarTupTy out_ids
         before_c_ty = mkCorePairTy in_ty1 out_ty
         after_c_ty = mkCorePairTy c_ty out_ty
-    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
+    dsNoLevPoly c_ty LevityCheckCmdStmt
     snd_fn <- mkSndExpr c_ty out_ty
     return (do_premap ids in_ty before_c_ty out_ty core_mux $
                 do_compose ids before_c_ty after_c_ty out_ty
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index db5bb68706..c5a47f388a 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -28,6 +28,7 @@ import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )
 import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )
 
 import GHC.HsToCore.Monad
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.GuardedRHSs
 import GHC.HsToCore.Utils
 import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
@@ -90,8 +91,8 @@ dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
 dsTopLHsBinds binds
      -- see Note [Strict binds checks]
   | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
-  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
-       ; mapBagM_ (top_level_err "strict bindings")             bang_binds
+  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds
+       ; mapBagM_ (top_level_err StrictBinds)       bang_binds
        ; return nilOL }
 
   | otherwise
@@ -107,10 +108,9 @@ dsTopLHsBinds binds
     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
 
-    top_level_err desc (L loc bind)
+    top_level_err bindsType (L loc bind)
       = putSrcSpanDs (locA loc) $
-        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
-                  2 (ppr bind))
+        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
 
 
 -- | Desugar all other kind of bindings, Ids of strict binds are returned to
@@ -665,16 +665,14 @@ dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   | isJust (isClassOpId_maybe poly_id)
   = putSrcSpanDs loc $
-    do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for class method selector"
-                                  <+> quotes (ppr poly_id))
+    do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
        ; return Nothing  }  -- There is no point in trying to specialise a class op
                             -- Moreover, classops don't (currently) have an inl_sat arity set
                             -- (it would be Just 0) and that in turn makes makeCorePair bleat
 
   | no_act_spec && isNeverActive rule_act
   = putSrcSpanDs loc $
-    do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
-                                  <+> quotes (ppr poly_id))
+    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
        ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
                             -- See Note [Activation pragmas for SPECIALISE]
 
@@ -699,7 +697,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
          --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
          dflags <- getDynFlags
        ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
-           Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ;
+           Left msg -> do { diagnosticDs msg; return Nothing } ;
            Right (rule_bndrs, _fn, rule_lhs_args) -> do
 
        { this_mod <- getModule
@@ -768,12 +766,9 @@ dsMkUserRule :: Module -> Bool -> RuleName -> Activation
 dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
     let rule = mkRule this_mod False is_local name act fn bndrs args rhs
     when (isOrphan (ru_orphan rule)) $
-        diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule)
+        diagnosticDs (DsOrphanRule rule)
     return rule
 
-ruleOrphWarn :: CoreRule -> SDoc
-ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
-
 {- Note [SPECIALISE on INLINE functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We used to warn that using SPECIALISE for a function marked INLINE
@@ -836,7 +831,7 @@ SPEC f :: ty                [n]   INLINE [k]
 -}
 
 decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
-                 -> Either SDoc ([Var], Id, [CoreExpr])
+                 -> Either DsMessage ([Var], Id, [CoreExpr])
 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
 -- may add some extra dictionary binders (see Note [Free dictionaries])
@@ -846,10 +841,10 @@ decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
 decomposeRuleLhs dflags orig_bndrs orig_lhs
   | not (null unbound)    -- Check for things unbound on LHS
                           -- See Note [Unused spec binders]
-  = Left (vcat (map dead_msg unbound))
+  = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)
   | Var funId <- fun2
   , Just con <- isDataConId_maybe funId
-  = Left (constructor_msg con) -- See Note [No RULES on datacons]
+  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]
   | Just (fn_id, args) <- decompose fun2 args2
   , let extra_bndrs = mk_extra_bndrs fn_id args
   = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
@@ -861,7 +856,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs
     Right (orig_bndrs ++ extra_bndrs, fn_id, args)
 
   | otherwise
-  = Left bad_shape_msg
+  = Left (DsRuleLhsTooComplicated orig_lhs lhs2)
  where
    simpl_opts   = initSimpleOpts dflags
    lhs1         = drop_dicts orig_lhs
@@ -893,24 +888,6 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs
 
    decompose _ _ = Nothing
 
-   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
-                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
-                              , text "Orig lhs:" <+> ppr orig_lhs])
-   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
-                             , text "is not bound in RULE lhs"])
-                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
-                              , text "Orig lhs:" <+> ppr orig_lhs
-                              , text "optimised lhs:" <+> ppr lhs2 ])
-   pp_bndr bndr
-    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
-    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))
-    | otherwise    = text "variable"      <+> quotes (ppr bndr)
-
-   constructor_msg con = vcat
-     [ text "A constructor," <+> ppr con <>
-         text ", appears as outermost match in RULE lhs."
-     , text "This rule will be ignored." ]
-
    drop_dicts :: CoreExpr -> CoreExpr
    drop_dicts e
        = wrap_lets needed bnds body
@@ -1135,7 +1112,7 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)
                                    ; w2 <- dsHsWrapper c2
                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
                                          arg     = w1 (Var x)
-                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg (LevityCheckWpFun doc)
                                    ; if ok
                                      then return (\e -> (Lam x (w2 (app e arg))))
                                      else return id }  -- this return is irrelevant
@@ -1145,7 +1122,7 @@ dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
                                    ; return (\e -> App e core_tm) }
   -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
 dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $
-                                         errDs (text "Multiplicity coercions are currently not supported")
+                                         diagnosticDs DsMultiplicityCoercionsNotSupported
                                      ; return $ \e -> e }
 --------------------------------------
 dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index b8d2a0a86c..87846bb8f2 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -1,11 +1,359 @@
+{-# LANGUAGE LambdaCase #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage
 
 module GHC.HsToCore.Errors.Ppr where
 
-import GHC.Types.Error
+import GHC.Builtin.Names (withDictName)
+import GHC.Core.Predicate (isEvVar)
+import GHC.Core.TyCo.Ppr (pprWithTYPE)
+import GHC.Core.Type
+import GHC.Core.Utils (exprType)
+import GHC.Driver.Flags
+import GHC.Hs
 import GHC.HsToCore.Errors.Types
+import GHC.Prelude
+import GHC.Tc.Errors.Ppr (formatLevPolyErr, pprLevityPolyInType)
+import GHC.Types.Basic (pprRuleName)
+import GHC.Types.Error
+import GHC.Types.Id (idType)
+import GHC.Types.SrcLoc
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import qualified GHC.LanguageExtensions as LangExt
+import GHC.HsToCore.Pmc.Ppr
+
 
 instance Diagnostic DsMessage where
-  diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m
-  diagnosticReason  (DsUnknownMessage m) = diagnosticReason m
-  diagnosticHints   (DsUnknownMessage m) = diagnosticHints m
+  diagnosticMessage = \case
+    DsUnknownMessage m
+      -> diagnosticMessage m
+    DsEmptyEnumeration
+      -> mkSimpleDecorated $ text "Enumeration is empty"
+    DsIdentitiesFound conv_fn type_of_conv
+      -> mkSimpleDecorated $
+           vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+                , nest 2 $ text "can probably be omitted"
+                ]
+    DsOverflowedLiterals i tc bounds _possiblyUsingNegativeLiterals
+      -> let msg = case bounds of
+               Nothing
+                 -> vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> text "only supports positive numbers"
+                         ]
+               Just (MinBound minB, MaxBound maxB)
+                 -> vcat [ text "Literal" <+> integer i
+                                 <+> text "is out of the" <+> ppr tc <+> text "range"
+                                 <+> integer minB <> text ".." <> integer maxB
+                         ]
+         in mkSimpleDecorated msg
+    DsRedundantBangPatterns ctx q
+      -> mkSimpleDecorated $ pprEqn ctx q "has redundant bang"
+    DsOverlappingPatterns ctx q
+      -> mkSimpleDecorated $ pprEqn ctx q "is redundant"
+    DsInaccessibleRhs ctx q
+      -> mkSimpleDecorated $ pprEqn ctx q "has inaccessible right hand side"
+    DsMaxPmCheckModelsReached limit
+      -> mkSimpleDecorated $ vcat
+           [ hang
+               (text "Pattern match checker ran into -fmax-pmcheck-models="
+                 <> int limit
+                 <> text " limit, so")
+               2
+               (  bullet <+> text "Redundant clauses might not be reported at all"
+               $$ bullet <+> text "Redundant clauses might be reported as inaccessible"
+               $$ bullet <+> text "Patterns reported as unmatched might actually be matched")
+           ]
+    DsNonExhaustivePatterns kind _flag maxPatterns vars nablas
+      -> mkSimpleDecorated $
+           pprContext False kind (text "are non-exhaustive") $ \_ ->
+             case vars of -- See #11245
+                  [] -> text "Guards do not cover entire pattern space"
+                  _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas
+                            pp_tys = pprQuotedList $ map idType vars
+                        in  hang
+                              (text "Patterns of type" <+> pp_tys <+> text "not matched:")
+                              4
+                              (vcat (take maxPatterns us) $$ dots maxPatterns us)
+    DsTopLevelBindsNotAllowed bindsType bind
+      -> let desc = case bindsType of
+               UnliftedTypeBinds -> "bindings for unlifted types"
+               StrictBinds       -> "strict bindings"
+         in mkSimpleDecorated $
+              hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)
+    DsUselessSpecialiseForClassMethodSelector poly_id
+      -> mkSimpleDecorated $
+           text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
+    DsUselessSpecialiseForNoInlineFunction poly_id
+      -> mkSimpleDecorated $
+          text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
+    DsMultiplicityCoercionsNotSupported
+      -> mkSimpleDecorated $ text "Multiplicity coercions are currently not supported"
+    DsOrphanRule rule
+      -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule
+    DsRuleLhsTooComplicated orig_lhs lhs2
+      -> mkSimpleDecorated $
+           hang (text "RULE left-hand side too complicated to desugar")
+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
+                              , text "Orig lhs:" <+> ppr orig_lhs])
+    DsRuleIgnoredDueToConstructor con
+      -> mkSimpleDecorated $ vcat
+           [ text "A constructor," <+> ppr con <>
+               text ", appears as outermost match in RULE lhs."
+           , text "This rule will be ignored." ]
+    DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2
+      -> mkSimpleDecorated $ vcat (map pp_dead unbound)
+         where
+           pp_dead bndr =
+             hang (sep [ text "Forall'd" <+> pp_bndr bndr
+                       , text "is not bound in RULE lhs"])
+                2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+                        , text "Orig lhs:" <+> ppr orig_lhs
+                        , text "optimised lhs:" <+> ppr lhs2 ])
+
+           pp_bndr b
+            | isTyVar b = text "type variable" <+> quotes (ppr b)
+            | isEvVar b = text "constraint"    <+> quotes (ppr (varType b))
+            | otherwise = text "variable"      <+> quotes (ppr b)
+    DsMultipleConForNewtype names
+      -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names
+    DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs
+      -> mkSimpleDecorated $
+          hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                text "Unlifted variables:")
+             2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) unlifted_bndrs))
+    DsNotYetHandledByTH reason
+      -> case reason of
+             ThAmbiguousRecordUpdates fld
+               -> mkMsg "Ambiguous record updates" (ppr fld)
+             ThAbstractClosedTypeFamily decl
+               -> mkMsg "abstract closed type family" (ppr decl)
+             ThForeignLabel cls
+               -> mkMsg "Foreign label" (doubleQuotes (ppr cls))
+             ThForeignExport decl
+               -> mkMsg "Foreign export" (ppr decl)
+             ThMinimalPragmas
+               -> mkMsg "MINIMAL pragmas" empty
+             ThSCCPragmas
+               -> mkMsg "SCC pragmas" empty
+             ThNoUserInline
+               -> mkMsg "NOUSERINLINE" empty
+             ThExoticFormOfType ty
+               -> mkMsg "Exotic form of type" (ppr ty)
+             ThAmbiguousRecordSelectors e
+               -> mkMsg "Ambiguous record selectors" (ppr e)
+             ThMonadComprehensionSyntax e
+               -> mkMsg "monad comprehension and [: :]" (ppr e)
+             ThCostCentres e
+               -> mkMsg "Cost centres" (ppr e)
+             ThExpressionForm e
+               -> mkMsg "Expression form" (ppr e)
+             ThExoticStatement other
+               -> mkMsg "Exotic statement" (ppr other)
+             ThExoticLiteral lit
+               -> mkMsg "Exotic literal" (ppr lit)
+             ThExoticPattern pat
+               -> mkMsg "Exotic pattern" (ppr pat)
+             ThGuardedLambdas m
+               -> mkMsg "Guarded lambdas" (pprMatch m)
+             ThNegativeOverloadedPatterns pat
+               -> mkMsg "Negative overloaded patterns" (ppr pat)
+             ThHaddockDocumentation
+               -> mkMsg "Haddock documentation" empty
+             ThWarningAndDeprecationPragmas decl
+               -> mkMsg "WARNING and DEPRECATION pragmas" $
+                    text "Pragma for declaration of" <+> ppr decl
+             ThDefaultDeclarations decl
+               -> mkMsg "Default declarations" (ppr decl)
+             ThSplicesWithinDeclBrackets
+               -> mkMsg "Splices within declaration brackets" empty
+         where
+           mkMsg what doc =
+             mkSimpleDecorated $
+               hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc
+    DsAggregatedViewExpressions views
+      -> mkSimpleDecorated (vcat msgs)
+         where
+           msgs = map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) views
+    DsUnbangedStrictPatterns bind
+      -> mkSimpleDecorated $
+           hang (text "Pattern bindings containing unlifted types should use" $$
+                 text "an outermost bang pattern:")
+              2 (ppr bind)
+    DsCannotMixPolyAndUnliftedBindings bind
+      -> mkSimpleDecorated $
+           hang (text "You can't mix polymorphic and unlifted bindings:")
+              2 (ppr bind)
+    DsInvalidInstantiationDictAtType wrapped_ty
+      -> mkSimpleDecorated $
+           hang (text "Invalid instantiation of" <+>
+                quotes (ppr withDictName) <+> text "at type:")
+             4 (ppr wrapped_ty)
+    DsWrongDoBind _rhs elt_ty
+      -> mkSimpleDecorated $ badMonadBind elt_ty
+    DsUnusedDoBind _rhs elt_ty
+      -> mkSimpleDecorated $ badMonadBind elt_ty
+    DsRecBindsNotAllowedForUnliftedTys binds
+      -> mkSimpleDecorated $
+           hang (text "Recursive bindings for unlifted types aren't allowed:")
+              2 (vcat (map ppr binds))
+    DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys
+      -> mkSimpleDecorated $
+           vcat [ hang (text "Cannot use function with levity-polymorphic arguments:")
+                  2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty))
+             , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat
+                 [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
+                 , text "are eta-expanded internally because they must occur fully saturated."
+                 , text "Use -fprint-typechecker-elaboration to display the full expression.)"
+                 ]
+             , hang (text "Levity-polymorphic arguments:")
+                  2 $ vcat $ map
+                    (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
+                    bad_tys
+             ]
+    DsRuleMightInlineFirst rule_name lhs_id _
+      -> mkSimpleDecorated $
+           vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                          <+> text "may never fire")
+                       2 (text "because" <+> quotes (ppr lhs_id)
+                          <+> text "might inline first")
+                ]
+    DsAnotherRuleMightFireFirst rule_name bad_rule lhs_id
+      -> mkSimpleDecorated $
+           vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                          <+> text "may never fire")
+                       2 (text "because rule" <+> pprRuleName bad_rule
+                          <+> text "for"<+> quotes (ppr lhs_id)
+                          <+> text "might fire first")
+                ]
+    DsLevityPolyInExpr e prov
+      -> let extra = case prov of
+               LevityCheckHsExpr hsExpr -> ppr hsExpr
+               LevityCheckWpFun doc     -> doc
+               LevityCheckInSyntaxExpr (DsArgNum n) expr
+                 -> text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+
+         in mkSimpleDecorated $
+               formatLevPolyErr (exprType e) $$ (text "In the type of expression:" <+> extra)
+    DsLevityPolyInType ty prov
+      -> mkSimpleDecorated $ pprLevityPolyInType ty prov
+
+  diagnosticReason = \case
+    DsUnknownMessage m          -> diagnosticReason m
+    DsEmptyEnumeration          -> WarningWithFlag Opt_WarnEmptyEnumerations
+    DsIdentitiesFound{}         -> WarningWithFlag Opt_WarnIdentities
+    DsOverflowedLiterals{}      -> WarningWithFlag Opt_WarnOverflowedLiterals
+    DsRedundantBangPatterns{}   -> WarningWithFlag Opt_WarnRedundantBangPatterns
+    DsOverlappingPatterns{}     -> WarningWithFlag Opt_WarnOverlappingPatterns
+    DsInaccessibleRhs{}         -> WarningWithFlag Opt_WarnOverlappingPatterns
+    DsMaxPmCheckModelsReached{} -> WarningWithoutFlag
+    DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _
+      -> maybe WarningWithoutFlag WarningWithFlag mb_flag
+    DsTopLevelBindsNotAllowed{}                 -> ErrorWithoutFlag
+    DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag
+    DsUselessSpecialiseForNoInlineFunction{}    -> WarningWithoutFlag
+    DsMultiplicityCoercionsNotSupported{}       -> ErrorWithoutFlag
+    DsOrphanRule{}                              -> WarningWithFlag Opt_WarnOrphans
+    DsRuleLhsTooComplicated{}                   -> WarningWithoutFlag
+    DsRuleIgnoredDueToConstructor{}             -> WarningWithoutFlag
+    DsRuleBindersNotBound{}                     -> WarningWithoutFlag
+    DsMultipleConForNewtype{}                   -> ErrorWithoutFlag
+    DsLazyPatCantBindVarsOfUnliftedType{}       -> ErrorWithoutFlag
+    DsNotYetHandledByTH{}                       -> ErrorWithoutFlag
+    DsAggregatedViewExpressions{}               -> WarningWithoutFlag
+    DsUnbangedStrictPatterns{}                  -> WarningWithFlag Opt_WarnUnbangedStrictPatterns
+    DsCannotMixPolyAndUnliftedBindings{}        -> ErrorWithoutFlag
+    DsInvalidInstantiationDictAtType{}          -> ErrorWithoutFlag
+    DsWrongDoBind{}                             -> WarningWithFlag Opt_WarnWrongDoBind
+    DsUnusedDoBind{}                            -> WarningWithFlag Opt_WarnUnusedDoBind
+    DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag
+    DsCannotUseFunWithPolyArgs{}                -> ErrorWithoutFlag
+    DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing
+    DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing
+    DsLevityPolyInExpr{}                        -> ErrorWithoutFlag
+    DsLevityPolyInType{}                        -> ErrorWithoutFlag
+
+  diagnosticHints  = \case
+    DsUnknownMessage m          -> diagnosticHints m
+    DsEmptyEnumeration          -> noHints
+    DsIdentitiesFound{}         -> noHints
+    DsOverflowedLiterals i _tc bounds usingNegLiterals
+      -> case (bounds, usingNegLiterals) of
+          (Just (MinBound minB, MaxBound _), NotUsingNegLiterals)
+            | minB == -i -- Note [Suggest NegativeLiterals]
+            , i > 0 -> [SuggestExtension LangExt.NegativeLiterals]
+          _ -> noHints
+    DsRedundantBangPatterns{}                   -> noHints
+    DsOverlappingPatterns{}                     -> noHints
+    DsInaccessibleRhs{}                         -> noHints
+    DsMaxPmCheckModelsReached{}                 -> [SuggestIncreaseMaxPmCheckModels]
+    DsNonExhaustivePatterns{}                   -> noHints
+    DsTopLevelBindsNotAllowed{}                 -> noHints
+    DsUselessSpecialiseForClassMethodSelector{} -> noHints
+    DsUselessSpecialiseForNoInlineFunction{}    -> noHints
+    DsMultiplicityCoercionsNotSupported         -> noHints
+    DsOrphanRule{}                              -> noHints
+    DsRuleLhsTooComplicated{}                   -> noHints
+    DsRuleIgnoredDueToConstructor{}             -> noHints
+    DsRuleBindersNotBound{}                     -> noHints
+    DsMultipleConForNewtype{}                   -> noHints
+    DsLazyPatCantBindVarsOfUnliftedType{}       -> noHints
+    DsNotYetHandledByTH{}                       -> noHints
+    DsAggregatedViewExpressions{}               -> noHints
+    DsUnbangedStrictPatterns{}                  -> noHints
+    DsCannotMixPolyAndUnliftedBindings{}        -> [SuggestAddTypeSignature]
+    DsWrongDoBind rhs _                         -> [SuggestBindToWildcard rhs]
+    DsUnusedDoBind rhs _                        -> [SuggestBindToWildcard rhs]
+    DsRecBindsNotAllowedForUnliftedTys{}        -> noHints
+    DsInvalidInstantiationDictAtType{}          -> noHints
+    DsCannotUseFunWithPolyArgs{}                -> noHints
+    DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]
+    DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]
+    DsLevityPolyInExpr{}                        -> noHints
+    DsLevityPolyInType{}                        -> noHints
+
+{-
+Note [Suggest NegativeLiterals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write
+  x :: Int8
+  x = -128
+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
+We get an erroneous suggestion for
+  x = 128
+but perhaps that does not matter too much.
+-}
+
+--
+-- Helper functions
+--
+
+badMonadBind :: Type -> SDoc
+badMonadBind elt_ty
+  = hang (text "A do-notation statement discarded a result of type")
+       2 (quotes (ppr elt_ty))
+
+-- Print a single clause (for redundant/with-inaccessible-rhs)
+pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc
+pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->
+  f (q <+> matchSeparator ctx <+> text "...")
+
+pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pprContext singular kind msg rest_of_msg_fun
+  = vcat [text txt <+> msg,
+          sep [ text "In" <+> ppr_match <> char ':'
+              , nest 4 (rest_of_msg_fun pref)]]
+  where
+    txt | singular  = "Pattern match"
+        | otherwise = "Pattern match(es)"
+
+    (ppr_match, pref)
+        = case kind of
+             FunRhs { mc_fun = L _ fun }
+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _    -> (pprMatchContext kind, \ pp -> pp)
+
+dots :: Int -> [a] -> SDoc
+dots maxPatterns qs
+    | qs `lengthExceeds` maxPatterns = text "..."
+    | otherwise                      = empty
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 45a47d5c30..950d4aa42a 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -1,10 +1,209 @@
+{-# LANGUAGE ExistentialQuantification #-}
 
 module GHC.HsToCore.Errors.Types where
 
+import Data.Typeable
+
+import GHC.Prelude
+
+import GHC.Core (CoreRule, CoreExpr, RuleName)
+import GHC.Core.DataCon
+import GHC.Core.Type
+import GHC.Driver.Session
+import GHC.Hs
+import GHC.HsToCore.Pmc.Solver.Types
+import GHC.Tc.Errors.Types (LevityCheckProvenance)
+import GHC.Types.Basic (Activation)
 import GHC.Types.Error
+import GHC.Types.ForeignCall
+import GHC.Types.Id
+import GHC.Types.Name (Name)
+import GHC.Utils.Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
+newtype MinBound = MinBound Integer
+newtype MaxBound = MaxBound Integer
+type MaxUncoveredPatterns = Int
+type MaxPmCheckModels = Int
 
 -- | Diagnostics messages emitted during desugaring.
-data DsMessage =
-  DsUnknownMessage !DiagnosticMessage
-  -- ^ Simply rewraps a generic 'DiagnosticMessage'. More
-  -- constructors will be added in the future (#18516).
+data DsMessage
+  -- | Simply wraps a generic 'Diagnostic' message.
+  = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a
+
+    {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is
+        emitted if an enumeration is empty.
+
+        Example(s):
+
+          main :: IO ()
+          main = do
+            let enum = [5 .. 3]
+            print enum
+
+          Here 'enum' would yield an empty list, because 5 is greater than 3.
+
+        Test case(s):
+          warnings/should_compile/T10930
+          warnings/should_compile/T18402
+          warnings/should_compile/T10930b
+          numeric/should_compile/T10929
+          numeric/should_compile/T7881
+          deSugar/should_run/T18172
+
+    -}
+  | DsEmptyEnumeration
+
+    {-| DsIdentitiesFound is a warning (controlled by the -Widentities flag) that is
+        emitted on uses of Prelude numeric conversions that are probably the identity
+        (and hence could be omitted).
+
+        Example(s):
+
+          main :: IO ()
+          main = do
+            let x = 10
+            print $ conv 10
+
+            where
+              conv :: Int -> Int
+              conv x = fromIntegral x
+
+        Here calling 'conv' is essentially the identity function, and therefore can be omitted.
+
+        Test case(s):
+          deSugar/should_compile/T4488
+    -}
+  | DsIdentitiesFound !Id   -- The conversion function
+                      !Type -- The type of conversion
+
+  | DsOverflowedLiterals !Integer
+                         !Name
+                         !(Maybe (MinBound, MaxBound))
+                         !NegLiteralExtEnabled
+
+  -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
+  -- 'SrcInfo' gives us an 'SDoc' to begin with.
+  | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc
+
+  -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
+  -- 'SrcInfo' gives us an 'SDoc' to begin with.
+  | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc
+
+  -- FIXME(adn) Use a proper type instead of 'SDoc'
+  | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc
+
+  | DsMaxPmCheckModelsReached !MaxPmCheckModels
+
+  | DsNonExhaustivePatterns !(HsMatchContext GhcRn)
+                            !ExhaustivityCheckType
+                            !MaxUncoveredPatterns
+                            [Id]
+                            [Nabla]
+
+  | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc)
+
+  | DsUselessSpecialiseForClassMethodSelector !Id
+
+  | DsUselessSpecialiseForNoInlineFunction !Id
+
+  | DsMultiplicityCoercionsNotSupported
+
+  | DsOrphanRule !CoreRule
+
+  | DsRuleLhsTooComplicated !CoreExpr !CoreExpr
+
+  | DsRuleIgnoredDueToConstructor !DataCon
+
+  | DsRuleBindersNotBound ![Var]
+                          -- ^ The list of unbound binders
+                          ![Var]
+                          -- ^ The original binders
+                          !CoreExpr
+                          -- ^ The original LHS
+                          !CoreExpr
+                          -- ^ The optimised LHS
+
+  | DsMultipleConForNewtype [LocatedN Name]
+
+  | DsLazyPatCantBindVarsOfUnliftedType [Var]
+
+  | DsNotYetHandledByTH !ThRejectionReason
+
+  | DsAggregatedViewExpressions [[LHsExpr GhcTc]]
+
+  | DsUnbangedStrictPatterns !(HsBindLR GhcTc GhcTc)
+
+  | DsCannotMixPolyAndUnliftedBindings !(HsBindLR GhcTc GhcTc)
+
+  | DsInvalidInstantiationDictAtType !Type
+
+  | DsWrongDoBind !(LHsExpr GhcTc) !Type
+
+  | DsUnusedDoBind !(LHsExpr GhcTc) !Type
+
+  | DsRecBindsNotAllowedForUnliftedTys ![LHsBindLR GhcTc GhcTc]
+
+  -- NOTE(adn) The first argument is an opaque 'expr' with an
+  -- 'Outputable' constraint because this messages is emitted from
+  -- 'GHC.HsToCore.Expr.checkLevPolyArgs' which gets passed a polymorphic
+  -- 'Outputable' type.
+  | forall expr. Outputable expr => DsCannotUseFunWithPolyArgs !expr !Type ![Type]
+
+  | DsRuleMightInlineFirst !RuleName !Var !Activation
+
+  | DsAnotherRuleMightFireFirst !RuleName
+                                !RuleName -- the \"bad\" rule
+                                !Var
+
+  | DsLevityPolyInExpr !CoreExpr !LevityExprProvenance
+
+  | DsLevityPolyInType !Type !LevityCheckProvenance
+
+-- The positional number of the argument for an expression (first, second, third, etc)
+newtype DsArgNum = DsArgNum Int
+
+-- | Where the levity checking for the expression originated
+data LevityExprProvenance
+  = LevityCheckHsExpr !(HsExpr GhcTc)
+  | LevityCheckWpFun !SDoc -- FIXME(adn) Alas 'WpFun' gives us an SDoc here.
+  | LevityCheckInSyntaxExpr !DsArgNum !(HsExpr GhcTc)
+
+-- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH'
+-- constructor of a 'DsMessage'.
+data ThRejectionReason
+  = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn)
+  | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn)
+  | ThForeignLabel !CLabelString
+  | ThForeignExport !(LForeignDecl GhcRn)
+  | ThMinimalPragmas
+  | ThSCCPragmas
+  | ThNoUserInline
+  | ThExoticFormOfType !(HsType GhcRn)
+  | ThAmbiguousRecordSelectors !(HsExpr GhcRn)
+  | ThMonadComprehensionSyntax !(HsExpr GhcRn)
+  | ThCostCentres !(HsExpr GhcRn)
+  | ThExpressionForm !(HsExpr GhcRn)
+  | ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)]
+  | ThExoticLiteral !(HsLit GhcRn)
+  | ThExoticPattern !(Pat GhcRn)
+  | ThGuardedLambdas !(Match GhcRn (LHsExpr GhcRn))
+  | ThNegativeOverloadedPatterns !(Pat GhcRn)
+  | ThHaddockDocumentation
+  | ThWarningAndDeprecationPragmas [LIdP GhcRn]
+  | ThDefaultDeclarations !(DefaultDecl GhcRn)
+  | ThSplicesWithinDeclBrackets
+
+data NegLiteralExtEnabled
+  = YesUsingNegLiterals
+  | NotUsingNegLiterals
+
+negLiteralExtEnabled :: DynFlags -> NegLiteralExtEnabled
+negLiteralExtEnabled dflags =
+ if (xopt LangExt.NegativeLiterals dflags) then YesUsingNegLiterals else NotUsingNegLiterals
+
+newtype ExhaustivityCheckType = ExhaustivityCheckType (Maybe WarningFlag)
+
+data BindsType
+  = UnliftedTypeBinds
+  | StrictBinds
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 0735ed9000..bd84e21ace 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -29,6 +29,7 @@ import GHC.HsToCore.Utils
 import GHC.HsToCore.Arrows
 import GHC.HsToCore.Monad
 import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
+import GHC.HsToCore.Errors.Types
 import GHC.Types.SourceText
 import GHC.Types.Name
 import GHC.Types.Name.Env
@@ -57,7 +58,6 @@ import GHC.Types.Var.Env
 import GHC.Unit.Module
 import GHC.Core.ConLike
 import GHC.Core.DataCon
-import GHC.Core.TyCo.Ppr( pprWithTYPE )
 import GHC.Builtin.Types
 import GHC.Builtin.Names
 import GHC.Types.Basic
@@ -125,7 +125,7 @@ ds_val_bind (NonRecursive, hsbinds) body
   = putSrcSpanDs (locA loc) $
      -- see Note [Strict binds checks] in GHC.HsToCore.Binds
     if is_polymorphic bind
-    then errDsCoreExpr (poly_bind_err bind)
+    then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind)
             -- data Ptr a = Ptr Addr#
             -- f x = let p@(Ptr y) = ... in ...
             -- Here the binding for 'p' is polymorphic, but does
@@ -133,7 +133,7 @@ ds_val_bind (NonRecursive, hsbinds) body
             -- use a bang pattern.  #6078.
 
     else do { when (looksLazyPatBind bind) $
-              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
+              diagnosticDs (DsUnbangedStrictPatterns bind)
         -- Complain about a binding that looks lazy
         --    e.g.    let I# y = x in ...
         -- Remember, in checkStrictBinds we are going to do strict
@@ -148,22 +148,11 @@ ds_val_bind (NonRecursive, hsbinds) body
                      = not (null tvs && null evs)
     is_polymorphic _ = False
 
-    unlifted_must_be_bang bind
-      = hang (text "Pattern bindings containing unlifted types should use" $$
-              text "an outermost bang pattern:")
-           2 (ppr bind)
-
-    poly_bind_err bind
-      = hang (text "You can't mix polymorphic and unlifted bindings:")
-           2 (ppr bind) $$
-        text "Probable fix: add a type signature"
 
 ds_val_bind (is_rec, binds) _body
   | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
   = assert (isRec is_rec )
-    errDsCoreExpr $
-    hang (text "Recursive bindings for unlifted types aren't allowed:")
-       2 (vcat (map ppr (bagToList binds)))
+    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (is_rec, binds) body
@@ -261,7 +250,7 @@ dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
 dsLExprNoLP (L loc e)
   = putSrcSpanDsA loc $
     do { e' <- dsExpr e
-       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
+       ; dsNoLevPolyExpr e' (LevityCheckHsExpr e)
        ; return e' }
 
 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
@@ -809,10 +798,10 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
        ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
-       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ])
                       (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
   where
-    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+    mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr
 dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
 
 findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
@@ -1101,8 +1090,7 @@ warnDiscardedDoBindings rhs rhs_ty
 
            -- Warn about discarding non-() things in 'monadic' binding
        ; if warn_unused && not (isUnitTy norm_elt_ty)
-         then diagnosticDs (WarningWithFlag Opt_WarnUnusedDoBind)
-                           (badMonadBind rhs elt_ty)
+         then diagnosticDs (DsUnusedDoBind rhs elt_ty)
          else
 
            -- Warn about discarding m a things in 'monadic' binding of the same type,
@@ -1111,21 +1099,12 @@ warnDiscardedDoBindings rhs rhs_ty
                 case tcSplitAppTy_maybe norm_elt_ty of
                       Just (elt_m_ty, _)
                          | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-                         -> diagnosticDs (WarningWithFlag Opt_WarnWrongDoBind)
-                                         (badMonadBind rhs elt_ty)
+                         -> diagnosticDs (DsWrongDoBind rhs elt_ty)
                       _ -> return () } }
 
   | otherwise   -- RHS does have type of form (m ty), which is weird
   = return ()   -- but at least this warning is irrelevant
 
-badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
-badMonadBind rhs elt_ty
-  = vcat [ hang (text "A do-notation statement discarded a result of type")
-              2 (quotes (ppr elt_ty))
-         , hang (text "Suppress this warning by saying")
-              2 (quotes $ text "_ <-" <+> ppr rhs)
-         ]
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1322,9 +1301,7 @@ ds_withDict wrapped_ty
        ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) }
 
   | otherwise
-  = errDsCoreExpr $ hang (text "Invalid instantiation of" <+>
-                          quotes (ppr withDictName) <+> text "at type:")
-                       4 (ppr wrapped_ty)
+  = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty)
 
 {- Note [withDict]
 ~~~~~~~~~~~~~~~~~~
@@ -1478,18 +1455,5 @@ checkLevPolyArgs orig_hs_expr ty
         arg_tys      = mapMaybe binderRelevantType_maybe binders
         bad_tys      = filter isTypeLevPoly arg_tys
   , not (null bad_tys)
-  = errDs $ vcat
-    [ hang (text "Cannot use function with levity-polymorphic arguments:")
-         2 (hang (ppr orig_hs_expr) 2 (dcolon <+> pprWithTYPE ty))
-    , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat
-        [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
-        , text "are eta-expanded internally because they must occur fully saturated."
-        , text "Use -fprint-typechecker-elaboration to display the full expression.)"
-        ]
-    , hang (text "Levity-polymorphic arguments:")
-         2 $ vcat $ map
-           (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
-           bad_tys
-    ]
-
+  = diagnosticDs $ DsCannotUseFunWithPolyArgs orig_hs_expr ty bad_tys
   | otherwise = return ()
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index fb338208fc..0816bf3c1c 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -16,6 +16,7 @@ import GHC.Prelude
 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import GHC.Hs
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import GHC.Tc.Utils.Zonk
 import GHC.Core
 import GHC.Core.Make
@@ -138,8 +139,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
                 , Var unzip_fn'
                 , inner_list_expr' ]
 
-    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
-      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
+    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) (LevityCheckInFunUse using)
 
     -- Build a pattern that ensures the consumer binds into the NEW binders,
     -- which hold lists rather than single values
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 33ffc1e998..50aaef9b56 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -46,6 +46,7 @@ import GHC.Types.Id
 import GHC.Core.ConLike
 import GHC.Core.DataCon
 import GHC.Core.PatSyn
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.Match.Constructor
 import GHC.HsToCore.Match.Literal
 import GHC.Core.Type
@@ -247,10 +248,9 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
                                            case p of PgView e _ -> e:acc
                                                      _ -> acc) [] group) eqns
             maybeWarn [] = return ()
-            maybeWarn l = diagnosticDs WarningWithoutFlag (vcat l)
+            maybeWarn l  = diagnosticDs (DsAggregatedViewExpressions l)
         in
-          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
-                       (filter (not . null) gs))
+          maybeWarn $ filter (not . null) gs
 
 matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
 -- See Note [Empty case expressions]
@@ -455,10 +455,7 @@ tidy1 v _ (LazyPat _ pat)
   = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
         ; unless (null unlifted_bndrs) $
           putSrcSpanDs (getLocA pat) $
-          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
-                       text "Unlifted variables:")
-                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
-                                 unlifted_bndrs)))
+          diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
 
         ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index b2f7043f45..d8da036dba 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -30,6 +30,7 @@ import GHC.Platform
 import {-# SOURCE #-} GHC.HsToCore.Match ( match )
 import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )
 
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.Monad
 import GHC.HsToCore.Utils
 
@@ -56,7 +57,6 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Data.FastString
-import qualified GHC.LanguageExtensions as LangExt
 import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
 
 import Control.Monad
@@ -263,10 +263,7 @@ warnAboutIdentities dflags conv_fn type_of_conv
   , idName conv_fn `elem` conversionNames
   , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
-  = diagnosticDs (WarningWithFlag Opt_WarnIdentities)
-                 (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
-                       , nest 2 $ text "can probably be omitted"
-                 ])
+  = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)
 warnAboutIdentities _ _ _ = return ()
 
 conversionNames :: [Name]
@@ -347,37 +344,13 @@ warnAboutOverflowedLiterals dflags lit
     checkPositive :: Integer -> Name -> DsM ()
     checkPositive i tc
       = when (i < 0) $
-        diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals)
-                     (vcat [ text "Literal" <+> integer i
-                             <+> text "is negative but" <+> ppr tc
-                             <+> text "only supports positive numbers"
-                           ])
+        diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))
 
     check i tc minB maxB
       = when (i < minB || i > maxB) $
-        diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals)
-                     (vcat [ text "Literal" <+> integer i
-                             <+> text "is out of the" <+> ppr tc <+> text "range"
-                             <+> integer minB <> text ".." <> integer maxB
-                           , sug ])
+        diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))
       where
-        sug | minB == -i   -- Note [Suggest NegativeLiterals]
-            , i > 0
-            , not (xopt LangExt.NegativeLiterals dflags)
-            = text "If you are trying to write a large negative literal, use NegativeLiterals"
-            | otherwise = Outputable.empty
-
-{-
-Note [Suggest NegativeLiterals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you write
-  x :: Int8
-  x = -128
-it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
-We get an erroneous suggestion for
-  x = 128
-but perhaps that does not matter too much.
--}
+        bounds = Just (MinBound minB, MaxBound maxB)
 
 warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
                            -> Maybe (LHsExpr GhcTc)
@@ -441,7 +414,7 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
   | otherwise = return ()
   where
     raiseWarning =
-      diagnosticDs (WarningWithFlag Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
+      diagnosticDs DsEmptyEnumeration
 
 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
 -- ^ See if the expression is an 'Integral' literal.
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 6844606276..91cb41c46c 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -40,7 +40,7 @@ module GHC.HsToCore.Monad (
         dsGetCompleteMatches,
 
         -- Warnings and errors
-        DsWarning, diagnosticDs, warnIfSetDs, errDs, errDsCoreExpr,
+        DsWarning, diagnosticDs, errDsCoreExpr,
         failWithDs, failDs, discardWarningsDs,
         askNoErrsDs,
 
@@ -79,8 +79,9 @@ import GHC.Core.Multiplicity
 
 import GHC.IfaceToCore
 
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )
+import GHC.Tc.Utils.TcMType ( checkForLevPolyX )
 
 import GHC.Builtin.Names
 
@@ -431,9 +432,8 @@ newSysLocalsDsNoLP = mapM (\(Scaled w t) -> newSysLocalDsNoLP w t)
 newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
 
 mk_local :: FastString -> Mult -> Type -> DsM Id
-mk_local fs w ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
-                                        ppr ty)  -- could improve the msg with another
-                                                 -- parameter indicating context
+mk_local fs w ty = do { dsNoLevPoly ty LevityCheckInVarType -- could improve the msg with another
+                                                            -- parameter indicating context
                       ; mkSysLocalOrCoVarM fs w ty }
 
 {-
@@ -466,43 +466,27 @@ putSrcSpanDs (RealSrcSpan real_span _) thing_inside
 putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
 putSrcSpanDsA loc = putSrcSpanDs (locA loc)
 
--- | Emit a diagnostic for the current source location
--- NB: Warns whether or not -Wxyz is set
-diagnosticDs :: DiagnosticReason -> SDoc -> DsM ()
-diagnosticDs reason warn
+-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
+-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
+-- See Note [Discarding Messages] in 'GHC.Types.Error'.
+diagnosticDs :: DsMessage -> DsM ()
+diagnosticDs dsMessage
   = do { env <- getGblEnv
        ; loc <- getSrcSpanDs
        ; dflags <- getDynFlags
-       ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $
-                   DsUnknownMessage $
-                   mkPlainDiagnostic reason noHints warn
+       ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) dsMessage
        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
--- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags
-warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
-warnIfSetDs flag warn
-  = whenWOptM flag $
-    diagnosticDs (WarningWithFlag flag) warn
-
-errDs :: SDoc -> DsM ()
-errDs err
-  = do  { env <- getGblEnv
-        ; loc <- getSrcSpanDs
-        ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $
-                    DsUnknownMessage $
-                    mkPlainError noHints err
-        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
-
 -- | Issue an error, but return the expression for (), so that we can continue
 -- reporting errors.
-errDsCoreExpr :: SDoc -> DsM CoreExpr
-errDsCoreExpr err
-  = do { errDs err
+errDsCoreExpr :: DsMessage -> DsM CoreExpr
+errDsCoreExpr msg
+  = do { diagnosticDs msg
        ; return unitExpr }
 
-failWithDs :: SDoc -> DsM a
-failWithDs err
-  = do  { errDs err
+failWithDs :: DsMessage -> DsM a
+failWithDs msg
+  = do  { diagnosticDs msg
         ; failM }
 
 failDs :: DsM a
@@ -604,16 +588,17 @@ discardWarningsDs thing_inside
         ; return result }
 
 -- | Fail with an error message if the type is levity polymorphic.
-dsNoLevPoly :: Type -> SDoc -> DsM ()
+dsNoLevPoly :: Type -> LevityCheckProvenance -> DsM ()
 -- See Note [Levity polymorphism checking]
-dsNoLevPoly ty doc = checkForLevPolyX failWithDs doc ty
+dsNoLevPoly ty provenance =
+  checkForLevPolyX (\ty -> failWithDs . DsLevityPolyInType ty) provenance ty
 
 -- | Check an expression for levity polymorphism, failing if it is
 -- levity polymorphic.
-dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+dsNoLevPolyExpr :: CoreExpr -> LevityExprProvenance -> DsM ()
 -- See Note [Levity polymorphism checking]
-dsNoLevPolyExpr e doc
-  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+dsNoLevPolyExpr e provenance
+  | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance)
   | otherwise       = return ()
 
 -- | Runs the thing_inside. If there are no errors, then returns the expr
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index a9e97ef781..a05e3597be 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -43,12 +43,12 @@ module GHC.HsToCore.Pmc (
 
 import GHC.Prelude
 
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.Pmc.Types
 import GHC.HsToCore.Pmc.Utils
 import GHC.HsToCore.Pmc.Desugar
 import GHC.HsToCore.Pmc.Check
 import GHC.HsToCore.Pmc.Solver
-import GHC.HsToCore.Pmc.Ppr
 import GHC.Types.Basic (Origin(..))
 import GHC.Core (CoreExpr)
 import GHC.Driver.Session
@@ -330,7 +330,7 @@ formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do
 -- | Issue all the warnings
 -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).
 reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
-reportWarnings dflags ctx@(DsMatchContext kind loc) vars
+reportWarnings dflags (DsMatchContext kind loc) vars
   CheckResult { cr_ret    = CIRB { cirb_inacc = inaccessible_rhss
                                  , cirb_red   = redundant_rhss
                                  , cirb_bangs = redundant_bangs }
@@ -345,55 +345,26 @@ reportWarnings dflags ctx@(DsMatchContext kind loc) vars
           approx   = precision == Approximate
 
       when (approx && (exists_u || exists_i)) $
-        putSrcSpanDs loc (diagnosticDs WarningWithoutFlag approx_msg)
+        putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags)))
 
       when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnRedundantBangPatterns)
-                                     (pprEqn q "has redundant bang"))
+        putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q))
 
       when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns)
-                                     (pprEqn q "is redundant"))
+        putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q))
       when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns)
-                                     (pprEqn q "has inaccessible right hand side"))
+        putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q))
 
-      when exists_u $ putSrcSpanDs loc $ diagnosticDs flag_u_reason $
-        pprEqns vars unc_examples
+      when exists_u $
+        putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples))
   where
     flag_i = overlapping dflags kind
     flag_u = exhaustive dflags kind
     flag_b = redundantBang dflags
-    flag_u_reason = maybe WarningWithoutFlag WarningWithFlag (exhaustiveWarningFlag kind)
+    check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind)
 
     maxPatterns = maxUncoveredPatterns dflags
 
-    -- Print a single clause (for redundant/with-inaccessible-rhs)
-    pprEqn q txt = pprContext True ctx (text txt) $ \f ->
-      f (q <+> matchSeparator kind <+> text "...")
-
-    -- Print several clauses (for uncovered clauses)
-    pprEqns vars nablas = pprContext False ctx (text "are non-exhaustive") $ \_ ->
-      case vars of -- See #11245
-           [] -> text "Guards do not cover entire pattern space"
-           _  -> let us = map (\nabla -> pprUncovered nabla vars) nablas
-                     pp_tys = pprQuotedList $ map idType vars
-                 in  hang
-                       (text "Patterns of type" <+> pp_tys <+> text "not matched:")
-                       4
-                       (vcat (take maxPatterns us) $$ dots maxPatterns us)
-
-    approx_msg = vcat
-      [ hang
-          (text "Pattern match checker ran into -fmax-pmcheck-models="
-            <> int (maxPmCheckModels dflags)
-            <> text " limit, so")
-          2
-          (  bullet <+> text "Redundant clauses might not be reported at all"
-          $$ bullet <+> text "Redundant clauses might be reported as inaccessible"
-          $$ bullet <+> text "Patterns reported as unmatched might actually be matched")
-      , text "Increase the limit or resolve the warnings to suppress this message." ]
-
 getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]
 getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)
   where
@@ -404,26 +375,6 @@ getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)
       back <- go (n - length front) nablas
       pure (front ++ back)
 
-dots :: Int -> [a] -> SDoc
-dots maxPatterns qs
-    | qs `lengthExceeds` maxPatterns = text "..."
-    | otherwise                      = empty
-
-pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
-pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun
-  = vcat [text txt <+> msg,
-          sep [ text "In" <+> ppr_match <> char ':'
-              , nest 4 (rest_of_msg_fun pref)]]
-  where
-    txt | singular  = "Pattern match"
-        | otherwise = "Pattern match(es)"
-
-    (ppr_match, pref)
-        = case kind of
-             FunRhs { mc_fun = L _ fun }
-                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
-             _    -> (pprMatchContext kind, \ pp -> pp)
-
 --
 -- * Adding external long-distance information
 --
diff --git a/compiler/GHC/HsToCore/Pmc/Ppr.hs b/compiler/GHC/HsToCore/Pmc/Ppr.hs
index eddab8df6e..e8221d961f 100644
--- a/compiler/GHC/HsToCore/Pmc/Ppr.hs
+++ b/compiler/GHC/HsToCore/Pmc/Ppr.hs
@@ -5,7 +5,7 @@
 -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for
 -- user facing pattern match warnings.
 module GHC.HsToCore.Pmc.Ppr (
-        pprUncovered
+      pprUncovered
     ) where
 
 import GHC.Prelude
@@ -25,7 +25,6 @@ import GHC.Data.Maybe
 import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
 
 import GHC.HsToCore.Pmc.Types
-import GHC.HsToCore.Pmc.Solver
 
 -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
 -- components and refutable shapes associated to any mentioned variables.
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 65bf188bf4..6efd44a5aa 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -23,7 +23,6 @@ Authors: George Karachalias <george.karachalias@cs.kuleuven.be>
 module GHC.HsToCore.Pmc.Solver (
 
         Nabla, Nablas(..), initNablas,
-        lookupRefuts, lookupSolution,
 
         PhiCt(..), PhiCts,
         addPhiCtNablas,
@@ -510,58 +509,9 @@ inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.
 In order to avoid this pitfall, we need to normalise the type passed to
 pmTopNormaliseType, using the constraint solver to solve for any local
 equalities (such as i ~ Int) that may be in scope.
--}
 
------------------------
--- * Looking up VarInfo
-
-emptyRCM :: ResidualCompleteMatches
-emptyRCM = RCM Nothing Nothing
-
-emptyVarInfo :: Id -> VarInfo
-emptyVarInfo x
-  = VI
-  { vi_id = x
-  , vi_pos = []
-  , vi_neg = emptyPmAltConSet
-  -- Case (3) in Note [Strict fields and fields of unlifted type]
-  , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot
-  , vi_rcm = emptyRCM
-  }
-
-lookupVarInfo :: TmState -> Id -> VarInfo
--- (lookupVarInfo tms x) tells what we know about 'x'
-lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)
-
--- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks
--- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the
--- returned @y@ doesn't have a positive newtype constructor constraint
--- associated with it (yet). The 'VarInfo' returned is that of @y@'s
--- representative.
---
--- Careful, this means that @idType x@ might be different to @idType y@, even
--- modulo type normalisation!
---
--- See also Note [Coverage checking Newtype matches].
-lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)
-lookupVarInfoNT ts x = case lookupVarInfo ts x of
-  VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y
-  res                                 -> (x, res)
-  where
-    as_newtype = listToMaybe . mapMaybe go
-    go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}
-      | isNewDataCon dc = Just y
-    go _                = Nothing
-
-trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
-trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x
-  = set_vi <$> f (lookupVarInfo ts x)
-  where
-    set_vi (a, vi') =
-      (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })
-
-{- Note [Coverage checking Newtype matches]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Coverage checking Newtype matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a
 pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation
 testing purposes (e.g. at construction sites), they behave rather like a DataCon
@@ -588,28 +538,6 @@ Handling of Newtypes is also described in the Appendix of the Lower Your Guards
 where you can find the solution in a perhaps more digestible format.
 -}
 
-------------------------------------------------
--- * Exported utility functions querying 'Nabla'
-
-lookupRefuts :: Nabla -> Id -> [PmAltCon]
--- Unfortunately we need the extra bit of polymorphism and the unfortunate
--- duplication of lookupVarInfo here.
-lookupRefuts MkNabla{ nabla_tm_st = ts } x =
-  pmAltConSetElems $ vi_neg $ lookupVarInfo ts x
-
-isDataConSolution :: PmAltConApp -> Bool
-isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True
-isDataConSolution _                                             = False
-
--- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from
--- possibly many, preferring 'RealDataCon' solutions whenever possible.
-lookupSolution :: Nabla -> Id -> Maybe PmAltConApp
-lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of
-  []                                         -> Nothing
-  pos
-    | Just sol <- find isDataConSolution pos -> Just sol
-    | otherwise                              -> Just (head pos)
-
 -------------------------
 -- * Adding φ constraints
 --
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index 9cec967592..a111bbdd33 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE ApplicativeDo       #-}
-
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
 
 -- | Domain types used in "GHC.HsToCore.Pmc.Solver".
 -- The ultimate goal is to define 'Nabla', which models normalised refinement
@@ -11,6 +11,10 @@ module GHC.HsToCore.Pmc.Solver.Types (
         -- * Normalised refinement types
         BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..),
         Nabla(..), Nablas(..), initNablas,
+        lookupRefuts, lookupSolution,
+
+        -- ** Looking up 'VarInfo'
+        lookupVarInfo, lookupVarInfoNT, trvVarInfo,
 
         -- ** Caching residual COMPLETE sets
         CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised,
@@ -273,6 +277,77 @@ instance Outputable ResidualCompleteMatches where
   -- formats as "[{Nothing,Just},{P,Q}]"
   ppr rcm = ppr (getRcm rcm)
 
+-----------------------
+-- * Looking up VarInfo
+
+emptyRCM :: ResidualCompleteMatches
+emptyRCM = RCM Nothing Nothing
+
+emptyVarInfo :: Id -> VarInfo
+emptyVarInfo x
+  = VI
+  { vi_id = x
+  , vi_pos = []
+  , vi_neg = emptyPmAltConSet
+  -- Case (3) in Note [Strict fields and fields of unlifted type]
+  -- in GHC.HsToCore.Pmc.Solver
+  , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot
+  , vi_rcm = emptyRCM
+  }
+
+lookupVarInfo :: TmState -> Id -> VarInfo
+-- (lookupVarInfo tms x) tells what we know about 'x'
+lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)
+
+-- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks
+-- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the
+-- returned @y@ doesn't have a positive newtype constructor constraint
+-- associated with it (yet). The 'VarInfo' returned is that of @y@'s
+-- representative.
+--
+-- Careful, this means that @idType x@ might be different to @idType y@, even
+-- modulo type normalisation!
+--
+-- See also Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver.
+lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)
+lookupVarInfoNT ts x = case lookupVarInfo ts x of
+  VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y
+  res                                 -> (x, res)
+  where
+    as_newtype = listToMaybe . mapMaybe go
+    go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}
+      | isNewDataCon dc = Just y
+    go _                = Nothing
+
+trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
+trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x
+  = set_vi <$> f (lookupVarInfo ts x)
+  where
+    set_vi (a, vi') =
+      (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })
+
+------------------------------------------------
+-- * Exported utility functions querying 'Nabla'
+
+lookupRefuts :: Nabla -> Id -> [PmAltCon]
+-- Unfortunately we need the extra bit of polymorphism and the unfortunate
+-- duplication of lookupVarInfo here.
+lookupRefuts MkNabla{ nabla_tm_st = ts } x =
+  pmAltConSetElems $ vi_neg $ lookupVarInfo ts x
+
+isDataConSolution :: PmAltConApp -> Bool
+isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True
+isDataConSolution _                                             = False
+
+-- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from
+-- possibly many, preferring 'RealDataCon' solutions whenever possible.
+lookupSolution :: Nabla -> Id -> Maybe PmAltConApp
+lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of
+  []                                         -> Nothing
+  pos
+    | Just sol <- find isDataConSolution pos -> Just sol
+    | otherwise                              -> Just (head pos)
+
 --------------------------------------------------------------------------------
 -- The rest is just providing an IR for (overloaded!) literals and AltCons that
 -- sits between Hs and Core. We need a reliable way to detect and determine
@@ -434,7 +509,7 @@ pmAltConType (PmAltConLike con) arg_tys  = conLikeResTy con arg_tys
 -- | Is a match on this constructor forcing the match variable?
 -- True of data constructors, literals and pattern synonyms (#17357), but not of
 -- newtypes.
--- See Note [Coverage checking Newtype matches] in "GHC.HsToCore.Pmc.Solver".
+-- See Note [Coverage checking Newtype matches] in GHC.HsToCore.Pmc.Solver.
 isPmAltConMatchStrict :: PmAltCon -> Bool
 isPmAltConMatchStrict PmAltLit{}                      = True
 isPmAltConMatchStrict (PmAltConLike PatSynCon{})      = True -- #17357
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 3a70bc18d6..cd7bee26ef 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -34,6 +34,7 @@ import GHC.Platform
 
 import GHC.Driver.Session
 
+import GHC.HsToCore.Errors.Types
 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
 import GHC.HsToCore.Match.Literal
 import GHC.HsToCore.Monad
@@ -330,15 +331,14 @@ repTopDs group@(HsGroup { hs_valds   = valds
       }
   where
     no_splice (L loc _)
-      = notHandledL (locA loc) "Splices within declaration brackets" empty
+      = notHandledL (locA loc) ThSplicesWithinDeclBrackets
     no_default_decl (L loc decl)
-      = notHandledL (locA loc) "Default declarations" (ppr decl)
+      = notHandledL (locA loc) (ThDefaultDeclarations decl)
     no_warn :: LWarnDecl GhcRn -> MetaM a
     no_warn (L loc (Warning _ thing _))
-      = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $
-                    text "Pragma for declaration of" <+> ppr thing
+      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
     no_doc (L loc _)
-      = notHandledL (locA loc) "Haddock documentation" empty
+      = notHandledL (locA loc) ThHaddockDocumentation
 
 hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
 -- See Note [Scoped type variables in quotes]
@@ -530,9 +530,7 @@ repDataDefn tc opts
                                    ; ksig' <- repMaybeLTy ksig
                                    ; repNewtype cxt1 tc opts ksig' con'
                                                 derivs1 }
-           (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"
-                                       <+> pprQuotedList
-                                       (getConNames $ unLoc $ head cons))
+           (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))
            (DataType, _) -> do { ksig' <- repMaybeLTy ksig
                                ; consL <- mapM repC cons
                                ; cons1 <- coreListM conTyConName consL
@@ -564,7 +562,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
                 addTyClTyVarBinds resTyVar $ \_ ->
            case info of
              ClosedTypeFamily Nothing ->
-                 notHandled "abstract closed type family" (ppr decl)
+                 notHandled (ThAbstractClosedTypeFamily decl)
              ClosedTypeFamily (Just eqns) ->
                do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
                   ; eqns2  <- coreListM tySynEqnTyConName eqns1
@@ -755,7 +753,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
       return (locA loc, dec)
  where
     conv_cimportspec (CLabel cls)
-      = notHandled "Foreign label" (doubleQuotes (ppr cls))
+      = notHandled (ThForeignLabel cls)
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
     conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                             = return (unpackFS fs)
@@ -770,7 +768,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
     chStr = case mch of
             Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
             _ -> ""
-repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)
+repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)
 
 repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
 repCCallConv CCallConv          = rep2_nw cCallName []
@@ -997,8 +995,8 @@ rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
 rep_sig (L loc (SpecSig _ nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
 rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty (locA loc)
-rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
-rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas
+rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas
 rep_sig (L loc (CompleteMatchSig _ _st cls mty))
   = rep_complete_sig cls mty (locA loc)
 
@@ -1118,7 +1116,7 @@ repInline :: InlineSpec -> MetaM (Core TH.Inline)
 repInline NoInline         = dataCon noInlineDataConName
 repInline Inline           = dataCon inlineDataConName
 repInline Inlinable        = dataCon inlinableDataConName
-repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty
+repInline NoUserInlinePrag = notHandled ThNoUserInline
 
 repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
 repRuleMatch ConLike = dataCon conLikeDataConName
@@ -1416,7 +1414,7 @@ repTy (HsIParamTy _ n t) = do
                              t' <- repLTy t
                              repTImplicitParam n' t'
 
-repTy ty                      = notHandled "Exotic form of type" (ppr ty)
+repTy ty                      = notHandled (ThExoticFormOfType ty)
 
 repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
 repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]
@@ -1552,7 +1550,7 @@ repE e@(HsDo _ ctxt (L _ sts))
         wrapGenSyms ss e' }
 
   | otherwise
-  = notHandled "monad comprehension and [: :]" (ppr e)
+  = notHandled (ThMonadComprehensionSyntax e)
 
 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 repE (ExplicitTuple _ es boxity) =
@@ -1625,8 +1623,8 @@ repE (XExpr (HsExpanded orig_expr ds_expr))
          then repE ds_expr
          else repE orig_expr }
 
-repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled "Cost centres" (ppr e)
-repE e                              = notHandled "Expression form" (ppr e)
+repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
+repE e                              = notHandled (ThExpressionForm e)
 
 {- Note [Quotation and rebindable syntax]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1717,7 +1715,7 @@ repUpdFields = repListM fieldExpTyConName rep_fld
       Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
                                    ; e  <- repLE (hfbRHS fld)
                                    ; repFieldExp fn e }
-      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)
+      Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)
 
 
 
@@ -1798,7 +1796,7 @@ repSts (stmt@RecStmt{} : ss)
        ; (ss2,zs) <- addBinds ss1 (repSts ss)
        ; return (ss1++ss2, z : zs) }
 repSts []    = return ([],[])
-repSts other = notHandled "Exotic statement" (ppr other)
+repSts other = notHandled (ThExoticStatement other)
 
 
 -----------------------------------------------------------
@@ -2016,7 +2014,7 @@ repLambda (L _ (Match { m_pats = ps
                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
       ; wrapGenSyms ss lam }
 
-repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
+repLambda (L _ m) = notHandled (ThGuardedLambdas m)
 
 
 -----------------------------------------------------------------------------
@@ -2072,12 +2070,12 @@ repP (ConPat NoExtField dc details)
 repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
                                      ; repPlit a }
 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p)
 repP (SigPat _ p t) = do { p' <- repLP p
                          ; t' <- repLTy (hsPatSigType t)
                          ; repPsig p' t' }
 repP (SplicePat _ splice) = repSplice splice
-repP other = notHandled "Exotic pattern" (ppr other)
+repP other = notHandled (ThExoticPattern other)
 
 ----------------------------------------------------------
 -- Declaration ordering helpers
@@ -2841,7 +2839,7 @@ repLiteral lit
        lit_expr <- lift $ dsLit lit'
        case mb_lit_name of
           Just lit_name -> rep2_nw lit_name [lit_expr]
-          Nothing -> notHandled "Exotic literal" (ppr lit)
+          Nothing -> notHandled (ThExoticLiteral lit)
   where
     mb_lit_name = case lit of
                  HsInteger _ _ _  -> Just integerLName
@@ -3008,15 +3006,12 @@ coreVar :: Id -> Core TH.Name   -- The Id has type Name
 coreVar id = MkC (Var id)
 
 ----------------- Failure -----------------------
-notHandledL :: SrcSpan -> String -> SDoc -> MetaM a
-notHandledL loc what doc
+notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a
+notHandledL loc reason
   | isGoodSrcSpan loc
-  = mapReaderT (putSrcSpanDs loc) $ notHandled what doc
+  = mapReaderT (putSrcSpanDs loc) $ notHandled reason
   | otherwise
-  = notHandled what doc
+  = notHandled reason
 
-notHandled :: String -> SDoc -> MetaM a
-notHandled what doc = lift $ failWithDs msg
-  where
-    msg = hang (text what <+> text "not (yet) handled by Template Haskell")
-             2 doc
+notHandled :: ThRejectionReason -> MetaM a
+notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason)
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 6b08ae0877..725d99fea4 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -13,6 +13,7 @@ import GHC.Parser.Errors.Types
 import GHC.Parser.Types
 import GHC.Types.Basic
 import GHC.Types.Error
+import GHC.Types.Hint.Ppr (perhapsAsPat)
 import GHC.Types.SrcLoc
 import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual)
 import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)
@@ -774,6 +775,3 @@ pp_unexpected_fun_app e a =
 
 parse_error_in_pat :: SDoc
 parse_error_in_pat = text "Parse error in pattern:"
-
-perhapsAsPat :: SDoc
-perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 650befdd8f..a44309eaf6 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -2,12 +2,17 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
 
 module GHC.Tc.Errors.Ppr (
+    formatLevPolyErr
+  , pprLevityPolyInType
   ) where
 
 import GHC.Prelude
 
+import GHC.Core.TyCo.Ppr (pprWithTYPE)
+import GHC.Core.Type
 import GHC.Tc.Errors.Types
 import GHC.Types.Error
+import GHC.Types.Var.Env (emptyTidyEnv)
 import GHC.Driver.Flags
 import GHC.Hs
 import GHC.Utils.Outputable
@@ -16,6 +21,8 @@ instance Diagnostic TcRnMessage where
   diagnosticMessage = \case
     TcRnUnknownMessage m
       -> diagnosticMessage m
+    TcLevityPolyInType ty prov (ErrInfo extra)
+      -> mkDecorated [pprLevityPolyInType ty prov, extra]
     TcRnImplicitLift id_or_name errInfo
       -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+>
                       text "is implicitly lifted in the TH quotation"
@@ -35,6 +42,8 @@ instance Diagnostic TcRnMessage where
   diagnosticReason = \case
     TcRnUnknownMessage m
       -> diagnosticReason m
+    TcLevityPolyInType{}
+      -> ErrorWithoutFlag
     TcRnImplicitLift{}
       -> WarningWithFlag Opt_WarnImplicitLift
     TcRnUnusedPatternBinds{}
@@ -49,6 +58,8 @@ instance Diagnostic TcRnMessage where
   diagnosticHints = \case
     TcRnUnknownMessage m
       -> diagnosticHints m
+    TcLevityPolyInType{}
+      -> noHints
     TcRnImplicitLift{}
       -> noHints
     TcRnUnusedPatternBinds{}
@@ -73,3 +84,44 @@ dodgy_msg_insert tc = IEThingAll noAnn ii
   where
     ii :: LIEWrappedName (IdP (GhcPass p))
     ii = noLocA (IEName $ noLocA tc)
+
+formatLevPolyErr :: Type  -- levity-polymorphic type
+                 -> SDoc
+formatLevPolyErr ty
+  = hang (text "A levity-polymorphic type is not allowed here:")
+       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
+               , text "Kind:" <+> pprWithTYPE tidy_ki ])
+  where
+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
+    tidy_ki             = tidyType tidy_env (tcTypeKind ty)
+
+pprLevityPolyInType :: Type -> LevityCheckProvenance -> SDoc
+pprLevityPolyInType ty prov =
+  let extra = case prov of
+        LevityCheckInBinder v
+          -> text "In the type of binder" <+> quotes (ppr v)
+        LevityCheckInVarType
+          -> text "When trying to create a variable of type:" <+> ppr ty
+        LevityCheckInWildcardPattern
+          -> text "In a wildcard pattern"
+        LevityCheckInUnboxedTuplePattern p
+          -> text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
+        LevityCheckPatSynSig
+          -> empty
+        LevityCheckCmdStmt
+          -> empty -- I (Richard E, Dec '16) have no idea what to say here
+        LevityCheckMkCmdEnv id_var
+          -> text "In the result of the function" <+> quotes (ppr id_var)
+        LevityCheckDoCmd do_block
+          -> text "In the do-command:" <+> ppr do_block
+        LevityCheckDesugaringCmd cmd
+          -> text "When desugaring the command:" <+> ppr cmd
+        LevityCheckInCmd body
+          -> text "In the command:" <+> ppr body
+        LevityCheckInFunUse using
+          -> text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using
+        LevityCheckInValidDataCon
+          -> empty
+        LevityCheckInValidClass
+          -> empty
+  in formatLevPolyErr ty $$ extra
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 6da4cd6613..b0deeaaf2c 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
 module GHC.Tc.Errors.Types (
   -- * Main types
     TcRnMessage(..)
   , ErrInfo(..)
+  , LevityCheckProvenance(..)
   ) where
 
 import GHC.Hs
@@ -11,6 +13,7 @@ import GHC.Types.Name (Name)
 import GHC.Types.Name.Reader
 import GHC.Utils.Outputable
 import Data.Typeable
+import GHC.Core.Type (Type, Var)
 
 -- The majority of TcRn messages come with extra context about the error,
 -- and this newtype captures it.
@@ -22,6 +25,15 @@ data TcRnMessage where
       to provide custom diagnostic messages originated during typechecking/renaming.
   -}
   TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage
+
+  {-| A levity polymorphism check happening during TcRn.
+  -}
+  TcLevityPolyInType :: !Type
+                     -> !LevityCheckProvenance
+                     -> !ErrInfo -- Extra info accumulated in the TcM monad
+                     -> TcRnMessage
+
+
   {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when
       a Template Haskell quote implicitly uses 'lift'.
 
@@ -76,3 +88,21 @@ data TcRnMessage where
      Test cases: rename/should_compile/T4489
   -}
   TcRnMissingImportList :: IE GhcPs -> TcRnMessage
+
+
+-- | Where the levity checking for the input type originated
+data LevityCheckProvenance
+  = LevityCheckInVarType
+  | LevityCheckInBinder !Var
+  | LevityCheckInWildcardPattern
+  | LevityCheckInUnboxedTuplePattern !(Pat GhcTc)
+  | LevityCheckPatSynSig
+  | LevityCheckCmdStmt
+  | LevityCheckMkCmdEnv !Var
+  | LevityCheckDoCmd !(HsCmd GhcTc)
+  | LevityCheckDesugaringCmd !(LHsCmd GhcTc)
+  | LevityCheckInCmd !(LHsCmd GhcTc)
+  | LevityCheckInFunUse !(LHsExpr GhcTc)
+  | LevityCheckInValidDataCon
+  | LevityCheckInValidClass
+
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index ffe2e4ecdd..6edb614884 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -27,6 +27,7 @@ module GHC.Tc.Gen.Sig(
 import GHC.Prelude
 
 import GHC.Hs
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Types
 import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
@@ -445,7 +446,7 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty
        -- arguments become the types of binders. We thus cannot allow
        -- levity polymorphism here
        ; let (arg_tys, _) = tcSplitFunTys body_ty
-       ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys
+       ; mapM_ (checkForLevPoly LevityCheckPatSynSig . scaledThing) arg_tys
 
        ; traceTc "tcTySig }" $
          vcat [ text "kvs"          <+> ppr_tvs (binderVars kv_bndrs)
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index d0a511ccfa..8c23fef1cf 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -33,6 +33,7 @@ import GHC.Driver.Session
 
 import GHC.Hs
 
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import GHC.Tc.TyCl.Build
 import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
                     , reportUnsolvedEqualities )
@@ -4368,7 +4369,7 @@ checkValidDataCon dflags existential_ok tc con
           -- better error message than checkForLevPoly would.
         ; unless (isNewTyCon tc) $
             checkNoErrs $
-            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)
+            mapM_ (checkForLevPoly LevityCheckInValidDataCon) (map scaledThing $ dataConOrigArgTys con)
             -- the checkNoErrs is to prevent a panic in isVanillaDataCon
             -- (called a a few lines down), which can fall over if there is a
             -- bang on a levity-polymorphic argument. This is #18534,
@@ -4573,7 +4574,7 @@ checkValidClass cls
            -- example of what this prevents:
            --   class BoundedX (a :: TYPE r) where minBound :: a
            -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
-        ; checkForLevPoly empty tau1
+        ; checkForLevPoly LevityCheckInValidClass tau1
 
         ; unless constrained_class_methods $
           mapM_ check_constraint (tail (cls_pred:op_theta))
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index f24f949923..ccebfd6716 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -93,7 +93,7 @@ module GHC.Tc.Utils.TcMType (
 
   ------------------------------
   -- Levity polymorphism
-  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX,
   ) where
 
 -- friends:
@@ -110,6 +110,7 @@ import GHC.Core.Coercion
 import GHC.Core.Class
 import GHC.Types.Var
 import GHC.Core.Predicate
+import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Origin
 
 -- others:
@@ -2624,36 +2625,28 @@ See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
 -- isn't really a compositional property of a type system, so it's
 -- not a terrible surprise that the check has to go in an awkward spot.
 ensureNotLevPoly :: Type  -- its zonked type
-                 -> SDoc  -- where this happened
+                 -> LevityCheckProvenance  -- where this happened
                  -> TcM ()
-ensureNotLevPoly ty doc
+ensureNotLevPoly ty provenance
   = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type
                    -- forall a. a. See, for example, test ghci/scripts/T9140
-    checkForLevPoly doc ty
+    checkForLevPoly provenance ty
 
   -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
-checkForLevPoly :: SDoc -> Type -> TcM ()
-checkForLevPoly = checkForLevPolyX addErr
+checkForLevPoly :: LevityCheckProvenance -> Type -> TcM ()
+checkForLevPoly = checkForLevPolyX (\ty -> addDetailedDiagnostic . TcLevityPolyInType ty)
 
 checkForLevPolyX :: Monad m
-                 => (SDoc -> m ())  -- how to report an error
-                 -> SDoc -> Type -> m ()
-checkForLevPolyX add_err extra ty
+                 => (Type -> LevityCheckProvenance -> m ())  -- how to report an error
+                 -> LevityCheckProvenance
+                 -> Type
+                 -> m ()
+checkForLevPolyX add_err provenance ty
   | isTypeLevPoly ty
-  = add_err (formatLevPolyErr ty $$ extra)
+  = add_err ty provenance
   | otherwise
   = return ()
 
-formatLevPolyErr :: Type  -- levity-polymorphic type
-                 -> SDoc
-formatLevPolyErr ty
-  = hang (text "A levity-polymorphic type is not allowed here:")
-       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
-               , text "Kind:" <+> pprWithTYPE tidy_ki ])
-  where
-    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
-    tidy_ki             = tidyType tidy_env (tcTypeKind ty)
-
 {-
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 9207e1805f..7755ff0f14 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -53,6 +53,7 @@ import GHC.Builtin.Names
 
 import GHC.Hs
 
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
 import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
 import GHC.Tc.Utils.Monad
 import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
@@ -444,8 +445,7 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
 zonkIdBndr env v
   = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)
-       ensureNotLevPoly ty'
-         (text "In the type of binder" <+> quotes (ppr v))
+       ensureNotLevPoly ty' (LevityCheckInBinder v)
 
        return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w'))
 
@@ -1418,8 +1418,7 @@ zonk_pat env (ParPat x lpar p rpar)
 
 zonk_pat env (WildPat ty)
   = do  { ty' <- zonkTcTypeToTypeX env ty
-        ; ensureNotLevPoly ty'
-            (text "In a wildcard pattern")
+        ; ensureNotLevPoly ty' LevityCheckInWildcardPattern
         ; return (env, WildPat ty') }
 
 zonk_pat env (VarPat x (L l v))
@@ -1485,7 +1484,7 @@ zonk_pat env p@(ConPat { pat_con = L _ con
         ; case con of
             RealDataCon dc
               | isUnboxedTupleTyCon (dataConTyCon dc)
-              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
+              -> mapM_ (checkForLevPoly (LevityCheckInUnboxedTuplePattern p)) (dropRuntimeRepArgs new_tys)
             _ -> return ()
 
         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
@@ -1509,8 +1508,6 @@ zonk_pat env p@(ConPat { pat_con = L _ con
                  }
                )
         }
-  where
-    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
 
 zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
 
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 51cd77b33a..475e0ee6fb 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -1,13 +1,20 @@
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE LambdaCase #-}
-module GHC.Types.Hint where
 
-import GHC.Prelude
+module GHC.Types.Hint (
+  GhcHint(..),
+  InstantiationSuggestion(..)
+  ) where
 
 import GHC.Utils.Outputable
-import GHC.LanguageExtensions
+import qualified GHC.LanguageExtensions as LangExt
 import Data.Typeable
 import GHC.Unit.Module (ModuleName, Module)
+import GHC.Hs.Extension (GhcTc)
+import GHC.Types.Var (Var)
+import GHC.Types.Basic (Activation, RuleName)
+import {-# SOURCE #-} Language.Haskell.Syntax.Expr
+  -- This {-# SOURCE #-} import should be removable once
+  -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'.
 
 -- | A type for hints emitted by GHC.
 -- A /hint/ suggests a possible way to deal with a particular warning or error.
@@ -29,7 +36,7 @@ data GhcHint
                       parser/should_fail/T18251e, ... (and many more)
 
     -}
-  | SuggestExtension !Extension
+  | SuggestExtension !LangExt.Extension
     {-| Suggests that a monadic code block is probably missing a \"do\" keyword.
 
         Example:
@@ -68,51 +75,46 @@ data GhcHint
       Test case(s): driver/T12955
     -}
   | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion]
-  {-| Suggests to use spaces instead of tabs.
+    {-| Suggests to use spaces instead of tabs.
 
-      Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'.
+        Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'.
 
-      Examples: None
-      Test Case(s): None
-  -}
+        Examples: None
+        Test Case(s): None
+    -}
   | SuggestUseSpaces
-  {-| Suggests wrapping an expression in parentheses
+    {-| Suggests wrapping an expression in parentheses
 
-      Examples: None
-      Test Case(s): None
-  -}
+        Examples: None
+        Test Case(s): None
+    -}
   | SuggestParentheses
+    {-| Suggests to increase the -fmax-pmcheck-models limit for the pattern match checker.
+
+      Triggered by: 'GHC.HsToCore.Errors.Types.DsMaxPmCheckModelsReached'
+
+      Test case(s): pmcheck/should_compile/TooManyDeltas
+                    pmcheck/should_compile/TooManyDeltas
+                    pmcheck/should_compile/T11822
+    -}
+  | SuggestIncreaseMaxPmCheckModels
+    {-| Suggests adding a type signature, typically to resolve ambiguity or help GHC inferring types.
+
+    -}
+  | SuggestAddTypeSignature
+    {-| Suggests to explicitly discard the result of a monadic action by binding the result to
+        the '_' wilcard.
+
+        Example:
+           main = do
+             _ <- getCurrentTime
+
+    -}
+  | SuggestBindToWildcard !(LHsExpr GhcTc)
 
+  | SuggestAddInlineOrNoInlinePragma !Var !Activation
 
-instance Outputable GhcHint where
-  ppr = \case
-    UnknownHint m
-      -> ppr m
-    SuggestExtension ext
-      -> text "Perhaps you intended to use" <+> ppr ext
-    SuggestMissingDo
-      -> text "Possibly caused by a missing 'do'?"
-    SuggestLetInDo
-      -> text "Perhaps you need a 'let' in a 'do' block?"
-           $$ text "e.g. 'let x = 5' instead of 'x = 5'"
-    SuggestAddSignatureCabalFile pi_mod_name
-      -> text "Try adding" <+> quotes (ppr pi_mod_name)
-           <+> text "to the"
-           <+> quotes (text "signatures")
-           <+> text "field in your Cabal file."
-    SuggestSignatureInstantiations pi_mod_name suggestions
-      -> let suggested_instantiated_with =
-               hcat (punctuate comma $
-                   [ ppr k <> text "=" <> ppr v
-                   | InstantiationSuggestion k v <- suggestions
-                   ])
-         in text "Try passing -instantiated-with=\"" <>
-              suggested_instantiated_with <> text "\"" $$
-                text "replacing <" <> ppr pi_mod_name <> text "> as necessary."
-    SuggestUseSpaces
-      -> text "Please use spaces instead."
-    SuggestParentheses
-      -> text "Use parentheses."
+  | SuggestAddPhaseToCompetingRule !RuleName
 
 -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
 -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
new file mode 100644
index 0000000000..ad8c614c16
--- /dev/null
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE LambdaCase #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}   -- instance Outputable GhcHint
+
+module GHC.Types.Hint.Ppr (
+  perhapsAsPat
+  -- also, and more interesting: instance Outputable GhcHint
+  ) where
+
+import GHC.Prelude
+
+import GHC.Types.Hint
+
+import GHC.Hs.Expr ()   -- instance Outputable
+import GHC.Types.Id
+import GHC.Utils.Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
+instance Outputable GhcHint where
+  ppr = \case
+    UnknownHint m
+      -> ppr m
+    SuggestExtension ext
+      -> case ext of
+          LangExt.NegativeLiterals
+            -> text "If you are trying to write a large negative literal, use NegativeLiterals"
+          _ -> text "Perhaps you intended to use" <+> ppr ext
+    SuggestMissingDo
+      -> text "Possibly caused by a missing 'do'?"
+    SuggestLetInDo
+      -> text "Perhaps you need a 'let' in a 'do' block?"
+           $$ text "e.g. 'let x = 5' instead of 'x = 5'"
+    SuggestAddSignatureCabalFile pi_mod_name
+      -> text "Try adding" <+> quotes (ppr pi_mod_name)
+           <+> text "to the"
+           <+> quotes (text "signatures")
+           <+> text "field in your Cabal file."
+    SuggestSignatureInstantiations pi_mod_name suggestions
+      -> let suggested_instantiated_with =
+               hcat (punctuate comma $
+                   [ ppr k <> text "=" <> ppr v
+                   | InstantiationSuggestion k v <- suggestions
+                   ])
+         in text "Try passing -instantiated-with=\"" <>
+              suggested_instantiated_with <> text "\"" $$
+                text "replacing <" <> ppr pi_mod_name <> text "> as necessary."
+    SuggestUseSpaces
+      -> text "Please use spaces instead."
+    SuggestParentheses
+      -> text "Use parentheses."
+    SuggestIncreaseMaxPmCheckModels
+      -> text "Increase the limit or resolve the warnings to suppress this message."
+    SuggestAddTypeSignature
+      -> text "Add a type signature."
+    SuggestBindToWildcard rhs
+      -> hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs)
+    SuggestAddInlineOrNoInlinePragma lhs_id rule_act
+      -> vcat [ text "Add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id)
+              , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act)
+              ]
+    SuggestAddPhaseToCompetingRule bad_rule
+      -> vcat [ text "Add phase [n] or [~n] to the competing rule"
+              , whenPprDebug (ppr bad_rule) ]
+
+perhapsAsPat :: SDoc
+perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fae95343f6..40cfde0d3a 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -643,6 +643,7 @@ Library
         GHC.Types.ForeignCall
         GHC.Types.ForeignStubs
         GHC.Types.Hint
+        GHC.Types.Hint.Ppr
         GHC.Types.HpcInfo
         GHC.Types.Id
         GHC.Types.IPE
diff --git a/testsuite/tests/deSugar/should_compile/T10662.stderr b/testsuite/tests/deSugar/should_compile/T10662.stderr
index 6a5cc457fc..e1f8c75c17 100644
--- a/testsuite/tests/deSugar/should_compile/T10662.stderr
+++ b/testsuite/tests/deSugar/should_compile/T10662.stderr
@@ -1,5 +1,6 @@
 
 T10662.hs:3:3: warning: [-Wunused-do-bind (in -Wall)]
     A do-notation statement discarded a result of type ‘String’
-    Suppress this warning by saying
-      ‘_ <- return $ let a = "hello" in a’
+    Suggested fix:
+      Suppress this warning by saying
+        ‘_ <- return $ let a = "hello" in a’
diff --git a/testsuite/tests/deSugar/should_compile/T3263-1.stderr b/testsuite/tests/deSugar/should_compile/T3263-1.stderr
index a50f8933aa..acc59ab3cd 100644
--- a/testsuite/tests/deSugar/should_compile/T3263-1.stderr
+++ b/testsuite/tests/deSugar/should_compile/T3263-1.stderr
@@ -1,8 +1,10 @@
 
 T3263-1.hs:25:3: warning: [-Wunused-do-bind (in -Wall)]
     A do-notation statement discarded a result of type ‘Int’
-    Suppress this warning by saying ‘_ <- nonNullM’
+    Suggested fix:
+      Suppress this warning by saying ‘_ <- nonNullM’
 
 T3263-1.hs:35:3: warning: [-Wunused-do-bind (in -Wall)]
     A do-notation statement discarded a result of type ‘Int’
-    Suppress this warning by saying ‘_ <- nonNullM’
+    Suggested fix:
+      Suppress this warning by saying ‘_ <- nonNullM’
diff --git a/testsuite/tests/deSugar/should_compile/T3263-2.stderr b/testsuite/tests/deSugar/should_compile/T3263-2.stderr
index 83de241f50..32c3bc3ad8 100644
--- a/testsuite/tests/deSugar/should_compile/T3263-2.stderr
+++ b/testsuite/tests/deSugar/should_compile/T3263-2.stderr
@@ -1,8 +1,10 @@
 
 T3263-2.hs:25:3: warning: [-Wwrong-do-bind (in -Wdefault)]
     A do-notation statement discarded a result of type ‘m Int’
-    Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’
+    Suggested fix:
+      Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’
 
 T3263-2.hs:37:3: warning: [-Wwrong-do-bind (in -Wdefault)]
     A do-notation statement discarded a result of type ‘m Int’
-    Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’
+    Suggested fix:
+      Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’
diff --git a/testsuite/tests/driver/recomp005/recomp005.stderr b/testsuite/tests/driver/recomp005/recomp005.stderr
index f1c81418a2..9a966f977b 100644
--- a/testsuite/tests/driver/recomp005/recomp005.stderr
+++ b/testsuite/tests/driver/recomp005/recomp005.stderr
@@ -1,9 +1,11 @@
 
 C.hs:7:11: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "f/g" may never fire because ‘g’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘g’
+    Suggested fix:
+      Add an INLINE[n] or NOINLINE[n] pragma for ‘g’
 
 C.hs:7:11: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "f/g" may never fire because ‘f’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘f’
+    Suggested fix:
+      Add an INLINE[n] or NOINLINE[n] pragma for ‘f’
 
diff --git a/testsuite/tests/ghci/scripts/T3263.stderr b/testsuite/tests/ghci/scripts/T3263.stderr
index df58a5dc58..dd72b3f31b 100644
--- a/testsuite/tests/ghci/scripts/T3263.stderr
+++ b/testsuite/tests/ghci/scripts/T3263.stderr
@@ -1,4 +1,5 @@
 
 T3263.hs:8:12: warning: [-Wunused-do-bind (in -Wall)]
     A do-notation statement discarded a result of type ‘Char’
-    Suppress this warning by saying ‘_ <- getChar’
+    Suggested fix:
+      Suppress this warning by saying ‘_ <- getChar’
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
index 85406d04b6..584803afbc 100644
--- a/testsuite/tests/ghci/scripts/T9140.stdout
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -1,11 +1,11 @@
 
 <interactive>:2:5: error:
     You can't mix polymorphic and unlifted bindings: a = (# 1 #)
-    Probable fix: add a type signature
+    Suggested fix: Add a type signature.
 
 <interactive>:3:5: error:
     You can't mix polymorphic and unlifted bindings: a = (# 1, 3 #)
-    Probable fix: add a type signature
+    Suggested fix: Add a type signature.
 
 <interactive>:1:1: error:
     GHCi can't bind a variable of unlifted type:
diff --git a/testsuite/tests/numeric/should_compile/T8542.stderr b/testsuite/tests/numeric/should_compile/T8542.stderr
index 699ba5d573..fb6ddf7a72 100644
--- a/testsuite/tests/numeric/should_compile/T8542.stderr
+++ b/testsuite/tests/numeric/should_compile/T8542.stderr
@@ -1,4 +1,5 @@
 
 T8542.hs:9:5: warning: [-Woverflowed-literals (in -Wdefault)]
     Literal 128 is out of the Int8 range -128..127
-    If you are trying to write a large negative literal, use NegativeLiterals
+    Suggested fix:
+      If you are trying to write a large negative literal, use NegativeLiterals
diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout
index d17ccda974..4b33ad2982 100644
--- a/testsuite/tests/parser/should_run/CountAstDeps.stdout
+++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout
@@ -1,4 +1,4 @@
-Found 258 Language.Haskell.Syntax module dependencies
+Found 266 Language.Haskell.Syntax module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.Types
@@ -31,6 +31,7 @@ GHC.Core.FamInstEnv
 GHC.Core.InstEnv
 GHC.Core.Lint
 GHC.Core.Make
+GHC.Core.Map.Expr
 GHC.Core.Map.Type
 GHC.Core.Multiplicity
 GHC.Core.Opt.Arity
@@ -108,6 +109,9 @@ GHC.Hs.Type
 GHC.Hs.Utils
 GHC.HsToCore.Errors.Ppr
 GHC.HsToCore.Errors.Types
+GHC.HsToCore.Pmc.Ppr
+GHC.HsToCore.Pmc.Solver.Types
+GHC.HsToCore.Pmc.Types
 GHC.Iface.Ext.Fields
 GHC.Iface.Recomp.Binary
 GHC.Iface.Syntax
@@ -148,6 +152,8 @@ GHC.SysTools.Terminal
 GHC.Tc.Errors.Hole.FitTypes
 GHC.Tc.Errors.Ppr
 GHC.Tc.Errors.Types
+GHC.Tc.Solver.InertSet
+GHC.Tc.Solver.Types
 GHC.Tc.Types
 GHC.Tc.Types.Constraint
 GHC.Tc.Types.Evidence
@@ -168,6 +174,7 @@ GHC.Types.Fixity.Env
 GHC.Types.ForeignCall
 GHC.Types.ForeignStubs
 GHC.Types.Hint
+GHC.Types.Hint.Ppr
 GHC.Types.HpcInfo
 GHC.Types.IPE
 GHC.Types.Id
@@ -197,6 +204,7 @@ GHC.Types.Unique.DFM
 GHC.Types.Unique.DSet
 GHC.Types.Unique.FM
 GHC.Types.Unique.Map
+GHC.Types.Unique.SDFM
 GHC.Types.Unique.Set
 GHC.Types.Unique.Supply
 GHC.Types.Var
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout
index c9080fbce3..16dbb8e185 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.stdout
+++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout
@@ -1,4 +1,4 @@
-Found 264 GHC.Parser module dependencies
+Found 272 GHC.Parser module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.Types
@@ -31,6 +31,7 @@ GHC.Core.FamInstEnv
 GHC.Core.InstEnv
 GHC.Core.Lint
 GHC.Core.Make
+GHC.Core.Map.Expr
 GHC.Core.Map.Type
 GHC.Core.Multiplicity
 GHC.Core.Opt.Arity
@@ -109,6 +110,9 @@ GHC.Hs.Type
 GHC.Hs.Utils
 GHC.HsToCore.Errors.Ppr
 GHC.HsToCore.Errors.Types
+GHC.HsToCore.Pmc.Ppr
+GHC.HsToCore.Pmc.Solver.Types
+GHC.HsToCore.Pmc.Types
 GHC.Iface.Ext.Fields
 GHC.Iface.Recomp.Binary
 GHC.Iface.Syntax
@@ -154,6 +158,8 @@ GHC.SysTools.Terminal
 GHC.Tc.Errors.Hole.FitTypes
 GHC.Tc.Errors.Ppr
 GHC.Tc.Errors.Types
+GHC.Tc.Solver.InertSet
+GHC.Tc.Solver.Types
 GHC.Tc.Types
 GHC.Tc.Types.Constraint
 GHC.Tc.Types.Evidence
@@ -174,6 +180,7 @@ GHC.Types.Fixity.Env
 GHC.Types.ForeignCall
 GHC.Types.ForeignStubs
 GHC.Types.Hint
+GHC.Types.Hint.Ppr
 GHC.Types.HpcInfo
 GHC.Types.IPE
 GHC.Types.Id
@@ -203,6 +210,7 @@ GHC.Types.Unique.DFM
 GHC.Types.Unique.DSet
 GHC.Types.Unique.FM
 GHC.Types.Unique.Map
+GHC.Types.Unique.SDFM
 GHC.Types.Unique.Set
 GHC.Types.Unique.Supply
 GHC.Types.Var
diff --git a/testsuite/tests/pmcheck/should_compile/T11822.stderr b/testsuite/tests/pmcheck/should_compile/T11822.stderr
index 8ad52e6de4..212d300537 100644
--- a/testsuite/tests/pmcheck/should_compile/T11822.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T11822.stderr
@@ -19,5 +19,6 @@ T11822.hs:33:1: warning:
       • Redundant clauses might not be reported at all
       • Redundant clauses might be reported as inaccessible
       • Patterns reported as unmatched might actually be matched
-    Increase the limit or resolve the warnings to suppress this message.
+    Suggested fix:
+      Increase the limit or resolve the warnings to suppress this message.
 
diff --git a/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr b/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr
index cb65b8cab4..9297e1b669 100644
--- a/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr
+++ b/testsuite/tests/pmcheck/should_compile/TooManyDeltas.stderr
@@ -13,14 +13,16 @@ TooManyDeltas.hs:14:1: warning:
       • Redundant clauses might not be reported at all
       • Redundant clauses might be reported as inaccessible
       • Patterns reported as unmatched might actually be matched
-    Increase the limit or resolve the warnings to suppress this message.
+    Suggested fix:
+      Increase the limit or resolve the warnings to suppress this message.
 
 TooManyDeltas.hs:19:1: warning:
     Pattern match checker ran into -fmax-pmcheck-models=0 limit, so
       • Redundant clauses might not be reported at all
       • Redundant clauses might be reported as inaccessible
       • Patterns reported as unmatched might actually be matched
-    Increase the limit or resolve the warnings to suppress this message.
+    Suggested fix:
+      Increase the limit or resolve the warnings to suppress this message.
 
 TooManyDeltas.hs:20:1: warning: [-Woverlapping-patterns (in -Wdefault)]
     Pattern match has inaccessible right hand side
diff --git a/testsuite/tests/rename/should_compile/T2600.stderr b/testsuite/tests/rename/should_compile/T2600.stderr
index ca675475cf..64ef6e9e82 100644
--- a/testsuite/tests/rename/should_compile/T2600.stderr
+++ b/testsuite/tests/rename/should_compile/T2600.stderr
@@ -2,10 +2,12 @@
 T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "myrule" may never fire
       because rule "Class op to" for ‘to’ might fire first
-    Probable fix: add phase [n] or [~n] to the competing rule
+    Suggested fix:
+      Add phase [n] or [~n] to the competing rule
 
 T2600.hs:16:1: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "myrule" may never fire
       because rule "Class op tmap" for ‘tmap’ might fire first
-    Probable fix: add phase [n] or [~n] to the competing rule
+    Suggested fix:
+      Add phase [n] or [~n] to the competing rule
 
diff --git a/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr b/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr
index 7359861750..3a3332769e 100644
--- a/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr
+++ b/testsuite/tests/simplCore/should_compile/T6082-RULE.stderr
@@ -1,8 +1,10 @@
 
 T6082-RULE.hs:5:11: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "foo1" may never fire because ‘foo1’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’
+    Suggested fix:
+      Add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’
 
 T6082-RULE.hs:10:11: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "foo2" may never fire because ‘foo2’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’
+    Suggested fix:
+      Add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’
diff --git a/testsuite/tests/simplCore/should_compile/T7287.stderr b/testsuite/tests/simplCore/should_compile/T7287.stderr
index 5aa71e0e98..957282b8f3 100644
--- a/testsuite/tests/simplCore/should_compile/T7287.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7287.stderr
@@ -2,4 +2,5 @@
 T7287.hs:7:3: warning: [-Winline-rule-shadowing (in -Wdefault)]
     Rule "int2Word#/word2Int#" may never fire
       because rule "word2Int#" for ‘word2Int#’ might fire first
-    Probable fix: add phase [n] or [~n] to the competing rule
+    Suggested fix:
+      Add phase [n] or [~n] to the competing rule
diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr
index 62a4210443..65f5df765e 100644
--- a/testsuite/tests/typecheck/should_fail/T6078.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6078.stderr
@@ -2,4 +2,4 @@
 T6078.hs:8:10: error:
     You can't mix polymorphic and unlifted bindings:
       ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
-    Probable fix: add a type signature
+    Suggested fix: Add a type signature.