Support new parser types in GHC

This commit converts the lexers and all the parser machinery to use the
new parser types and diagnostics infrastructure. Furthermore, it cleans
up the way the parser code was emitting hints.

As a result of this systematic approach, the test output of the
`InfixAppPatErr` and `T984` tests have been changed. Previously they
would emit a `SuggestMissingDo` hint, but this was not at all helpful in
resolving the error, and it was even confusing by just looking at the
original program that triggered the errors.

Update haddock submodule

1 files changed, 160 insertions, 125 deletions

diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 261967be85..e29a8314ff 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -58,7 +58,9 @@ module GHC.Parser.PostProcess (
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
         checkPattern,         -- HsExp -> P HsPat
-        checkPattern_hints,
+        checkPattern_details,
+        incompleteDoBlock,
+        ParseContext(..),
         checkMonadComp,       -- P (HsStmtContext GhcPs)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
@@ -119,12 +121,13 @@ import GHC.Types.Name.Reader
 import GHC.Types.Name
 import GHC.Unit.Module (ModuleName)
 import GHC.Types.Basic
-import GHC.Types.Error ( GhcHint(..) )
+import GHC.Types.Error
 import GHC.Types.Fixity
 import GHC.Types.SourceText
 import GHC.Parser.Types
 import GHC.Parser.Lexer
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr ()
 import GHC.Utils.Lexeme ( isLexCon )
 import GHC.Types.TyThing
 import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )
@@ -138,16 +141,14 @@ import GHC.Data.OrdList
 import GHC.Utils.Outputable as Outputable
 import GHC.Data.FastString
 import GHC.Data.Maybe
-import GHC.Data.Bag
+import GHC.Utils.Error
 import GHC.Utils.Misc
 import Data.Either
 import Data.List        ( findIndex )
 import Data.Foldable
-import GHC.Driver.Flags ( WarningFlag(..) )
 import qualified Data.Semigroup as Semi
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import qualified GHC.LanguageExtensions as LangExt
 import qualified GHC.Data.Strict as Strict
 
 import Control.Monad
@@ -275,12 +276,14 @@ mkStandaloneKindSig loc lhs rhs anns =
     check_lhs_name v@(unLoc->name) =
       if isUnqual name && isTcOcc (rdrNameOcc name)
       then return v
-      else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v)
+      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $
+             (PsErrUnexpectedQualifiedConstructor (unLoc v))
     check_singular_lhs vs =
       case vs of
         [] -> panic "mkStandaloneKindSig: empty left-hand side"
         [v] -> return v
-        _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)
+        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $
+               (PsErrMultipleNamesInStandaloneKindSignature vs)
 
 mkTyFamInstEqn :: SrcSpan
                -> HsOuterFamEqnTyVarBndrs GhcPs
@@ -409,7 +412,8 @@ mkRoleAnnotDecl loc tycon roles anns
             let nearby = fuzzyLookup (unpackFS role)
                   (mapFst unpackFS possible_roles)
             in
-            addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role
+            addFatalError $ mkPlainErrorMsgEnvelope loc_role $
+              (PsErrIllegalRoleName role nearby)
 
 -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
 -- binders without annotations. Only accepts specified variables, and errors if
@@ -429,7 +433,8 @@ fromSpecTyVarBndr bndr = case bndr of
   where
     check_spec :: Specificity -> SrcSpanAnnA -> P ()
     check_spec SpecifiedSpec _   = return ()
-    check_spec InferredSpec  loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc)
+    check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+                                     PsErrInferredTypeVarNotAllowed
 
 -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@
 annBinds :: AddEpAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs
@@ -508,7 +513,7 @@ cvBindsAndSigs fb = do
     -- called on top-level declarations.
     drop_bad_decls [] = return []
     drop_bad_decls (L l (SpliceD _ d) : ds) = do
-      addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l)
+      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d
       drop_bad_decls ds
     drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
 
@@ -618,14 +623,14 @@ constructor, a type, or a context, we would need unlimited lookahead which
 -- | Reinterpret a type constructor, including type operators, as a data
 --   constructor.
 -- See Note [Parsing data constructors is hard]
-tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName)
+tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)
 tyConToDataCon (L loc tc)
   | isTcOcc occ || isDataOcc occ
   , isLexCon (occNameFS occ)
   = return (L loc (setRdrNameSpace tc srcDataName))
 
   | otherwise
-  = Left $ PsError (PsErrNotADataCon tc) [] (locA loc)
+  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)
   where
     occ = rdrNameOcc tc
 
@@ -666,17 +671,21 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
     fromDecl (L loc decl) = extraDeclErr (locA loc) decl
 
     extraDeclErr loc decl =
-        addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc
+        addFatalError $ mkPlainErrorMsgEnvelope loc $
+          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)
 
     wrongNameBindingErr loc decl =
-      addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc
+      addFatalError $ mkPlainErrorMsgEnvelope loc $
+          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)
 
     wrongNumberErr loc =
-      addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc
+      addFatalError $ mkPlainErrorMsgEnvelope loc $
+        (PsErrEmptyWhereInPatSynDecl patsyn_name)
 
 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
 recordPatSynErr loc pat =
-    addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc
+    addFatalError $ mkPlainErrorMsgEnvelope loc $
+      (PsErrRecordSyntaxInPatSynDecl pat)
 
 mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                 -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
@@ -817,7 +826,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
-eitherToP :: MonadP m => Either PsError a -> m a
+eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a
 -- Adapts the Either monad to the P monad
 eitherToP (Left err)    = addFatalError err
 eitherToP (Right thing) = return thing
@@ -831,9 +840,11 @@ checkTyVars pp_what equals_or_where tc tparms
   = do { (tvs, anns) <- fmap unzip $ mapM check tparms
        ; return (mkHsQTvs tvs, concat anns) }
   where
-    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc)
+    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+                                         (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))
     check (HsValArg ty) = chkParens [] emptyComments ty
-    check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp
+    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $
+                            (PsErrMalformedDecl pp_what (unLoc tc))
         -- Keep around an action for adjusting the annotations of extra parens
     chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
               -> P (LHsTyVarBndr () GhcPs, [AddEpAnn])
@@ -853,7 +864,8 @@ checkTyVars pp_what equals_or_where tc tparms
         | isRdrTyVar tv    = return (L (widenLocatedAn l an)
                                      (UserTyVar (addAnns ann an cs) () (L ltv tv)))
     chk _ _ t@(L loc _)
-        = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc)
+        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
 
 
 whereDots, equalsDots :: SDoc
@@ -865,7 +877,8 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
 checkDatatypeContext Nothing = return ()
 checkDatatypeContext (Just c)
     = do allowed <- getBit DatatypeContextsBit
-         unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c)
+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $
+                                       (PsErrIllegalDataTypeContext c)
 
 type LRuleTyTmVar = Located RuleTyTmVar
 data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))
@@ -895,13 +908,15 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
   where check (L loc (Unqual occ)) =
           -- TODO: don't use string here, OccName has a Unique/FastString
           when ((occNameString occ ==) `any` ["forall","family","role"])
-            (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc))
+            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+               (PsErrParseErrorOnInput occ))
         check _ = panic "checkRuleTyVarBndrNames"
 
 checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
 checkRecordSyntax lr@(L loc r)
     = do allowed <- getBit TraditionalRecordSyntaxBit
-         unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc)
+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $
+                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))
          return lr
 
 -- | Check if the gadt_constrlist is empty. Only raise parse error for
@@ -910,7 +925,8 @@ checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
                 -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.
     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
-         unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span
+         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $
+                                          PsErrIllegalWhereInDataDecl
          return gadts
 checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.
 
@@ -933,7 +949,7 @@ checkTyClHdr is_cls ty
 
     -- workaround to define '*' despite StarIsType
     go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix
-      = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l))
+      = do { addPsMessage (locA l) PsWarnStarBinder
            ; let name = mkOccName tcClsName (starSym isUni)
            ; let a' = newAnns l an
            ; return (L a' (Unqual name), acc, fix
@@ -955,7 +971,8 @@ checkTyClHdr is_cls ty
                  | otherwise = getName (tupleTyCon Boxed arity)
           -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
     go l _ _ _ _
-      = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l
+      = addFatalError $ mkPlainErrorMsgEnvelope l $
+          (PsErrMalformedTyOrClDecl ty)
 
     -- Combine the annotations from the HsParTy and HsStarTy into a
     -- new one for the LocatedN RdrName
@@ -1003,7 +1020,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
     check err a = do
       blockArguments <- getBit BlockArgumentsBit
       unless blockArguments $
-        addError $ PsError (err a) [] (getLocA a)
+        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)
 
 -- | Validate the context constraints and break up a context into a list
 -- of predicates.
@@ -1077,8 +1094,8 @@ checkImportDecl mPre mPost = do
 checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
 checkPattern = runPV . checkLPat
 
-checkPattern_hints :: [GhcHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
-checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)
+checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
+checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
 
 checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
 checkLPat e@(L l _) = checkPat l e [] []
@@ -1092,11 +1109,10 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
       , pat_args = PrefixCon tyargs args
       }
   | not (null tyargs) =
-      add_hint TypeApplicationsInPatternsOnlyDataCons $
-      patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])
-  | not (null args) && patIsRec c =
-      add_hint (SuggestExtension LangExt.RecursiveDo) $
-      patFail (locA l) (ppr e)
+      patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs
+  | (not (null args) && patIsRec c) = do
+      ctx <- askParseContext
+      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
 checkPat loc (L _ (PatBuilderAppType f t)) tyargs args =
   checkPat loc f (t : tyargs) args
 checkPat loc (L _ (PatBuilderApp f e)) [] args = do
@@ -1105,7 +1121,9 @@ checkPat loc (L _ (PatBuilderApp f e)) [] args = do
 checkPat loc (L l e) [] [] = do
   p <- checkAPat loc e
   return (L l p)
-checkPat loc e _ _ = patFail (locA loc) (ppr e)
+checkPat loc e _ _ = do
+  details <- fromParseContext <$> askParseContext
+  patFail (locA loc) (PsErrInPat (unLoc e) details)
 
 checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
 checkAPat loc e0 = do
@@ -1130,7 +1148,7 @@ checkAPat loc e0 = do
 
    -- Improve error messages for the @-operator when the user meant an @-pattern
    PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do
-     addError $ PsError PsErrAtInPatPos [] (getLocA op)
+     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
      return (WildPat noExtField)
 
    PatBuilderOpApp l (L cl c) r anns
@@ -1147,7 +1165,9 @@ checkAPat loc e0 = do
      p <- checkLPat e
      return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)
 
-   _           -> patFail (locA loc) (ppr e0)
+   _           -> do
+     details <- fromParseContext <$> askParseContext
+     patFail (locA loc) (PsErrInPat e0 details)
 
 placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
 -- The RHS of a punned record field will be filled in by the renamer
@@ -1164,8 +1184,8 @@ checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))
 checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)
                              return (L l (fld { hfbRHS = p }))
 
-patFail :: SrcSpan -> SDoc -> PV a
-patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc
+patFail :: SrcSpan -> PsMessage -> PV a
+patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg
 
 patIsRec :: RdrName -> Bool
 patIsRec e = e == mkUnqual varName (fsLit "rec")
@@ -1204,7 +1224,7 @@ checkFunBind :: SrcStrictness
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P (HsBind GhcPs)
 checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
-  = do  ps <- runPV_hints param_hints (mapM checkLPat pats)
+  = do  ps <- runPV_details extraDetails (mapM checkLPat pats)
         let match_span = noAnnSrcSpan $ locF
         cs <- getCommentsFor locF
         return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
@@ -1218,9 +1238,9 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
   where
-    param_hints
-      | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]
-      | otherwise         = []
+    extraDetails
+      | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock
+      | otherwise         = noParseContext
 
 makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
@@ -1260,11 +1280,11 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
   = return lrdr
 
 checkValSigLhs lhs@(L l _)
-  = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l)
+  = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs
 
 checkDoAndIfThenElse
   :: (Outputable a, Outputable b, Outputable c)
-  => (a -> Bool -> b -> Bool -> c -> PsErrorDesc)
+  => (a -> Bool -> b -> Bool -> c -> PsMessage)
   -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()
 checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse = do
@@ -1274,7 +1294,7 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
                     semiElse (unLoc elseExpr)
           loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)
 
-      unless doAndIfThenElse $ addError (PsError e [] loc)
+      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)
   | otherwise = return ()
 
 isFunLhs :: LocatedA (PatBuilder GhcPs)
@@ -1390,7 +1410,7 @@ instance DisambInfixOp (HsExpr GhcPs) where
 instance DisambInfixOp RdrName where
   mkHsConOpPV (L l v) = return $ L l v
   mkHsVarOpPV (L l v) = return $ L l v
-  mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l
+  mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole
 
 type AnnoBody b
   = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan
@@ -1554,7 +1574,8 @@ instance DisambECP (HsCmd GhcPs) where
   type Body (HsCmd GhcPs) = HsCmd
   ecpFromCmd' = return
   ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
+                                                 PsErrOverloadedRecordDotInvalid
   mkHsLamPV l mg = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))
@@ -1590,7 +1611,7 @@ instance DisambECP (HsCmd GhcPs) where
   mkHsDoPV l Nothing stmts anns = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)
-  mkHsDoPV l (Just m)    _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l
+  mkHsDoPV l (Just m)    _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
   mkHsParPV l lpar c rpar = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)
@@ -1605,7 +1626,7 @@ instance DisambECP (HsCmd GhcPs) where
   mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do
     let (fs, ps) = partitionEithers fbinds
     if not (null ps)
-      then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid
       else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)
   mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)
   mkHsSectionR_PV l op c = cmdFail l $
@@ -1624,17 +1645,17 @@ instance DisambECP (HsCmd GhcPs) where
   rejectPragmaPV _ = return ()
 
 cmdFail :: SrcSpan -> SDoc -> PV a
-cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc
+cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e
 
 checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()
 checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do
-  when (null (hsLMatchPats matches)) $ addError $ PsError PsErrEmptyLambda [] l
+  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda
 checkLamMatchGroup _ _ = return ()
 
 instance DisambECP (HsExpr GhcPs) where
   type Body (HsExpr GhcPs) = HsExpr
   ecpFromCmd' (L l c) = do
-    addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l)
+    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c
     return (L l (hsHoleExpr noAnn))
   ecpFromExp' = return
   mkHsProjUpdatePV l fields arg isPun anns = do
@@ -1708,19 +1729,20 @@ instance DisambECP (HsExpr GhcPs) where
   mkHsSectionR_PV l op e = do
     cs <- getCommentsFor l
     return $ L l (SectionR (comment (realSrcSpan l) cs) op e)
-  mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l)
+  mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
-  mkHsAsPatPV l v e   _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l)
+  mkHsAsPatPV l v e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
-  mkHsLazyPatPV l e   _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l)
+  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)
                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
-  mkHsBangPatPV l e   _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l)
+  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)
                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
   mkSumOrTuplePV = mkSumOrTupleExpr
   rejectPragmaPV (L _ (OpApp _ _ _ e)) =
     -- assuming left-associative parsing of operators
     rejectPragmaPV e
-  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l)
+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $
+                                                         (PsErrUnallowedPragma prag)
   rejectPragmaPV _                        = return ()
 
 hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs
@@ -1733,19 +1755,19 @@ type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanA
 
 instance DisambECP (PatBuilder GhcPs) where
   type Body (PatBuilder GhcPs) = PatBuilder
-  ecpFromCmd' (L l c)    = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l)
-  ecpFromExp' (L l e)    = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l)
-  mkHsLamPV l _          = addFatalError $ PsError PsErrLambdaInPat [] l
-  mkHsLetPV l _ _ _      = addFatalError $ PsError PsErrLetInPat [] l
-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c
+  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e
+  mkHsLamPV l _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat
+  mkHsLetPV l _ _ _      = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
   type InfixOp (PatBuilder GhcPs) = RdrName
   superInfixOp m = m
   mkHsOpAppPV l p1 op p2 = do
     cs <- getCommentsFor l
     let anns = EpAnn (spanAsAnchor l) [] cs
     return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
-  mkHsCasePV l _ _ _     = addFatalError $ PsError PsErrCaseInPat [] l
-  mkHsLamCasePV l _ _    = addFatalError $ PsError PsErrLambdaCaseInPat [] l
+  mkHsCasePV l _ _ _     = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
+  mkHsLamCasePV l _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat
   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
   superFunArg m = m
   mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)
@@ -1753,8 +1775,8 @@ instance DisambECP (PatBuilder GhcPs) where
     cs <- getCommentsFor (locA l)
     let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs
     return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))
-  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l
-  mkHsDoPV l _ _ _       = addFatalError $ PsError PsErrDoNotationInPat [] l
+  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
+  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
   mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
@@ -1774,7 +1796,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do
     let (fs, ps) = partitionEithers fbinds
     if not (null ps)
-     then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l
+     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
      else do
        cs <- getCommentsFor l
        r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)
@@ -1782,11 +1804,11 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsNegAppPV l (L lp p) anns = do
     lit <- case p of
       PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit)
-      _ -> patFail l (text "-" <> ppr p)
+      _ -> patFail l $ PsErrInPat p PEIP_NegApp
     cs <- getCommentsFor l
     let an = EpAnn (spanAsAnchor l) anns cs
     return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))
-  mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
+  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))
   mkHsViewPatPV l a b anns = do
     p <- checkLPat b
     cs <- getCommentsFor l
@@ -1812,7 +1834,8 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
 checkUnboxedStringLitPat (L loc lit) =
   case lit of
     HsStringPrim _ _  -- Trac #13260
-      -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc
+      -> addFatalError $ mkPlainErrorMsgEnvelope loc $
+                           (PsErrIllegalUnboxedStringInPat lit)
     _ -> return ()
 
 mkPatRec ::
@@ -1829,7 +1852,8 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns
          , pat_args = RecCon (HsRecFields fs dd)
          }
 mkPatRec p _ _ =
-  addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p)
+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
+                    (PsErrInvalidRecordCon (unLoc p))
 
 -- | Disambiguate constructs that may appear when we do not know
 -- ahead of time whether we are parsing a type or a newtype/data constructor.
@@ -1892,7 +1916,8 @@ instance DisambTD DataConBuilder where
     panic "mkHsAppTyPV: InfixDataConBuilder"
 
   mkHsAppKindTyPV lhs l_at ki =
-    addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at
+    addFatalError $ mkPlainErrorMsgEnvelope l_at $
+                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
 
   mkHsOpTyPV lhs tc rhs = do
       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
@@ -1902,7 +1927,8 @@ instance DisambTD DataConBuilder where
       l = combineLocsA lhs rhs
       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
       check_no_ops (HsOpTy{}) =
-        addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l)
+        addError $ mkPlainErrorMsgEnvelope (locA l) $
+                     (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))
       check_no_ops _ = return ()
 
   mkUnpackednessPV unpk constr_stuff
@@ -1913,7 +1939,7 @@ instance DisambTD DataConBuilder where
          let l = combineLocsA (reLocA unpk) constr_stuff
          return $ L l (InfixDataConBuilder lhs' data_con rhs)
     | otherwise =
-      do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk)
+      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon
          return constr_stuff
 
 tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
@@ -1924,7 +1950,8 @@ tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
   let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))
   return $ L l (PrefixDataConBuilder (toOL ts) data_con)
 tyToDataConBuilder t =
-  addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t)
+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $
+                    (PsErrInvalidDataCon (unLoc t))
 
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2373,7 +2400,7 @@ checkPrecP
 checkPrecP (L l (_,i)) (L _ ol)
  | 0 <= i, i <= maxPrecedence = pure ()
  | all specialOp ol = pure ()
- | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l
+ | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)
   where
     -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
     specialOp op = unLoc op `elem` [ eqTyCon_RDR
@@ -2391,10 +2418,12 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
   = do
       let (fs, ps) = partitionEithers fbinds
       if not (null ps)
-        then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps))
+        then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $
+                               PsErrOverloadedRecordDotInvalid
         else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
 mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
-  | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc
+  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $
+                                          PsErrDotsInRecordUpdate
   | otherwise = mkRdrRecordUpd overloaded_update exp fs anns
 
 mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)
@@ -2408,7 +2437,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
   case overloaded_on of
     False | not $ null ps ->
       -- A '.' was found in an update and OverloadedRecordUpdate isn't on.
-      addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc)
+      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled
     False ->
       -- This is just a regular record update.
       return RecordUpd {
@@ -2422,7 +2451,8 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
             ]
       if not $ null qualifiedFields
         then
-          addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields))
+          addFatalError $ mkPlainErrorMsgEnvelope (getLoc (head qualifiedFields)) $
+            PsErrOverloadedRecordUpdateNoQualifiedFields
         else -- This is a RecordDotSyntax update.
           return RecordUpd {
             rupd_ext = anns
@@ -2505,7 +2535,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
     mkCImport = do
       let e = unpackFS entity
       case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
-        Nothing         -> addFatalError $ PsError PsErrMalformedEntityString [] loc
+        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $
+                             PsErrMalformedEntityString
         Just importSpec -> returnSpec importSpec
 
     -- currently, all the other import conventions only support a symbol name in
@@ -2646,12 +2677,14 @@ mkModuleImpExp anns (L l specname) subs = do
             in (\newName
                         -> IEThingWith ann (L l newName) pos ies)
                <$> nameT
-          else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l)
+          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
+                 PsErrIllegalPatSynExport
   where
     name = ieNameVal specname
     nameT =
       if isVarNameSpace (rdrNameSpace name)
-        then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l)
+        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
+               (PsErrVarForTyCon name)
         else return $ ieNameFromSpec specname
 
     ieNameVal (ImpExpQcName ln)   = unLoc ln
@@ -2668,7 +2701,8 @@ mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space
              -> P (LocatedN RdrName)
 mkTypeImpExp name =
   do allowed <- getBit ExplicitNamespacesBit
-     unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name)
+     unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $
+                                   PsErrIllegalExplicitNamespace
      return (fmap (`setRdrNameSpace` tcClsName) name)
 
 checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])
@@ -2678,7 +2712,7 @@ checkImportSpec ie@(L _ specs) =
       (l:_) -> importSpecError (locA l)
   where
     importSpecError l =
-      addFatalError $ PsError PsErrIllegalImportBundleForm [] l
+      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm
 
 -- In the correct order
 mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
@@ -2699,21 +2733,24 @@ isImpExpQcWildcard _                = False
 
 warnPrepositiveQualifiedModule :: SrcSpan -> P ()
 warnPrepositiveQualifiedModule span =
-  addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span)
+  addPsMessage span PsWarnImportPreQualified
 
 failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
-failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc
+failOpNotEnabledImportQualifiedPost loc =
+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified
 
 failOpImportQualifiedTwice :: SrcSpan -> P ()
-failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc
+failOpImportQualifiedTwice loc =
+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice
 
 warnStarIsType :: SrcSpan -> P ()
-warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span)
+warnStarIsType span = addPsMessage span PsWarnStarIsType
 
 failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
 failOpFewArgs (L loc op) =
   do { star_is_type <- getBit StarIsTypeBit
-     ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) }
+     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+         (PsErrOpFewArgs (StarIsType star_is_type) op) }
 
 -----------------------------------------------------------------------------
 -- Misc utils
@@ -2721,13 +2758,13 @@ failOpFewArgs (L loc op) =
 data PV_Context =
   PV_Context
     { pv_options :: ParserOpts
-    , pv_hints   :: [GhcHint]  -- See Note [Parser-Validator Hint]
+    , pv_details :: ParseContext -- See Note [Parser-Validator Details]
     }
 
 data PV_Accum =
   PV_Accum
-    { pv_warnings        :: Bag PsWarning
-    , pv_errors          :: Bag PsError
+    { pv_warnings        :: Messages PsMessage
+    , pv_errors          :: Messages PsMessage
     , pv_header_comments :: Strict.Maybe [LEpaComment]
     , pv_comment_q       :: [LEpaComment]
     }
@@ -2769,15 +2806,18 @@ instance Monad PV where
       PV_Failed acc' -> PV_Failed acc'
 
 runPV :: PV a -> P a
-runPV = runPV_hints []
+runPV = runPV_details noParseContext
 
-runPV_hints :: [GhcHint] -> PV a -> P a
-runPV_hints hints m =
+askParseContext :: PV ParseContext
+askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details
+
+runPV_details :: ParseContext -> PV a -> P a
+runPV_details details m =
   P $ \s ->
     let
       pv_ctx = PV_Context
         { pv_options = options s
-        , pv_hints   = hints }
+        , pv_details = details }
       pv_acc = PV_Accum
         { pv_warnings = warnings s
         , pv_errors   = errors s
@@ -2792,22 +2832,14 @@ runPV_hints hints m =
         PV_Ok acc' a -> POk (mkPState acc') a
         PV_Failed acc' -> PFailed (mkPState acc')
 
-add_hint :: GhcHint -> PV a -> PV a
-add_hint hint m =
-  let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in
-  PV (\ctx acc -> unPV m (modifyHint ctx) acc)
-
 instance MonadP PV where
-  addError err@(PsError e hints loc) =
-    PV $ \ctx acc ->
-      let err' | null (pv_hints ctx) = err
-               | otherwise           = PsError e (hints ++ pv_hints ctx) loc
-      in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()
-  addWarning option w =
-    PV $ \ctx acc ->
-      if warnopt option (pv_options ctx)
-         then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} ()
-         else PV_Ok acc ()
+  addError err =
+    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()
+  addWarning w =
+    PV $ \_ctx acc ->
+      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed
+      -- diagnostics.
+      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()
   addFatalError err =
     addError err >> PV (const PV_Failed)
   getBit ext =
@@ -2834,9 +2866,9 @@ instance MonadP PV where
          pv_comment_q = comment_q'
        } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
 
-{- Note [Parser-Validator Hint]
+{- Note [Parser-Validator Details]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A PV computation is parametrized by a hint for error messages, which can be set
+A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set
 depending on validation context. We use this in checkPattern to fix #984.
 
 Consider this example, where the user has forgotten a 'do':
@@ -2863,16 +2895,17 @@ Note that this fragment is parsed as a pattern:
     _ ->
       result
 
-We attempt to detect such cases and add a hint to the error messages:
+We attempt to detect such cases and add a hint to the diagnostic messages:
 
   T984.hs:6:9:
     Parse error in pattern: case () of { _ -> result }
     Possibly caused by a missing 'do'?
 
-The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
-as the 'pv_hints' field 'PV_Context'. When validating in a context other than
-'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has
-no effect on the error messages.
+The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed
+out of the 'ParseContext', which are read by functions like 'patFail' when
+constructing the 'PsParseErrorInPatDetails' data structure. When validating in a
+context other than 'bindpat' (a pattern to the left of <-), we set the
+details to 'noParseContext' and it has no effect on the diagnostic messages.
 
 -}
 
@@ -2881,7 +2914,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
 hintBangPat span e = do
     bang_on <- getBit BangPatBit
     unless bang_on $
-      addError $ PsError (PsErrIllegalBangPattern e) [] span
+      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e
 
 mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)
                  -> [AddEpAnn]
@@ -2907,7 +2940,7 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do
     cs <- getCommentsFor (locA l)
     return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e)
 mkSumOrTupleExpr l Boxed a@Sum{} _ =
-    addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l)
+    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
 
 mkSumOrTuplePat
   :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]
@@ -2923,7 +2956,8 @@ mkSumOrTuplePat l boxity (Tuple ps) anns = do
     -- Ignore the element location so that the error message refers to the
     -- entire tuple. See #19504 (and the discussion) for details.
     toTupPat p = case p of
-      Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l)
+      Left _ -> addFatalError $
+                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat
       Right p' -> checkLPat p'
 
 -- Sum
@@ -2933,7 +2967,8 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do
    let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs
    return $ L l (PatBuilderPat (SumPat an p' alt arity))
 mkSumOrTuplePat l Boxed a@Sum{} _ =
-    addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l)
+    addFatalError $
+      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
 
 mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy x op y =