Use ADTs for parser errors/warnings

Haskell and Cmm parsers/lexers now report errors and warnings using ADTs
defined in GHC.Parser.Errors. They can be printed using functions in
GHC.Parser.Errors.Ppr.

Some of the errors provide hints with a separate ADT (e.g. to suggest to
turn on some extension). For now, however, hints are not consistent
across all messages. For example some errors contain the hints in the
main message. I didn't want to change any message with this patch. I
expect these changes to be discussed and implemented later.

Surprisingly, this patch enhances performance. On CI
(x86_64/deb9/hadrian, ghc/alloc):

   parsing001         -11.5%
   T13719             -2.7%
   MultiLayerModules  -3.5%
   Naperian           -3.1%

Bump haddock submodule

Metric Decrease:
    MultiLayerModules
    Naperian
    T13719
    parsing001

27 files changed, 1453 insertions, 652 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 979e42ccc9..be4d29181e 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -357,6 +357,7 @@ import GHC.Data.FastString
 import qualified GHC.Parser as Parser
 import GHC.Parser.Lexer
 import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Types.Name.Env
 import GHC.Tc.Module
@@ -1430,10 +1431,8 @@ getTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
-    POk _ ts  -> return ts
-    PFailed pst ->
-        do dflags <- getDynFlags
-           throwErrors (getErrorMessages pst dflags)
+    POk _ ts    -> return ts
+    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1443,10 +1442,8 @@ getRichTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
-    POk _ ts -> return $ addSourceToTokens startLoc source ts
-    PFailed pst ->
-        do dflags <- getDynFlags
-           throwErrors (getErrorMessages pst dflags)
+    POk _ ts    -> return $ addSourceToTokens startLoc source ts
+    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1620,12 +1617,12 @@ parser str dflags filename =
    case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
 
      PFailed pst ->
-         let (warns,errs) = getMessages pst dflags in
-         (warns, Left errs)
+         let (warns,errs) = getMessages pst in
+         (fmap pprWarning warns, Left (fmap pprError errs))
 
      POk pst rdr_module ->
-         let (warns,_) = getMessages pst dflags in
-         (warns, Right rdr_module)
+         let (warns,_) = getMessages pst in
+         (fmap pprWarning warns, Right rdr_module)
 
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index e211434e60..b254bc233d 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -78,6 +78,7 @@ module GHC.Builtin.Types (
         unboxedUnitTy,
         unboxedUnitTyCon, unboxedUnitDataCon,
         unboxedTupleKind, unboxedSumKind,
+        filterCTuple,
 
         -- ** Constraint tuples
         cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
@@ -2029,3 +2030,11 @@ naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon
 
 naturalNBDataCon :: DataCon
 naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon
+
+
+-- | Replaces constraint tuple names with corresponding boxed ones.
+filterCTuple :: RdrName -> RdrName
+filterCTuple (Exact n)
+  | Just arity <- cTupleTyConNameArity_maybe n
+  = Exact $ tupleTyConName BoxedTuple arity
+filterCTuple rdr = rdr
diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index 010001cd2a..956107e61e 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -26,6 +26,7 @@ import GHC.Types.Unique.FM
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
 import GHC.Parser.CharClass
+import GHC.Parser.Errors
 import GHC.Utils.Misc
 --import TRACE
 
@@ -325,7 +326,7 @@ lexToken = do
     AlexEOF -> do let span = mkPsSpan loc1 loc1
                   liftP (setLastToken span 0)
                   return (L span CmmT_EOF)
-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error"
+    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (Error ErrCmmLexer [])
     AlexSkip inp2 _ -> do
         setInput inp2
         lexToken
diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs
index edb4c5f9d6..7cee74cd34 100644
--- a/compiler/GHC/Cmm/Monad.hs
+++ b/compiler/GHC/Cmm/Monad.hs
@@ -26,6 +26,8 @@ import Control.Monad
 
 import GHC.Driver.Session
 import GHC.Parser.Lexer
+import GHC.Parser.Errors
+import GHC.Types.SrcLoc
 
 newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
 
@@ -42,7 +44,7 @@ instance Monad PD where
 liftP :: P a -> PD a
 liftP (P f) = PD $ \_ s -> f s
 
-failMsgPD :: String -> PD a
+failMsgPD :: (SrcSpan -> Error) -> PD a
 failMsgPD = liftP . failMsgP
 
 returnPD :: a -> PD a
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index e1e89e9977..6bbbdc819b 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -239,6 +239,7 @@ import qualified GHC.Cmm.Monad as PD
 import GHC.Cmm.CallConv
 import GHC.Runtime.Heap.Layout
 import GHC.Parser.Lexer
+import GHC.Parser.Errors
 
 import GHC.Types.CostCentre
 import GHC.Types.ForeignCall
@@ -257,7 +258,7 @@ import GHC.Utils.Panic
 import GHC.Settings.Constants
 import GHC.Utils.Outputable
 import GHC.Types.Basic
-import GHC.Data.Bag     ( emptyBag, unitBag )
+import GHC.Data.Bag     ( Bag, emptyBag, unitBag, isEmptyBag )
 import GHC.Types.Var
 
 import Control.Monad
@@ -899,7 +900,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure
 nameToMachOp :: FastString -> PD (Width -> MachOp)
 nameToMachOp name =
   case lookupUFM machOps name of
-        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
+        Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []
         Just m  -> return m
 
 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
@@ -1061,12 +1062,12 @@ parseSafety :: String -> PD Safety
 parseSafety "safe"   = return PlaySafe
 parseSafety "unsafe" = return PlayRisky
 parseSafety "interruptible" = return PlayInterruptible
-parseSafety str      = failMsgPD ("unrecognised safety: " ++ str)
+parseSafety str      = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedSafety str)) []
 
 parseCmmHint :: String -> PD ForeignHint
 parseCmmHint "ptr"    = return AddrHint
 parseCmmHint "signed" = return SignedHint
-parseCmmHint str      = failMsgPD ("unrecognised hint: " ++ str)
+parseCmmHint str      = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedHint str)) []
 
 -- labels are always pointers, so we might as well infer the hint
 inferCmmHint :: CmmExpr -> ForeignHint
@@ -1093,7 +1094,7 @@ happyError = PD $ \_ s -> unP srcParseFail s
 stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
-    Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)
+    Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownMacro fun)) []
     Just fcode -> return $ do
         args <- sequence args_code
         code (fcode args)
@@ -1194,9 +1195,9 @@ foreignCall
         -> PD (CmmParse ())
 foreignCall conv_string results_code expr_code args_code safety ret
   = do  conv <- case conv_string of
-          "C" -> return CCallConv
+          "C"       -> return CCallConv
           "stdcall" -> return StdCallConv
-          _ -> failMsgPD ("unknown calling convention: " ++ conv_string)
+          _         -> failMsgPD $ Error (ErrCmmParser (CmmUnknownCConv conv_string)) []
         return $ do
           platform <- getPlatform
           results <- sequence results_code
@@ -1274,7 +1275,7 @@ primCall results_code name args_code
   = do
     platform <- PD.getPlatform
     case lookupUFM (callishMachOps platform) name of
-        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
+        Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []
         Just f  -> return $ do
                 results <- sequence results_code
                 args <- sequence args_code
@@ -1428,8 +1429,8 @@ initEnv profile = listToUFM [
   ]
   where platform = profilePlatform profile
 
-parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
-parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)
+parseCmmFile dflags filename = do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -1438,16 +1439,17 @@ parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (te
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
   case unPD cmmParse dflags init_state of
-    PFailed pst ->
-        return (getMessages pst dflags, Nothing)
+    PFailed pst -> do
+        let (warnings,errors) = getMessages pst
+        return (warnings, errors, Nothing)
     POk pst code -> do
         st <- initC
         let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
             (cmm,_) = runC dflags no_module st fcode
-        let ms = getMessages pst dflags
-        if (errorsFound dflags ms)
-         then return (ms, Nothing)
-         else return (ms, Just cmm)
+            (warnings,errors) = getMessages pst
+        if not (isEmptyBag errors)
+         then return (warnings, errors, Nothing)
+         else return (warnings, errors, Just cmm)
   where
         no_module = panic "parseCmmFile: no module"
 }
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 494cffb785..242ecd9aa4 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -24,6 +24,7 @@ import GHC.Prelude
 import GHC.Driver.Backpack.Syntax
 
 import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
 import GHC hiding (Failed, Succeeded)
 import GHC.Parser
 import GHC.Parser.Lexer
@@ -85,7 +86,7 @@ doBackpack [src_filename] = do
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
     case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
-        PFailed pst -> throwErrors (getErrorMessages pst dflags)
+        PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an
             -- LHsUnit HsComponentId.  So let's rename it.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 593251a253..a2fa2e2aea 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -101,6 +101,8 @@ import GHC.Utils.Panic
 import GHC.Core.ConLike
 
 import GHC.Parser.Annotation
+import GHC.Parser.Errors
+import GHC.Parser.Errors.Ppr
 import GHC.Unit
 import GHC.Unit.State
 import GHC.Types.Name.Reader
@@ -177,7 +179,7 @@ import qualified Data.Set as S
 import Data.Set (Set)
 import Data.Functor
 import Control.DeepSeq (force)
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
 
 import GHC.Iface.Ext.Ast    ( mkHieFile )
 import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
@@ -237,15 +239,19 @@ handleWarnings = do
 
 -- | log warning in the monad, and if there are errors then
 -- throw a SourceError exception.
-logWarningsReportErrors :: Messages -> Hsc ()
-logWarningsReportErrors (warns,errs) = do
+logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc ()
+logWarningsReportErrors (warnings,errors) = do
+    let warns = fmap pprWarning warnings
+        errs  = fmap pprError   errors
     logWarnings warns
     when (not $ isEmptyBag errs) $ throwErrors errs
 
 -- | Log warnings and throw errors, assuming the messages
 -- contain at least one error (e.g. coming from PFailed)
-handleWarningsThrowErrors :: Messages -> Hsc a
-handleWarningsThrowErrors (warns, errs) = do
+handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a
+handleWarningsThrowErrors (warnings, errors) = do
+    let warns = fmap pprWarning warnings
+        errs  = fmap pprError   errors
     logWarnings warns
     dflags <- getDynFlags
     (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
@@ -356,9 +362,9 @@ hscParse' mod_summary
 
     case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
         PFailed pst ->
-            handleWarningsThrowErrors (getMessages pst dflags)
+            handleWarningsThrowErrors (getMessages pst)
         POk pst rdr_module -> do
-            let (warns, errs) = getMessages pst dflags
+            let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
             logWarnings warns
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr rdr_module)
@@ -1496,7 +1502,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags   = hsc_dflags hsc_env
         home_unit = mkHomeUnitFromFlags dflags
         platform  = targetPlatform dflags
-    cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+    cmm <- ioMsgMaybe
+               $ do
+                  (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
+                                       $ parseCmmFile dflags filename
+                  return ((fmap pprWarning warns, fmap pprError errs), cmm)
     liftIO $ do
         dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
         let -- Make up a module name to give the NCG. We can't pass bottom here
@@ -1878,10 +1888,10 @@ hscParseThingWithLocation source linenumber parser str
 
     case unP parser (initParserState (initParserOpts dflags) buf loc) of
         PFailed pst -> do
-            handleWarningsThrowErrors (getMessages pst dflags)
+            handleWarningsThrowErrors (getMessages pst)
 
         POk pst thing -> do
-            logWarningsReportErrors (getMessages pst dflags)
+            logWarningsReportErrors (getMessages pst)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr thing)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index de1746c815..a40efb74aa 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -45,6 +45,7 @@ import GHC.Utils.Error
 import GHC.Driver.Finder
 import GHC.Driver.Monad
 import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
 import GHC.Driver.Types
 import GHC.Unit
 import GHC.Unit.State
@@ -94,6 +95,7 @@ import Data.Foldable (toList)
 import Data.Maybe
 import Data.Ord ( comparing )
 import Data.Time
+import Data.Bifunctor (first)
 import System.Directory
 import System.FilePath
 import System.IO        ( fixIO )
@@ -2669,7 +2671,9 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
       <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
   pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
   (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
-      <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+      <- ExceptT $ do
+          mimps <- getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+          return (first (fmap pprError) mimps)
   return PreprocessedImports {..}
 
 
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 66487c497d..0dd3d0f8fa 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -45,6 +45,7 @@ import GHC.Unit.State
 import GHC.Platform.Ways
 import GHC.Platform.ArchOS
 import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
 import GHC.Driver.Phases
 import GHC.SysTools
 import GHC.SysTools.ExtraObj
@@ -1117,7 +1118,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
             buf <- hGetStringBuffer input_fn
             eimps <- getImports dflags buf input_fn (basename <.> suff)
             case eimps of
-              Left errs -> throwErrors errs
+              Left errs -> throwErrors (fmap pprError errs)
               Right (src_imps,imps,L _ mod_name) -> return
                   (Just buf, mod_name, imps, src_imps)
 
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 2984d33631..e61441cdb4 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -85,6 +85,7 @@ import GHC.Parser.PostProcess
 import GHC.Parser.PostProcess.Haddock
 import GHC.Parser.Lexer
 import GHC.Parser.Annotation
+import GHC.Parser.Errors
 
 import GHC.Tc.Types.Evidence  ( emptyTcEvBinds )
 
@@ -797,7 +798,7 @@ HYPHEN :: { [AddAnn] }
       | PREFIX_MINUS { [mj AnnMinus $1 ] }
       | VARSYM  {% if (getVARSYM $1 == fsLit "-")
                    then return [mj AnnMinus $1]
-                   else do { addError (getLoc $1) $ text "Expected a hyphen"
+                   else do { addError $ Error ErrExpectedHyphen [] (getLoc $1)
                            ; return [] } }
 
 
@@ -1094,10 +1095,7 @@ maybe_safe :: { ([AddAnn],Bool) }
 maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
         : STRING  {% do { let { pkgFS = getSTRING $1 }
                         ; unless (looksLikePackageName (unpackFS pkgFS)) $
-                             addError (getLoc $1) $ vcat [
-                             text "Parse error" <> colon <+> quotes (ppr pkgFS),
-                             text "Version number or non-alphanumeric" <+>
-                             text "character in package name"]
+                             addError $ Error (ErrInvalidPackageName pkgFS) [] (getLoc $1)
                         ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
         | {- empty -}                           { ([],Nothing) }
 
@@ -1798,7 +1796,7 @@ rule_activation_marker :: { [AddAnn] }
       : PREFIX_TILDE { [mj AnnTilde $1] }
       | VARSYM  {% if (getVARSYM $1 == fsLit "~")
                    then return [mj AnnTilde $1]
-                   else do { addError (getLoc $1) $ text "Invalid rule activation marker"
+                   else do { addError $ Error ErrInvalidRuleActivationMarker [] (getLoc $1)
                            ; return [] } }
 
 rule_explicit_activation :: { ([AddAnn]
@@ -3216,7 +3214,7 @@ pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }
 
 bindpat :: { LPat GhcPs }
 bindpat :  exp            {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess
-                             checkPattern_msg (text "Possibly caused by a missing 'do'?")
+                             checkPattern_hints [SuggestMissingDo]
                                               (unECP $1) }
 
 apat   :: { LPat GhcPs }
@@ -3840,10 +3838,9 @@ hasE _                             = False
 
 getSCC :: Located Token -> P FastString
 getSCC lt = do let s = getSTRING lt
-                   err = "Spaces are not allowed in SCCs"
                -- We probably actually want to be more restrictive than this
                if ' ' `elem` unpackFS s
-                   then addFatalError (getLoc lt) (text err)
+                   then addFatalError $ Error ErrSpaceInSCC [] (getLoc lt)
                    else return s
 
 -- Utilities for combining source spans
@@ -3928,8 +3925,7 @@ fileSrcSpan = do
 hintLinear :: MonadP m => SrcSpan -> m ()
 hintLinear span = do
   linearEnabled <- getBit LinearTypesBit
-  unless linearEnabled $ addError span $
-    text "Enable LinearTypes to allow linear functions"
+  unless linearEnabled $ addError $ Error ErrLinearFunction [] span
 
 -- Does this look like (a %m)?
 looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool
@@ -3948,22 +3944,14 @@ looksLikeMult ty1 l_op ty2
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
   mwiEnabled <- getBit MultiWayIfBit
-  unless mwiEnabled $ addError span $
-    text "Multi-way if-expressions need MultiWayIf turned on"
+  unless mwiEnabled $ addError $ Error ErrMultiWayIf [] span
 
 -- Hint about explicit-forall
 hintExplicitForall :: Located Token -> P ()
 hintExplicitForall tok = do
     forall   <- getBit ExplicitForallBit
     rulePrag <- getBit InRulePragBit
-    unless (forall || rulePrag) $ addError (getLoc tok) $ vcat
-      [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"
-      , text "Perhaps you intended to use RankNTypes or a similar language"
-      , text "extension to enable explicit-forall syntax:" <+>
-        forallSymDoc <+> text "<tvs>. <type>"
-      ]
-  where
-    forallSymDoc = text (forallSym (isUnicode tok))
+    unless (forall || rulePrag) $ addError $ Error (ErrExplicitForall (isUnicode tok)) [] (getLoc tok)
 
 -- Hint about qualified-do
 hintQualifiedDo :: Located Token -> P ()
@@ -3971,10 +3959,7 @@ hintQualifiedDo tok = do
     qualifiedDo   <- getBit QualifiedDoBit
     case maybeQDoDoc of
       Just qdoDoc | not qualifiedDo ->
-        addError (getLoc tok) $ vcat
-          [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
-          , text "Perhaps you intended to use QualifiedDo"
-          ]
+        addError $ Error (ErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)
       _ -> return ()
   where
     maybeQDoDoc = case unLoc tok of
@@ -3988,17 +3973,7 @@ hintQualifiedDo tok = do
 reportEmptyDoubleQuotes :: SrcSpan -> P a
 reportEmptyDoubleQuotes span = do
     thQuotes <- getBit ThQuotesBit
-    if thQuotes
-      then addFatalError span $ vcat
-        [ text "Parser error on `''`"
-        , text "Character literals may not be empty"
-        , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
-        , text "but the type variable or constructor is missing"
-        ]
-      else addFatalError span $ vcat
-        [ text "Parser error on `''`"
-        , text "Character literals may not be empty"
-        ]
+    addFatalError $ Error (ErrEmptyDoubleQuotes thQuotes) [] span
 
 {-
 %************************************************************************
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f6fbe47fe6..6560d5e735 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -197,10 +197,9 @@ getAndRemoveAnnotationComments anns span =
 -- various syntactic keywords that are not captured in the existing
 -- AST.
 --
--- The annotations, together with original source comments are made
--- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.
--- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in
--- @'GHC.Driver.Session.DynFlags'@ before parsing.
+-- The annotations, together with original source comments are made available in
+-- the @'pm_annotations'@ field of @'GHC.Driver.Types.HsParsedModule'@.
+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set.
 --
 -- The wiki page describing this feature is
 -- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations
diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs
new file mode 100644
index 0000000000..b67bf32baf
--- /dev/null
+++ b/compiler/GHC/Parser/Errors.hs
@@ -0,0 +1,404 @@
+module GHC.Parser.Errors
+   ( Warning(..)
+   , TransLayoutReason(..)
+   , NumUnderscoreReason(..)
+   , Error(..)
+   , ErrorDesc(..)
+   , LexErr(..)
+   , CmmParserError(..)
+   , LexErrKind(..)
+   , Hint(..)
+   , StarIsType (..)
+   )
+where
+
+import GHC.Prelude
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader (RdrName)
+import GHC.Types.Name.Occurrence (OccName)
+import GHC.Parser.Types
+import GHC.Hs.Extension
+import GHC.Hs.Expr
+import GHC.Hs.Pat
+import GHC.Hs.Type
+import GHC.Hs.Lit
+import GHC.Hs.Decls
+import GHC.Core.Coercion.Axiom (Role)
+import GHC.Utils.Outputable (SDoc)
+import GHC.Data.FastString
+import GHC.Unit.Module.Name
+
+data Warning
+
+     -- | Warn when tabulations are found
+   = WarnTab
+      { tabFirst :: !SrcSpan -- ^ First occurence of a tab
+      , tabCount :: !Word    -- ^ Number of other occurences
+      }
+
+   | WarnTransitionalLayout !SrcSpan !TransLayoutReason
+      -- ^ Transitional layout warnings
+
+   | WarnUnrecognisedPragma !SrcSpan
+      -- ^ Unrecognised pragma
+
+   | WarnHaddockInvalidPos !SrcSpan
+      -- ^ Invalid Haddock comment position
+
+   | WarnHaddockIgnoreMulti !SrcSpan
+      -- ^ Multiple Haddock comment for the same entity
+
+   | WarnStarBinder !SrcSpan
+      -- ^ Found binding occurence of "*" while StarIsType is enabled
+
+   | WarnStarIsType !SrcSpan
+      -- ^ Using "*" for "Type" without StarIsType enabled
+
+   | WarnImportPreQualified !SrcSpan
+      -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled
+
+
+data TransLayoutReason
+   = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"
+   | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")
+
+data Error = Error
+   { errDesc  :: !ErrorDesc   -- ^ Error description
+   , errHints :: ![Hint]      -- ^ Hints
+   , errLoc   :: !SrcSpan     -- ^ Error position
+   }
+
+data ErrorDesc
+   = ErrLambdaCase
+      -- ^ LambdaCase syntax used without the extension enabled
+
+   | ErrNumUnderscores !NumUnderscoreReason
+      -- ^ Underscores in literals without the extension enabled
+
+   | ErrPrimStringInvalidChar
+      -- ^ Invalid character in primitive string
+
+   | ErrMissingBlock
+      -- ^ Missing block
+
+   | ErrLexer !LexErr !LexErrKind
+      -- ^ Lexer error
+
+   | ErrSuffixAT
+      -- ^ Suffix occurence of `@`
+
+   | ErrParse !String
+      -- ^ Parse errors
+
+   | ErrCmmLexer
+      -- ^ Cmm lexer error
+
+   | ErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))
+      -- ^ Unsupported boxed sum in expression
+
+   | ErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))
+      -- ^ Unsupported boxed sum in pattern
+
+   | ErrUnexpectedQualifiedConstructor !RdrName
+      -- ^ Unexpected qualified constructor
+
+   | ErrTupleSectionInPat
+      -- ^ Tuple section in pattern context
+
+   | ErrIllegalBangPattern !(Pat GhcPs)
+      -- ^ Bang-pattern without BangPattterns enabled
+
+   | ErrOpFewArgs !StarIsType !RdrName
+      -- ^ Operator applied to too few arguments
+
+   | ErrImportQualifiedTwice
+      -- ^ Import: multiple occurrences of 'qualified'
+
+   | ErrImportPostQualified
+      -- ^ Post qualified import without 'ImportQualifiedPost'
+
+   | ErrIllegalExplicitNamespace
+      -- ^ Explicit namespace keyword without 'ExplicitNamespaces'
+
+   | ErrVarForTyCon !RdrName
+      -- ^ Expecting a type constructor but found a variable
+
+   | ErrIllegalPatSynExport
+      -- ^ Illegal export form allowed by PatternSynonyms
+
+   | ErrMalformedEntityString
+      -- ^ Malformed entity string
+
+   | ErrDotsInRecordUpdate
+      -- ^ Dots used in record update
+
+   | ErrPrecedenceOutOfRange !Int
+      -- ^ Precedence out of range
+
+   | ErrInvalidDataCon !(HsType GhcPs)
+      -- ^ Cannot parse data constructor in a data/newtype declaration
+
+   | ErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)
+      -- ^ Cannot parse data constructor in a data/newtype declaration
+
+   | ErrUnpackDataCon
+      -- ^ UNPACK applied to a data constructor
+
+   | ErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)
+      -- ^ Unexpected kind application in data/newtype declaration
+
+   | ErrInvalidRecordCon !(PatBuilder GhcPs)
+      -- ^ Not a record constructor
+
+   | ErrIllegalUnboxedStringInPat !(HsLit GhcPs)
+      -- ^ Illegal unboxed string literal in pattern
+
+   | ErrDoNotationInPat
+      -- ^ Do-notation in pattern
+
+   | ErrIfTheElseInPat
+      -- ^ If-then-else syntax in pattern
+
+   | ErrTypeAppInPat
+      -- ^ Type-application in pattern
+
+   | ErrLambdaCaseInPat
+      -- ^ Lambda-case in pattern
+
+   | ErrCaseInPat
+      -- ^ case..of in pattern
+
+   | ErrLetInPat
+      -- ^ let-syntax in pattern
+
+   | ErrLambdaInPat
+      -- ^ Lambda-syntax in pattern
+
+   | ErrArrowExprInPat !(HsExpr GhcPs)
+      -- ^ Arrow expression-syntax in pattern
+
+   | ErrArrowCmdInPat !(HsCmd GhcPs)
+      -- ^ Arrow command-syntax in pattern
+
+   | ErrArrowCmdInExpr !(HsCmd GhcPs)
+      -- ^ Arrow command-syntax in expression
+
+   | ErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)
+      -- ^ View-pattern in expression
+
+   | ErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)
+      -- ^ Type-application without space before '@'
+
+   | ErrLazyPatWithoutSpace !(LHsExpr GhcPs)
+      -- ^ Lazy-pattern ('~') without space after it
+
+   | ErrBangPatWithoutSpace !(LHsExpr GhcPs)
+      -- ^ Bang-pattern ('!') without space after it
+
+   | ErrUnallowedPragma !(HsPragE GhcPs)
+      -- ^ Pragma not allowed in this position
+
+   | ErrQualifiedDoInCmd !ModuleName
+      -- ^ Qualified do block in command
+
+   | ErrInvalidInfixHole
+      -- ^ Invalid infix hole, expected an infix operator
+
+   | ErrSemiColonsInCondExpr
+      -- ^ Unexpected semi-colons in conditional expression
+         !(HsExpr GhcPs) -- ^ conditional expr
+         !Bool           -- ^ "then" semi-colon?
+         !(HsExpr GhcPs) -- ^ "then" expr
+         !Bool           -- ^ "else" semi-colon?
+         !(HsExpr GhcPs) -- ^ "else" expr
+
+   | ErrSemiColonsInCondCmd
+      -- ^ Unexpected semi-colons in conditional command
+         !(HsExpr GhcPs) -- ^ conditional expr
+         !Bool           -- ^ "then" semi-colon?
+         !(HsCmd GhcPs)  -- ^ "then" expr
+         !Bool           -- ^ "else" semi-colon?
+         !(HsCmd GhcPs)  -- ^ "else" expr
+
+   | ErrAtInPatPos
+      -- ^ @-operator in a pattern position
+
+   | ErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)
+      -- ^ Unexpected lambda command in function application
+
+   | ErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)
+      -- ^ Unexpected case command in function application
+
+   | ErrIfCmdInFunAppCmd !(LHsCmd GhcPs)
+      -- ^ Unexpected if command in function application
+
+   | ErrLetCmdInFunAppCmd !(LHsCmd GhcPs)
+      -- ^ Unexpected let command in function application
+
+   | ErrDoCmdInFunAppCmd !(LHsCmd GhcPs)
+      -- ^ Unexpected do command in function application
+
+   | ErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)
+      -- ^ Unexpected do block in function application
+
+   | ErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)
+      -- ^ Unexpected mdo block in function application
+
+   | ErrLambdaInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected lambda expression in function application
+
+   | ErrCaseInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected case expression in function application
+
+   | ErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected lambda-case expression in function application
+
+   | ErrLetInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected let expression in function application
+
+   | ErrIfInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected if expression in function application
+
+   | ErrProcInFunAppExpr !(LHsExpr GhcPs)
+      -- ^ Unexpected proc expression in function application
+
+   | ErrMalformedTyOrClDecl !(LHsType GhcPs)
+      -- ^ Malformed head of type or class declaration
+
+   | ErrIllegalWhereInDataDecl
+      -- ^ Illegal 'where' keyword in data declaration
+
+   | ErrIllegalDataTypeContext !(LHsContext GhcPs)
+      -- ^ Illegal datatyp context
+
+   | ErrParseErrorOnInput !OccName
+      -- ^ Parse error on input
+
+   | ErrMalformedDecl !SDoc !RdrName
+      -- ^ Malformed ... declaration for ...
+
+   | ErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName
+      -- ^ Unexpected type application in a declaration
+
+   | ErrNotADataCon !RdrName
+      -- ^ Not a data constructor
+
+   | ErrRecordSyntaxInPatSynDecl !(LPat GhcPs)
+      -- ^ Record syntax used in pattern synonym declaration
+
+   | ErrEmptyWhereInPatSynDecl !RdrName
+      -- ^ Empty 'where' clause in pattern-synonym declaration
+
+   | ErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)
+      -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration
+
+   | ErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)
+      -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration
+
+   | ErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)
+      -- ^ Declaration splice not a top-level
+
+   | ErrInferredTypeVarNotAllowed
+      -- ^ Inferred type variables not allowed here
+
+   | ErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]
+      -- ^ Multiple names in standalone kind signatures
+
+   | ErrIllegalImportBundleForm
+      -- ^ Illegal import bundle form
+
+   | ErrIllegalRoleName !FastString [Role]
+      -- ^ Illegal role name
+
+   | ErrInvalidTypeSignature !(LHsExpr GhcPs)
+      -- ^ Invalid type signature
+
+   | ErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc
+      -- ^ Unexpected type in declaration
+
+   | ErrExpectedHyphen
+      -- ^ Expected a hyphen
+
+   | ErrSpaceInSCC
+      -- ^ Found a space in a SCC
+
+   | ErrEmptyDoubleQuotes !Bool-- Is TH on?
+      -- ^ Found two single quotes
+
+   | ErrInvalidPackageName !FastString
+      -- ^ Invalid package name
+
+   | ErrInvalidRuleActivationMarker
+      -- ^ Invalid rule activation marker
+
+   | ErrLinearFunction
+      -- ^ Linear function found but LinearTypes not enabled
+
+   | ErrMultiWayIf
+      -- ^ Multi-way if-expression found but MultiWayIf not enabled
+
+   | ErrExplicitForall !Bool -- is Unicode forall?
+      -- ^ Explicit forall found but no extension allowing it is enabled
+
+   | ErrIllegalQualifiedDo !SDoc
+      -- ^ Found qualified-do without QualifiedDo enabled
+
+   | ErrCmmParser !CmmParserError
+      -- ^ Cmm parser error
+
+   | ErrIllegalTraditionalRecordSyntax !SDoc
+      -- ^ Illegal traditional record syntax
+      --
+      -- TODO: distinguish errors without using SDoc
+
+   | ErrParseErrorInCmd !SDoc
+      -- ^ Parse error in command
+      --
+      -- TODO: distinguish errors without using SDoc
+
+   | ErrParseErrorInPat !SDoc
+      -- ^ Parse error in pattern
+      --
+      -- TODO: distinguish errors without using SDoc
+
+
+newtype StarIsType = StarIsType Bool
+
+data NumUnderscoreReason
+   = NumUnderscore_Integral
+   | NumUnderscore_Float
+   deriving (Show,Eq,Ord)
+
+data Hint
+   = SuggestTH
+   | SuggestRecursiveDo
+   | SuggestDo
+   | SuggestMissingDo
+   | SuggestLetInDo
+   | SuggestPatternSynonyms
+   | SuggestInfixBindMaybeAtPat !RdrName
+
+data LexErrKind
+   = LexErrKind_EOF        -- ^ End of input
+   | LexErrKind_UTF8       -- ^ UTF-8 decoding error
+   | LexErrKind_Char !Char -- ^ Error at given character
+   deriving (Show,Eq,Ord)
+
+data LexErr
+   = LexError               -- ^ Lexical error
+   | LexUnknownPragma       -- ^ Unknown pragma
+   | LexErrorInPragma       -- ^ Lexical error in pragma
+   | LexNumEscapeRange      -- ^ Numeric escape sequence out of range
+   | LexStringCharLit       -- ^ Llexical error in string/character literal
+   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal
+   | LexUnterminatedComment -- ^ Unterminated `{-'
+   | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma
+   | LexUnterminatedQQ      -- ^ Unterminated quasiquotation
+
+-- | Errors from the Cmm parser
+data CmmParserError
+   = CmmUnknownPrimitive    !FastString -- ^ Unknown Cmm primitive
+   | CmmUnknownMacro        !FastString -- ^ Unknown macro
+   | CmmUnknownCConv        !String     -- ^ Unknown calling convention
+   | CmmUnrecognisedSafety  !String     -- ^ Unrecognised safety
+   | CmmUnrecognisedHint    !String     -- ^ Unrecognised hint
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
new file mode 100644
index 0000000000..f99cac90a4
--- /dev/null
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -0,0 +1,585 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module GHC.Parser.Errors.Ppr
+   ( pprWarning
+   , pprError
+   )
+where
+
+import GHC.Prelude
+import GHC.Driver.Flags
+import GHC.Parser.Errors
+import GHC.Parser.Types
+import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)
+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)
+import GHC.Utils.Error
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
+import GHC.Data.FastString
+import GHC.Hs.Expr (prependQualified,HsExpr(..))
+import GHC.Hs.Type (pprLHsContext)
+import GHC.Builtin.Names (allNameStrings)
+import GHC.Builtin.Types (filterCTuple)
+
+mkParserErr :: SrcSpan -> SDoc -> ErrMsg
+mkParserErr span doc = ErrMsg
+   { errMsgSpan        = span
+   , errMsgContext     = alwaysQualify
+   , errMsgDoc         = ErrDoc [doc] [] []
+   , errMsgShortString = renderWithContext defaultSDocContext doc
+   , errMsgSeverity    = SevError
+   , errMsgReason      = NoReason
+   }
+
+mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg
+mkParserWarn flag span doc = ErrMsg
+   { errMsgSpan        = span
+   , errMsgContext     = alwaysQualify
+   , errMsgDoc         = ErrDoc [doc] [] []
+   , errMsgShortString = renderWithContext defaultSDocContext doc
+   , errMsgSeverity    = SevWarning
+   , errMsgReason      = Reason flag
+   }
+
+pprWarning :: Warning -> ErrMsg
+pprWarning = \case
+   WarnTab loc tc
+      -> mkParserWarn Opt_WarnTabs loc $
+          text "Tab character found here"
+            <> (if tc == 1
+                then text ""
+                else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))
+            <> text "."
+            $+$ text "Please use spaces instead."
+
+   WarnTransitionalLayout loc reason
+      -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $
+            text "transitional layout will not be accepted in the future:"
+            $$ text (case reason of
+               TransLayout_Where -> "`where' clause at the same depth as implicit layout block"
+               TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"
+            )
+
+   WarnUnrecognisedPragma loc
+      -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $
+            text "Unrecognised pragma"
+
+   WarnHaddockInvalidPos loc
+      -> mkParserWarn Opt_WarnInvalidHaddock loc $
+            text "A Haddock comment cannot appear in this position and will be ignored."
+
+   WarnHaddockIgnoreMulti loc
+      -> mkParserWarn Opt_WarnInvalidHaddock loc $
+            text "Multiple Haddock comments for a single entity are not allowed." $$
+            text "The extraneous comment will be ignored."
+
+   WarnStarBinder loc
+      -> mkParserWarn Opt_WarnStarBinder loc $
+            text "Found binding occurrence of" <+> quotes (text "*")
+            <+> text "yet StarIsType is enabled."
+         $$ text "NB. To use (or export) this operator in"
+            <+> text "modules with StarIsType,"
+         $$ text "    including the definition module, you must qualify it."
+
+   WarnStarIsType loc
+      -> mkParserWarn Opt_WarnStarIsType loc $
+             text "Using" <+> quotes (text "*")
+             <+> text "(or its Unicode variant) to mean"
+             <+> quotes (text "Data.Kind.Type")
+          $$ text "relies on the StarIsType extension, which will become"
+          $$ text "deprecated in the future."
+          $$ text "Suggested fix: use" <+> quotes (text "Type")
+           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
+
+   WarnImportPreQualified loc
+      -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $
+            text "Found" <+> quotes (text "qualified")
+             <+> text "in prepositive position"
+         $$ text "Suggested fix: place " <+> quotes (text "qualified")
+             <+> text "after the module name instead."
+         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+
+pprError :: Error -> ErrMsg
+pprError err = mkParserErr (errLoc err) $ vcat
+   (pp_err (errDesc err) : map pp_hint (errHints err))
+
+pp_err :: ErrorDesc -> SDoc
+pp_err = \case
+   ErrLambdaCase
+      -> text "Illegal lambda-case (use LambdaCase)"
+
+   ErrNumUnderscores reason
+      -> text $ case reason of
+            NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"
+            NumUnderscore_Float    -> "Use NumericUnderscores to allow underscores in floating literals"
+
+   ErrPrimStringInvalidChar
+      -> text "primitive string literal must contain only characters <= \'\\xFF\'"
+
+   ErrMissingBlock
+      -> text "Missing block"
+
+   ErrLexer err kind
+      -> hcat
+         [ text $ case err of
+            LexError               -> "lexical error"
+            LexUnknownPragma       -> "unknown pragma"
+            LexErrorInPragma       -> "lexical error in pragma"
+            LexNumEscapeRange      -> "numeric escape sequence out of range"
+            LexStringCharLit       -> "lexical error in string/character literal"
+            LexStringCharLitEOF    -> "unexpected end-of-file in string/character literal"
+            LexUnterminatedComment -> "unterminated `{-'"
+            LexUnterminatedOptions -> "unterminated OPTIONS pragma"
+            LexUnterminatedQQ      -> "unterminated quasiquotation"
+
+
+         , text $ case kind of
+            LexErrKind_EOF    -> " at end of input"
+            LexErrKind_UTF8   -> " (UTF-8 decoding error)"
+            LexErrKind_Char c -> " at character " ++ show c
+         ]
+
+   ErrSuffixAT
+      -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
+
+   ErrParse token
+      | null token
+      -> text "parse error (possibly incorrect indentation or mismatched brackets)"
+
+      | otherwise
+      -> text "parse error on input" <+> quotes (text token)
+
+   ErrCmmLexer
+      -> text "Cmm lexical error"
+
+   ErrUnsupportedBoxedSumExpr s
+      -> hang (text "Boxed sums not supported:") 2
+              (pprSumOrTuple Boxed s)
+
+   ErrUnsupportedBoxedSumPat s
+      -> hang (text "Boxed sums not supported:") 2
+              (pprSumOrTuple Boxed s)
+
+   ErrUnexpectedQualifiedConstructor v
+      -> hang (text "Expected an unqualified type constructor:") 2
+              (ppr v)
+
+   ErrTupleSectionInPat
+      -> text "Tuple section in pattern context"
+
+   ErrIllegalBangPattern e
+      -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e
+
+   ErrOpFewArgs (StarIsType star_is_type) op
+      -> text "Operator applied to too few arguments:" <+> ppr op
+         $$ starInfo star_is_type op
+
+   ErrImportQualifiedTwice
+      -> text "Multiple occurrences of 'qualified'"
+
+   ErrImportPostQualified
+      -> text "Found" <+> quotes (text "qualified")
+          <+> text "in postpositive position. "
+         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+
+   ErrIllegalExplicitNamespace
+      -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
+
+   ErrVarForTyCon name
+      -> text "Expecting a type constructor but found a variable,"
+           <+> quotes (ppr name) <> text "."
+         $$ if isSymOcc $ rdrNameOcc name
+            then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
+                  <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
+            else empty
+
+   ErrIllegalPatSynExport
+      -> text "Illegal export form (use PatternSynonyms to enable)"
+
+   ErrMalformedEntityString
+      -> text "Malformed entity string"
+
+   ErrDotsInRecordUpdate
+      -> text "You cannot use `..' in a record update"
+
+   ErrPrecedenceOutOfRange i
+      -> text "Precedence out of range: " <> int i
+
+   ErrInvalidDataCon t
+      -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2
+              (ppr t)
+
+   ErrInvalidInfixDataCon lhs tc rhs
+      -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
+            2 (ppr lhs <+> ppr tc <+> ppr rhs)
+
+   ErrUnpackDataCon
+      -> text "{-# UNPACK #-} cannot be applied to a data constructor."
+
+   ErrUnexpectedKindAppInDataCon lhs ki
+      -> hang (text "Unexpected kind application in a data/newtype declaration:") 2
+              (ppr lhs <+> text "@" <> ppr ki)
+
+   ErrInvalidRecordCon p
+      -> text "Not a record constructor:" <+> ppr p
+
+   ErrIllegalUnboxedStringInPat lit
+      -> text "Illegal unboxed string literal in pattern:" $$ ppr lit
+
+   ErrDoNotationInPat
+      -> text "do-notation in pattern"
+
+   ErrIfTheElseInPat
+      -> text "(if ... then ... else ...)-syntax in pattern"
+
+   ErrTypeAppInPat
+      -> text "Type applications in patterns are not yet supported"
+
+   ErrLambdaCaseInPat
+      -> text "(\\case ...)-syntax in pattern"
+
+   ErrCaseInPat
+      -> text "(case ... of ...)-syntax in pattern"
+
+   ErrLetInPat
+      -> text "(let ... in ...)-syntax in pattern"
+
+   ErrLambdaInPat
+      -> text "Lambda-syntax in pattern."
+         $$ text "Pattern matching on functions is not possible."
+
+   ErrArrowExprInPat e
+      -> text "Expression syntax in pattern:" <+> ppr e
+
+   ErrArrowCmdInPat c
+      -> text "Command syntax in pattern:" <+> ppr c
+
+   ErrArrowCmdInExpr c
+      -> vcat
+         [ text "Arrow command found where an expression was expected:"
+         , nest 2 (ppr c)
+         ]
+
+   ErrViewPatInExpr a b
+      -> sep [ text "View pattern in expression context:"
+             , nest 4 (ppr a <+> text "->" <+> ppr b)
+             ]
+
+   ErrTypeAppWithoutSpace v e
+      -> sep [ text "@-pattern in expression context:"
+             , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)
+             ]
+         $$ text "Type application syntax requires a space before '@'"
+
+
+   ErrLazyPatWithoutSpace e
+      -> sep [ text "Lazy pattern in expression context:"
+             , nest 4 (text "~" <> ppr e)
+             ]
+         $$ text "Did you mean to add a space after the '~'?"
+
+   ErrBangPatWithoutSpace e
+      -> sep [ text "Bang pattern in expression context:"
+             , nest 4 (text "!" <> ppr e)
+             ]
+         $$ text "Did you mean to add a space after the '!'?"
+
+   ErrUnallowedPragma prag
+      -> hang (text "A pragma is not allowed in this position:") 2
+              (ppr prag)
+
+   ErrQualifiedDoInCmd m
+      -> hang (text "Parse error in command:") 2 $
+            text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
+            $$ text "qualified 'do' is not supported in commands."
+
+   ErrParseErrorInCmd s
+      -> hang (text "Parse error in command:") 2 s
+
+   ErrParseErrorInPat s
+      -> text "Parse error in pattern:" <+> s
+
+
+   ErrInvalidInfixHole
+      -> text "Invalid infix hole, expected an infix operator"
+
+   ErrSemiColonsInCondExpr c st t se e
+      -> text "Unexpected semi-colons in conditional:"
+         $$ nest 4 expr
+         $$ text "Perhaps you meant to use DoAndIfThenElse?"
+         where
+            pprOptSemi True  = semi
+            pprOptSemi False = empty
+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>
+                   text "then" <+> ppr t <> pprOptSemi se <+>
+                   text "else" <+> ppr e
+
+   ErrSemiColonsInCondCmd c st t se e
+      -> text "Unexpected semi-colons in conditional:"
+         $$ nest 4 expr
+         $$ text "Perhaps you meant to use DoAndIfThenElse?"
+         where
+            pprOptSemi True  = semi
+            pprOptSemi False = empty
+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>
+                   text "then" <+> ppr t <> pprOptSemi se <+>
+                   text "else" <+> ppr e
+
+
+   ErrAtInPatPos
+      -> text "Found a binding for the"
+         <+> quotes (text "@")
+         <+> text "operator in a pattern position."
+         $$ perhaps_as_pat
+
+   ErrLambdaCmdInFunAppCmd a
+      -> pp_unexpected_fun_app (text "lambda command") a
+
+   ErrCaseCmdInFunAppCmd a
+      -> pp_unexpected_fun_app (text "case command") a
+
+   ErrIfCmdInFunAppCmd a
+      -> pp_unexpected_fun_app (text "if command") a
+
+   ErrLetCmdInFunAppCmd a
+      -> pp_unexpected_fun_app (text "let command") a
+
+   ErrDoCmdInFunAppCmd a
+      -> pp_unexpected_fun_app (text "do command") a
+
+   ErrDoInFunAppExpr m a
+      -> pp_unexpected_fun_app (prependQualified m (text "do block")) a
+
+   ErrMDoInFunAppExpr m a
+      -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a
+
+   ErrLambdaInFunAppExpr a
+      -> pp_unexpected_fun_app (text "lambda expression") a
+
+   ErrCaseInFunAppExpr a
+      -> pp_unexpected_fun_app (text "case expression") a
+
+   ErrLambdaCaseInFunAppExpr a
+      -> pp_unexpected_fun_app (text "lambda-case expression") a
+
+   ErrLetInFunAppExpr a
+      -> pp_unexpected_fun_app (text "let expression") a
+
+   ErrIfInFunAppExpr a
+      -> pp_unexpected_fun_app (text "if expression") a
+
+   ErrProcInFunAppExpr a
+      -> pp_unexpected_fun_app (text "proc expression") a
+
+   ErrMalformedTyOrClDecl ty
+      -> text "Malformed head of type or class declaration:"
+         <+> ppr ty
+
+   ErrIllegalWhereInDataDecl
+      -> vcat
+            [ text "Illegal keyword 'where' in data declaration"
+            , text "Perhaps you intended to use GADTs or a similar language"
+            , text "extension to enable syntax: data T where"
+            ]
+
+   ErrIllegalTraditionalRecordSyntax s
+      -> text "Illegal record syntax (use TraditionalRecordSyntax):"
+         <+> s
+
+   ErrParseErrorOnInput occ
+      -> text "parse error on input" <+> ftext (occNameFS occ)
+
+   ErrIllegalDataTypeContext c
+      -> text "Illegal datatype context (use DatatypeContexts):"
+         <+> pprLHsContext c
+
+   ErrMalformedDecl what for
+      -> text "Malformed" <+> what
+         <+> text "declaration for" <+> quotes (ppr for)
+
+   ErrUnexpectedTypeAppInDecl ki what for
+      -> vcat [ text "Unexpected type application"
+                <+> text "@" <> ppr ki
+              , text "In the" <+> what
+                <+> text "declaration for"
+                <+> quotes (ppr for)
+              ]
+
+   ErrNotADataCon name
+      -> text "Not a data constructor:" <+> quotes (ppr name)
+
+   ErrRecordSyntaxInPatSynDecl pat
+      -> text "record syntax not supported for pattern synonym declarations:"
+         $$ ppr pat
+
+   ErrEmptyWhereInPatSynDecl patsyn_name
+      -> text "pattern synonym 'where' clause cannot be empty"
+         $$ text "In the pattern synonym declaration for: "
+            <+> ppr (patsyn_name)
+
+   ErrInvalidWhereBindInPatSynDecl patsyn_name decl
+      -> text "pattern synonym 'where' clause must bind the pattern synonym's name"
+         <+> quotes (ppr patsyn_name) $$ ppr decl
+
+   ErrNoSingleWhereBindInPatSynDecl _patsyn_name decl
+      -> text "pattern synonym 'where' clause must contain a single binding:"
+         $$ ppr decl
+
+   ErrDeclSpliceNotAtTopLevel d
+      -> hang (text "Declaration splices are allowed only"
+               <+> text "at the top level:")
+           2 (ppr d)
+
+   ErrInferredTypeVarNotAllowed
+      -> text "Inferred type variables are not allowed here"
+
+   ErrIllegalRoleName role nearby
+      -> text "Illegal role name" <+> quotes (ppr role)
+         $$ case nearby of
+             []  -> empty
+             [r] -> text "Perhaps you meant" <+> quotes (ppr r)
+             -- will this last case ever happen??
+             _   -> hang (text "Perhaps you meant one of these:")
+                         2 (pprWithCommas (quotes . ppr) nearby)
+
+   ErrMultipleNamesInStandaloneKindSignature vs
+      -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
+                2 (pprWithCommas ppr vs)
+              , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."
+              ]
+
+   ErrIllegalImportBundleForm
+      -> text "Illegal import form, this syntax can only be used to bundle"
+         $+$ text "pattern synonyms with types in module exports."
+
+   ErrInvalidTypeSignature lhs
+      -> text "Invalid type signature:"
+         <+> ppr lhs
+         <+> text ":: ..."
+         $$ text hint
+         where
+         hint | foreign_RDR `looks_like` lhs
+              = "Perhaps you meant to use ForeignFunctionInterface?"
+              | default_RDR `looks_like` lhs
+              = "Perhaps you meant to use DefaultSignatures?"
+              | pattern_RDR `looks_like` lhs
+              = "Perhaps you meant to use PatternSynonyms?"
+              | otherwise
+              = "Should be of form <variable> :: <type>"
+
+         -- A common error is to forget the ForeignFunctionInterface flag
+         -- so check for that, and suggest.  cf #3805
+         -- Sadly 'foreign import' still barfs 'parse error' because
+         --  'import' is a keyword
+         looks_like s (L _ (HsVar _ (L _ v))) = v == s
+         looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs
+         looks_like _ _                       = False
+
+         foreign_RDR = mkUnqual varName (fsLit "foreign")
+         default_RDR = mkUnqual varName (fsLit "default")
+         pattern_RDR = mkUnqual varName (fsLit "pattern")
+
+   ErrUnexpectedTypeInDecl t what tc tparms equals_or_where
+      -> vcat [ text "Unexpected type" <+> quotes (ppr t)
+              , text "In the" <+> what
+                <+> ptext (sLit "declaration for") <+> quotes tc'
+              , vcat[ (text "A" <+> what
+                       <+> ptext (sLit "declaration should have form"))
+              , nest 2
+                (what
+                 <+> tc'
+                 <+> hsep (map text (takeList tparms allNameStrings))
+                 <+> equals_or_where) ] ]
+          where
+            -- Avoid printing a constraint tuple in the error message. Print
+            -- a plain old tuple instead (since that's what the user probably
+            -- wrote). See #14907
+            tc' = ppr $ filterCTuple tc
+
+   ErrCmmParser cmm_err -> case cmm_err of
+      CmmUnknownPrimitive name     -> text "unknown primitive" <+> ftext name
+      CmmUnknownMacro fun          -> text "unknown macro" <+> ftext fun
+      CmmUnknownCConv cconv        -> text "unknown calling convention:" <+> text cconv
+      CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety
+      CmmUnrecognisedHint hint     -> text "unrecognised hint:" <+> text hint
+
+   ErrExpectedHyphen
+      -> text "Expected a hyphen"
+
+   ErrSpaceInSCC
+      -> text "Spaces are not allowed in SCCs"
+
+   ErrEmptyDoubleQuotes th_on
+      -> if th_on then vcat (msg ++ th_msg) else vcat msg
+         where
+            msg    = [ text "Parser error on `''`"
+                     , text "Character literals may not be empty"
+                     ]
+            th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
+                     , text "but the type variable or constructor is missing"
+                     ]
+
+   ErrInvalidPackageName pkg
+      -> vcat
+            [ text "Parse error" <> colon <+> quotes (ftext pkg)
+            , text "Version number or non-alphanumeric" <+>
+              text "character in package name"
+            ]
+
+   ErrInvalidRuleActivationMarker
+      -> text "Invalid rule activation marker"
+
+   ErrLinearFunction
+      -> text "Enable LinearTypes to allow linear functions"
+
+   ErrMultiWayIf
+      -> text "Multi-way if-expressions need MultiWayIf turned on"
+
+   ErrExplicitForall is_unicode
+      -> vcat
+         [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"
+         , text "Perhaps you intended to use RankNTypes or a similar language"
+         , text "extension to enable explicit-forall syntax:" <+>
+           forallSym is_unicode <+> text "<tvs>. <type>"
+         ]
+         where
+          forallSym True  = text "∀"
+          forallSym False = text "forall"
+
+   ErrIllegalQualifiedDo qdoDoc
+      -> vcat
+         [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
+         , text "Perhaps you intended to use QualifiedDo"
+         ]
+
+pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc
+pp_unexpected_fun_app e a =
+   text "Unexpected " <> e <> text " in function application:"
+    $$ nest 4 (ppr a)
+    $$ text "You could write it with parentheses"
+    $$ text "Or perhaps you meant to enable BlockArguments?"
+
+pp_hint :: Hint -> SDoc
+pp_hint = \case
+   SuggestTH              -> text "Perhaps you intended to use TemplateHaskell"
+   SuggestDo              -> text "Perhaps this statement should be within a 'do' block?"
+   SuggestMissingDo       -> text "Possibly caused by a missing 'do'?"
+   SuggestRecursiveDo     -> text "Perhaps you intended to use RecursiveDo"
+   SuggestLetInDo         -> text "Perhaps you need a 'let' in a 'do' block?"
+                             $$ text "e.g. 'let x = 5' instead of 'x = 5'"
+   SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"
+
+   SuggestInfixBindMaybeAtPat fun
+      -> text "In a function binding for the"
+            <+> quotes (ppr fun)
+            <+> text "operator."
+         $$ if opIsAt fun
+               then perhaps_as_pat
+               else empty
+
+perhaps_as_pat :: SDoc
+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
+
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 64b1ee8333..f63e44f3c4 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -27,6 +27,8 @@ where
 import GHC.Prelude
 
 import GHC.Platform
+import GHC.Parser.Errors.Ppr
+import GHC.Parser.Errors
 import GHC.Driver.Types
 import GHC.Parser           ( parseHeader )
 import GHC.Parser.Lexer
@@ -43,7 +45,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Data.Maybe
-import GHC.Data.Bag         ( emptyBag, listToBag, unitBag )
+import GHC.Data.Bag         ( Bag, emptyBag, listToBag, unitBag, isEmptyBag )
 import GHC.Utils.Monad
 import GHC.Utils.Exception as Exception
 import GHC.Types.Basic
@@ -66,7 +68,7 @@ getImports :: DynFlags
            -> FilePath     -- ^ The original source filename (used for locations
                            --   in the function result)
            -> IO (Either
-               ErrorMessages
+               (Bag Error)
                ([(Maybe FastString, Located ModuleName)],
                 [(Maybe FastString, Located ModuleName)],
                 Located ModuleName))
@@ -77,15 +79,13 @@ getImports dflags buf filename source_filename = do
   case unP parseHeader (initParserState (initParserOpts dflags) buf loc) of
     PFailed pst ->
         -- assuming we're not logging warnings here as per below
-      return $ Left $ getErrorMessages pst dflags
+      return $ Left $ getErrorMessages pst
     POk pst rdr_module -> fmap Right $ do
-      let _ms@(_warns, errs) = getMessages pst dflags
+      let (_warns, errs) = getMessages pst
       -- don't log warnings: they'll be reported when we parse the file
       -- for real.  See #2500.
-          ms = (emptyBag, errs)
-      -- logWarnings warns
-      if errorsFound dflags ms
-        then throwIO $ mkSrcErr errs
+      if not (isEmptyBag errs)
+        then throwIO $ mkSrcErr (fmap pprError errs)
         else
           let   hsmod = unLoc rdr_module
                 mb_mod = hsmodName hsmod
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index b3d83b2408..90ee473c5d 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -53,8 +53,6 @@ module GHC.Parser.Lexer (
    ParserOpts(..), mkParserOpts,
    PState (..), initParserState, initPragState,
    P(..), ParseResult(..),
-   appendWarning,
-   appendError,
    allocateComments,
    MonadP(..),
    getRealSrcLoc, getPState, withHomeUnitId,
@@ -70,6 +68,7 @@ module GHC.Parser.Lexer (
    addAnnsAt,
    commentToAnnotation,
    HdkComment(..),
+   warnopt,
   ) where
 
 import GHC.Prelude
@@ -104,8 +103,6 @@ import GHC.Types.Unique.FM
 import GHC.Data.Maybe
 import GHC.Data.OrdList
 import GHC.Utils.Misc ( readRational, readHexRational )
-import GHC.Utils.Error
-import GHC.Driver.Session as DynFlags
 
 import GHC.Types.SrcLoc
 import GHC.Unit
@@ -117,6 +114,8 @@ import GHC.Hs.Doc
 import GHC.Parser.CharClass
 
 import GHC.Parser.Annotation
+import GHC.Driver.Flags
+import GHC.Parser.Errors
 }
 
 -- -----------------------------------------------------------------------------
@@ -357,7 +356,7 @@ $tab          { warnTab }
 }
 
 <0,option_prags> {
-  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
+  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas WarnUnrecognisedPragma
                     (nested_comment lexToken) }
 }
 
@@ -1086,7 +1085,7 @@ failLinePrag1 :: Action
 failLinePrag1 span _buf _len = do
   b <- getBit InNestedCommentBit
   if b then return (L span ITcomment_line_prag)
-       else lexError "lexical error in pragma"
+       else lexError LexErrorInPragma
 
 -- See Note [Nested comment line pragmas]
 popLinePrag1 :: Action
@@ -1107,7 +1106,7 @@ hopefully_open_brace span buf len
                  Layout prev_off _ : _ -> prev_off < offset
                  _                     -> True
       if isOK then pop_and open_brace span buf len
-              else addFatalError (mkSrcSpanPs span) (text "Missing block")
+              else addFatalError $ Error ErrMissingBlock [] (mkSrcSpanPs span)
 
 pop_and :: Action -> Action
 pop_and act span buf len = do _ <- popLexState
@@ -1486,7 +1485,7 @@ docCommentEnd input commentAcc docType buf span = do
   commentEnd lexToken input commentAcc finalizeComment buf span
 
 errBrace :: AlexInput -> RealSrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'"
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (Error (ErrLexer LexUnterminatedComment LexErrKind_EOF) [])
 
 open_brace, close_brace :: Action
 open_brace span _str _len = do
@@ -1545,8 +1544,7 @@ varid span buf len =
           lambdaCase <- getBit LambdaCaseBit
           unless lambdaCase $ do
             pState <- getPState
-            addError (mkSrcSpanPs (last_loc pState)) $ text
-                     "Illegal lambda-case (use LambdaCase)"
+            addError $ Error ErrLambdaCase [] (mkSrcSpanPs (last_loc pState))
           return ITlcase
         _ -> return ITcase
       maybe_layout keyword
@@ -1595,9 +1593,8 @@ varsym_prefix = sym $ \exts s ->
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_suffix :: Action
 varsym_suffix = sym $ \_ s ->
-  if | s == fsLit "@"
-     -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
-     | otherwise -> return (ITvarsym s)
+  if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT [])
+     | otherwise      -> return (ITvarsym s)
 
 -- See Note [Whitespace-sensitive operator parsing]
 varsym_tight_infix :: Action
@@ -1649,8 +1646,7 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
   let src = lexemeToString buf len
   when ((not numericUnderscores) && ('_' `elem` src)) $ do
     pState <- getPState
-    addError (mkSrcSpanPs (last_loc pState)) $ text
-             "Use NumericUnderscores to allow underscores in integer literals"
+    addError $ Error (ErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))
   return $ L span $ itint (SourceText src)
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
@@ -1691,8 +1687,7 @@ tok_frac drop f span buf len = do
   let src = lexemeToString buf (len-drop)
   when ((not numericUnderscores) && ('_' `elem` src)) $ do
     pState <- getPState
-    addError (mkSrcSpanPs (last_loc pState)) $ text
-             "Use NumericUnderscores to allow underscores in floating literals"
+    addError $ Error (ErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))
   return (L span $! (f $! src))
 
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
@@ -1862,7 +1857,7 @@ lex_string_prag mkTok span _buf _len
               = case alexGetChar i of
                   Just (c,i') | c == x    -> isString i' xs
                   _other -> False
-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma"
+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (Error (ErrLexer LexUnterminatedOptions LexErrKind_EOF) [])
 
 
 -- -----------------------------------------------------------------------------
@@ -1900,8 +1895,8 @@ lex_string s = do
                 setInput i
                 when (any (> '\xFF') s') $ do
                   pState <- getPState
-                  addError (mkSrcSpanPs (last_loc pState)) $ text
-                     "primitive string literal must contain only characters <= \'\\xFF\'"
+                  let err = Error ErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))
+                  addError err
                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))
               _other ->
                 return (ITstring (SourceText s') (mkFastString s'))
@@ -2057,7 +2052,7 @@ readNum2 is_digit base conv i = do
             Just (c,input') | is_digit c -> do
                let i' = i*base + conv c
                if i' > 0x10ffff
-                  then setInput input >> lexError "numeric escape sequence out of range"
+                  then setInput input >> lexError LexNumEscapeRange
                   else read i' input'
             _other -> do
               setInput input; return (chr i)
@@ -2106,12 +2101,12 @@ silly_escape_chars = [
 -- a correct location to the user, but also so we can detect UTF-8 decoding
 -- errors if they occur.
 lit_error :: AlexInput -> P a
-lit_error i = do setInput i; lexError "lexical error in string/character literal"
+lit_error i = do setInput i; lexError LexStringCharLit
 
 getCharOrFail :: AlexInput -> P Char
 getCharOrFail i =  do
   case alexGetChar' i of
-        Nothing -> lexError "unexpected end-of-file in string/character literal"
+        Nothing -> lexError LexStringCharLitEOF
         Just (c,i)  -> do setInput i; return c
 
 -- -----------------------------------------------------------------------------
@@ -2162,7 +2157,8 @@ lex_quasiquote start s = do
 quasiquote_error :: RealSrcLoc -> P a
 quasiquote_error start = do
   (AI end buf) <- getInput
-  reportLexError start (psRealLoc end) buf "unterminated quasiquotation"
+  reportLexError start (psRealLoc end) buf
+    (\k -> Error (ErrLexer LexUnterminatedQQ k) [])
 
 -- -----------------------------------------------------------------------------
 -- Warnings
@@ -2172,9 +2168,9 @@ warnTab srcspan _buf _len = do
     addTabWarning (psRealSpan srcspan)
     lexToken
 
-warnThen :: WarningFlag -> SDoc -> Action -> Action
-warnThen option warning action srcspan buf len = do
-    addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning
+warnThen :: WarningFlag -> (SrcSpan -> Warning) -> Action -> Action
+warnThen flag warning action srcspan buf len = do
+    addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))
     action srcspan buf len
 
 -- -----------------------------------------------------------------------------
@@ -2234,11 +2230,10 @@ data HdkComment
 data PState = PState {
         buffer     :: StringBuffer,
         options    :: ParserOpts,
-        -- This needs to take DynFlags as an argument until
-        -- we have a fix for #10143
-        messages   :: DynFlags -> Messages,
+        warnings   :: Bag Warning,
+        errors     :: Bag Error,
         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file
-        tab_count  :: !Int,              -- number of tab warnings in the file
+        tab_count  :: !Word,             -- number of tab warnings in the file
         last_tk    :: Maybe Token,
         last_loc   :: PsSpan,      -- pos of previous token
         last_len   :: !Int,        -- len of previous token
@@ -2316,14 +2311,14 @@ thenP :: P a -> (a -> P b) -> P b
                 POk s1 a         -> (unP (k a)) s1
                 PFailed s1 -> PFailed s1
 
-failMsgP :: String -> P a
-failMsgP msg = do
+failMsgP :: (SrcSpan -> Error) -> P a
+failMsgP f = do
   pState <- getPState
-  addFatalError (mkSrcSpanPs (last_loc pState)) (text msg)
+  addFatalError (f (mkSrcSpanPs (last_loc pState)))
 
-failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str =
-  addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str)
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> Error) -> P a
+failLocMsgP loc1 loc2 f =
+  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))
 
 getPState :: P PState
 getPState = P $ \s -> POk s s
@@ -2370,7 +2365,7 @@ setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
 getLastTk :: P (Maybe Token)
 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
 
-data AlexInput = AI PsLoc StringBuffer
+data AlexInput = AI !PsLoc !StringBuffer
 
 {-
 Note [Unicode in Alex]
@@ -2732,7 +2727,8 @@ initParserState options buf loc =
   PState {
       buffer        = buf,
       options       = options,
-      messages      = const emptyMessages,
+      errors        = emptyBag,
+      warnings      = emptyBag,
       tab_first     = Nothing,
       tab_count     = 0,
       last_tk       = Nothing,
@@ -2778,59 +2774,40 @@ class Monad m => MonadP m where
   --   to the accumulator and parsing continues. This allows GHC to report
   --   more than one parse error per file.
   --
-  addError :: SrcSpan -> SDoc -> m ()
+  addError :: Error -> m ()
+
   -- | Add a warning to the accumulator.
   --   Use 'getMessages' to get the accumulated warnings.
-  addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()
+  addWarning :: WarningFlag -> Warning -> m ()
+
   -- | Add a fatal error. This will be the last error reported by the parser, and
   --   the parser will not produce any result, ending in a 'PFailed' state.
-  addFatalError :: SrcSpan -> SDoc -> m a
+  addFatalError :: Error -> m a
+
   -- | Check if a given flag is currently set in the bitmap.
   getBit :: ExtBits -> m Bool
+
   -- | Given a location and a list of AddAnn, apply them all to the location.
   addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
                 -> AnnKeywordId     -- The first two parameters are the key
                 -> SrcSpan          -- The location of the keyword itself
                 -> m ()
 
-appendError
-  :: SrcSpan
-  -> SDoc
-  -> (DynFlags -> Messages)
-  -> (DynFlags -> Messages)
-appendError srcspan msg m =
-  \d ->
-    let (ws, es) = m d
-        errormsg = mkErrMsg d srcspan alwaysQualify msg
-        es' = es `snocBag` errormsg
-    in (ws, es')
-
-appendWarning
-  :: ParserOpts
-  -> WarningFlag
-  -> SrcSpan
-  -> SDoc
-  -> (DynFlags -> Messages)
-  -> (DynFlags -> Messages)
-appendWarning o option srcspan warning m =
-  \d ->
-    let (ws, es) = m d
-        warning' = makeIntoWarning (Reason option) $
-           mkWarnMsg d srcspan alwaysQualify warning
-        ws' = if warnopt option o then ws `snocBag` warning' else ws
-    in (ws', es)
-
 instance MonadP P where
-  addError srcspan msg
-   = P $ \s@PState{messages=m} ->
-             POk s{messages=appendError srcspan msg m} ()
-  addWarning option srcspan warning
-   = P $ \s@PState{messages=m, options=o} ->
-             POk s{messages=appendWarning o option srcspan warning m} ()
-  addFatalError span msg =
-    addError span msg >> P PFailed
+  addError err
+   = P $ \s -> POk s { errors = err `consBag` errors s} ()
+
+  addWarning option w
+   = P $ \s -> if warnopt option (options s)
+                  then POk (s { warnings = w `consBag` warnings s }) ()
+                  else POk s ()
+
+  addFatalError err =
+    addError err >> P PFailed
+
   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
                          in b `seq` POk s b
+
   addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do
     addAnnotationOnly l a v
     allocateCommentsP l
@@ -2849,32 +2826,23 @@ addTabWarning srcspan
                 else s
        in POk s' ()
 
-mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
-mkTabWarning PState{tab_first=tf, tab_count=tc} d =
-  let middle = if tc == 1
-        then text ""
-        else text ", and in" <+> speakNOf (tc - 1) (text "further location")
-      message = text "Tab character found here"
-                <> middle
-                <> text "."
-                $+$ text "Please use spaces instead."
-  in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
-                 mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf
-
 -- | Get a bag of the errors that have been accumulated so far.
 --   Does not take -Werror into account.
-getErrorMessages :: PState -> DynFlags -> ErrorMessages
-getErrorMessages PState{messages=m} d =
-  let (_, es) = m d in es
+getErrorMessages :: PState -> Bag Error
+getErrorMessages p = errors p
 
 -- | Get the warnings and errors accumulated so far.
 --   Does not take -Werror into account.
-getMessages :: PState -> DynFlags -> Messages
-getMessages p@PState{messages=m} d =
-  let (ws, es) = m d
-      tabwarning = mkTabWarning p d
-      ws' = maybe ws (`consBag` ws) tabwarning
-  in (ws', es)
+getMessages :: PState -> (Bag Warning, Bag Error)
+getMessages p =
+  let ws = warnings p
+      -- we add the tabulation warning on the fly because
+      -- we count the number of occurences of tab characters
+      ws' = case tab_first p of
+               Nothing -> ws
+               Just tf -> WarnTab (RealSrcSpan tf Nothing) (tab_count p)
+                           `consBag` ws
+  in (ws', errors p)
 
 getContext :: P [LayoutContext]
 getContext = P $ \s@PState{context=ctx} -> POk s ctx
@@ -2889,7 +2857,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
         (_:tl) ->
           POk s{ context = tl } ()
         []     ->
-          unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
+          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
 
 -- Push a new layout context at the indentation of the last token read.
 pushCurrentContext :: GenSemic -> P ()
@@ -2919,29 +2887,27 @@ srcParseErr
   :: ParserOpts
   -> StringBuffer       -- current buffer (placed just after the last token)
   -> Int                -- length of the previous token
-  -> MsgDoc
-srcParseErr options buf len
-  = if null token
-         then text "parse error (possibly incorrect indentation or mismatched brackets)"
-         else text "parse error on input" <+> quotes (text token)
-              $$ ppWhen (not th_enabled && token == "$") -- #7396
-                        (text "Perhaps you intended to use TemplateHaskell")
-              $$ ppWhen (token == "<-")
-                        (if mdoInLast100
-                           then text "Perhaps you intended to use RecursiveDo"
-                           else text "Perhaps this statement should be within a 'do' block?")
-              $$ ppWhen (token == "=" && doInLast100) -- #15849
-                        (text "Perhaps you need a 'let' in a 'do' block?"
-                         $$ text "e.g. 'let x = 5' instead of 'x = 5'")
-              $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429
-                        (text "Perhaps you intended to use PatternSynonyms")
-  where token = lexemeToString (offsetBytes (-len) buf) len
-        pattern = decodePrevNChars 8 buf
-        last100 = decodePrevNChars 100 buf
-        doInLast100 = "do" `isInfixOf` last100
-        mdoInLast100 = "mdo" `isInfixOf` last100
-        th_enabled = ThQuotesBit `xtest` pExtsBitmap options
-        ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
+  -> SrcSpan
+  -> Error
+srcParseErr options buf len loc = Error (ErrParse token) suggests loc
+  where
+   token = lexemeToString (offsetBytes (-len) buf) len
+   pattern = decodePrevNChars 8 buf
+   last100 = decodePrevNChars 100 buf
+   doInLast100 = "do" `isInfixOf` last100
+   mdoInLast100 = "mdo" `isInfixOf` last100
+   th_enabled = ThQuotesBit `xtest` pExtsBitmap options
+   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
+
+   sug c s = if c then Just s else Nothing
+   sug_th  = sug (not th_enabled && token == "$")          SuggestTH              -- #7396
+   sug_rdo = sug (token == "<-" && mdoInLast100)           SuggestRecursiveDo
+   sug_do  = sug (token == "<-" && not mdoInLast100)       SuggestDo
+   sug_let = sug (token == "=" && doInLast100)             SuggestLetInDo         -- #15849
+   sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429
+   suggests
+         | null token = []
+         | otherwise  = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]
 
 -- Report a parse failure, giving the span of the previous token as
 -- the location of the error.  This is the entry point for errors
@@ -2949,15 +2915,16 @@ srcParseErr options buf len
 srcParseFail :: P a
 srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
                             last_loc = last_loc } ->
-    unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
+    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
 
 -- A lexical error is reported at a particular position in the source file,
 -- not over a token range.
-lexError :: String -> P a
-lexError str = do
+lexError :: LexErr -> P a
+lexError e = do
   loc <- getRealSrcLoc
   (AI end buf) <- getInput
-  reportLexError loc (psRealLoc end) buf str
+  reportLexError loc (psRealLoc end) buf
+    (\k -> Error (ErrLexer e k) [])
 
 -- -----------------------------------------------------------------------------
 -- This is the top-level function: called from the parser each time a
@@ -3073,9 +3040,7 @@ alternativeLayoutRuleToken t
              (ITwhere, ALRLayout _ col : ls, _)
               | newLine && thisCol == col && transitional ->
                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                               (mkSrcSpanPs thisLoc)
-                               (transitionalAlternativeLayoutWarning
-                                    "`where' clause at the same depth as implicit layout block")
+                      $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where
                     setALRContext ls
                     setNextToken t
                     -- Note that we use lastLoc, as we may need to close
@@ -3085,9 +3050,7 @@ alternativeLayoutRuleToken t
              (ITvbar, ALRLayout _ col : ls, _)
               | newLine && thisCol == col && transitional ->
                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                               (mkSrcSpanPs thisLoc)
-                               (transitionalAlternativeLayoutWarning
-                                    "`|' at the same depth as implicit layout block")
+                      $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe
                     setALRContext ls
                     setNextToken t
                     -- Note that we use lastLoc, as we may need to close
@@ -3154,11 +3117,6 @@ alternativeLayoutRuleToken t
              -- the other ITwhere case omitted; general case below covers it
              (_, _, _) -> return t
 
-transitionalAlternativeLayoutWarning :: String -> SDoc
-transitionalAlternativeLayoutWarning msg
-    = text "transitional layout will not be accepted in the future:"
-   $$ text msg
-
 isALRopen :: Token -> Bool
 isALRopen ITcase          = True
 isALRopen ITif            = True
@@ -3213,7 +3171,8 @@ lexToken = do
         setLastToken span 0
         return (L span ITeof)
     AlexError (AI loc2 buf) ->
-        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error"
+        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf
+          (\k -> Error (ErrLexer LexError k) [])
     AlexSkip inp2 _ -> do
         setInput inp2
         lexToken
@@ -3227,14 +3186,14 @@ lexToken = do
         unless (isComment lt') (setLastTk lt')
         return lt
 
-reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
-reportLexError loc1 loc2 buf str
-  | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> Error) -> P a
+reportLexError loc1 loc2 buf f
+  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)
   | otherwise =
   let c = fst (nextChar buf)
   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
-     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
-     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
+     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)
+     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))
 
 lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
 lexTokenStream opts buf loc = unP go initState{ options = opts' }
@@ -3309,7 +3268,7 @@ twoWordPrags = Map.fromList [
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
                                        Just found -> found span buf len
-                                       Nothing -> lexError "unknown pragma"
+                                       Nothing -> lexError LexUnknownPragma
 
 known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 48bcc45091..648ab1bfa4 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -35,7 +35,6 @@ module GHC.Parser.PostProcess (
         mkTyClD, mkInstD,
         mkRdrRecordCon, mkRdrRecordUpd,
         setRdrNameSpace,
-        filterCTuple,
         fromSpecTyVarBndr, fromSpecTyVarBndrs,
 
         cvBindGroup,
@@ -58,7 +57,7 @@ module GHC.Parser.PostProcess (
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
         checkPattern,         -- HsExp -> P HsPat
-        checkPattern_msg,
+        checkPattern_hints,
         checkMonadComp,       -- P (HsStmtContext GhcPs)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
@@ -81,7 +80,6 @@ module GHC.Parser.PostProcess (
         checkImportSpec,
 
         -- Token symbols
-        forallSym,
         starSym,
 
         -- Warnings and errors
@@ -106,7 +104,6 @@ module GHC.Parser.PostProcess (
         -- Type/datacon ambiguity resolution
         DisambTD(..),
         addUnpackednessP,
-        DataConBuilder(),
         dataConBuilderCon,
         dataConBuilderDetails,
     ) where
@@ -121,27 +118,27 @@ import GHC.Types.Name.Reader
 import GHC.Types.Name
 import GHC.Unit.Module (ModuleName)
 import GHC.Types.Basic
+import GHC.Parser.Types
 import GHC.Parser.Lexer
+import GHC.Parser.Errors
 import GHC.Utils.Lexeme ( isLexCon )
 import GHC.Core.Type    ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
 import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
-                          listTyConName, listTyConKey, eqTyCon_RDR,
-                          tupleTyConName, cTupleTyConNameArity_maybe )
+                          listTyConName, listTyConKey, eqTyCon_RDR )
 import GHC.Types.ForeignCall
-import GHC.Builtin.Names ( allNameStrings )
 import GHC.Types.SrcLoc
 import GHC.Types.Unique ( hasKey )
 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.Misc
 import GHC.Parser.Annotation
 import Data.List
 import Data.Foldable
-import GHC.Driver.Session ( WarningFlag(..), DynFlags )
-import GHC.Utils.Error ( Messages )
+import GHC.Driver.Session ( WarningFlag(..) )
 import GHC.Utils.Panic
 
 import Control.Monad
@@ -264,16 +261,12 @@ mkStandaloneKindSig loc lhs rhs =
     check_lhs_name v@(unLoc->name) =
       if isUnqual name && isTcOcc (rdrNameOcc name)
       then return v
-      else addFatalError (getLoc v) $
-           hang (text "Expected an unqualified type constructor:") 2 (ppr v)
+      else addFatalError $ Error (ErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v)
     check_singular_lhs vs =
       case vs of
         [] -> panic "mkStandaloneKindSig: empty left-hand side"
         [v] -> return v
-        _ -> addFatalError (getLoc lhs) $
-             vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
-                       2 (pprWithCommas ppr vs)
-                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
+        _ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)
 
 mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
                -> LHsType GhcPs
@@ -383,15 +376,7 @@ mkRoleAnnotDecl loc tycon roles
             let nearby = fuzzyLookup (unpackFS role)
                   (mapFst unpackFS possible_roles)
             in
-            addFatalError loc_role
-              (text "Illegal role name" <+> quotes (ppr role) $$
-               suggestions nearby)
-
-    suggestions []   = empty
-    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
-      -- will this last case ever happen??
-    suggestions list = hang (text "Perhaps you meant one of these:")
-                       2 (pprWithCommas (quotes . ppr) list)
+            addFatalError $ Error (ErrIllegalRoleName role nearby) [] loc_role
 
 -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
 -- binders without annotations. Only accepts specified variables, and errors if
@@ -411,8 +396,7 @@ fromSpecTyVarBndr bndr = case bndr of
   where
     check_spec :: Specificity -> SrcSpan -> P ()
     check_spec SpecifiedSpec _   = return ()
-    check_spec InferredSpec  loc = addFatalError loc
-                                   (text "Inferred type variables are not allowed here")
+    check_spec InferredSpec  loc = addFatalError $ Error ErrInferredTypeVarNotAllowed [] loc
 
 {- **********************************************************************
 
@@ -463,10 +447,7 @@ cvBindsAndSigs fb = do
     -- called on top-level declarations.
     drop_bad_decls [] = return []
     drop_bad_decls (L l (SpliceD _ d) : ds) = do
-      addError l $
-        hang (text "Declaration splices are allowed only" <+>
-              text "at the top level:")
-           2 (ppr d)
+      addError $ Error (ErrDeclSpliceNotAtTopLevel d) [] l
       drop_bad_decls ds
     drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
 
@@ -571,17 +552,16 @@ 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 :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)
+tyConToDataCon :: SrcSpan -> RdrName -> Either Error (Located RdrName)
 tyConToDataCon loc tc
   | isTcOcc occ || isDataOcc occ
   , isLexCon (occNameFS occ)
   = return (L loc (setRdrNameSpace tc srcDataName))
 
   | otherwise
-  = Left (loc, msg)
+  = Left $ Error (ErrNotADataCon tc) [] loc
   where
     occ = rdrNameOcc tc
-    msg = text "Not a data constructor:" <+> quotes (ppr tc)
 
 mkPatSynMatchGroup :: Located RdrName
                    -> Located (OrdList (LHsDecl GhcPs))
@@ -619,25 +599,17 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
     fromDecl (L loc decl) = extraDeclErr loc decl
 
     extraDeclErr loc decl =
-        addFatalError loc $
-        text "pattern synonym 'where' clause must contain a single binding:" $$
-        ppr decl
+        addFatalError $ Error (ErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc
 
     wrongNameBindingErr loc decl =
-      addFatalError loc $
-      text "pattern synonym 'where' clause must bind the pattern synonym's name"
-      <+> quotes (ppr patsyn_name) $$ ppr decl
+      addFatalError $ Error (ErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc
 
     wrongNumberErr loc =
-      addFatalError loc $
-      text "pattern synonym 'where' clause cannot be empty" $$
-      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
+      addFatalError $ Error (ErrEmptyWhereInPatSynDecl patsyn_name) [] loc
 
 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
 recordPatSynErr loc pat =
-    addFatalError loc $
-    text "record syntax not supported for pattern synonym declarations:" $$
-    ppr pat
+    addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc
 
 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
                 -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
@@ -761,12 +733,6 @@ data_con_ty_con dc
   | otherwise  -- See Note [setRdrNameSpace for wired-in names]
   = Unqual (setOccNameSpace tcClsName (getOccName dc))
 
--- | Replaces constraint tuple names with corresponding boxed ones.
-filterCTuple :: RdrName -> RdrName
-filterCTuple (Exact n)
-  | Just arity <- cTupleTyConNameArity_maybe n
-  = Exact $ tupleTyConName BoxedTuple arity
-filterCTuple rdr = rdr
 
 
 {- Note [setRdrNameSpace for wired-in names]
@@ -781,10 +747,10 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
-eitherToP :: MonadP m => Either (SrcSpan, SDoc) a -> m a
+eitherToP :: MonadP m => Either Error a -> m a
 -- Adapts the Either monad to the P monad
-eitherToP (Left (loc, doc)) = addFatalError loc doc
-eitherToP (Right thing)     = return thing
+eitherToP (Left err)    = addFatalError err
+eitherToP (Right thing) = return thing
 
 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
             -> P ( LHsQTyVars GhcPs  -- the synthesized type variables
@@ -795,16 +761,9 @@ 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 loc $
-                                      vcat [ text "Unexpected type application" <+>
-                                            text "@" <> ppr ki
-                                          , text "In the" <+> pp_what <+>
-                                            ptext (sLit "declaration for") <+> quotes (ppr tc)]
+    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ Error (ErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc
     check (HsValArg ty) = chkParens [] ty
-    check (HsArgPar sp) = addFatalError sp $
-                          vcat [text "Malformed" <+> pp_what
-                            <+> text "declaration for" <+> quotes (ppr tc)]
+    check (HsArgPar sp) = addFatalError $ Error (ErrMalformedDecl pp_what (unLoc tc)) [] sp
         -- Keep around an action for adjusting the annotations of extra parens
     chkParens :: [AddAnn] -> LHsType GhcPs
               -> P (LHsTyVarBndr () GhcPs, [AddAnn])
@@ -820,23 +779,7 @@ checkTyVars pp_what equals_or_where tc tparms
     chk (L l (HsTyVar _ _ (L ltv tv)))
         | isRdrTyVar tv    = return (L l (UserTyVar noExtField () (L ltv tv)))
     chk t@(L loc _)
-        = addFatalError loc $
-                vcat [ text "Unexpected type" <+> quotes (ppr t)
-                     , text "In the" <+> pp_what
-                       <+> ptext (sLit "declaration for") <+> quotes tc'
-                     , vcat[ (text "A" <+> pp_what
-                              <+> ptext (sLit "declaration should have form"))
-                     , nest 2
-                       (pp_what
-                        <+> tc'
-                        <+> hsep (map text (takeList tparms allNameStrings))
-                        <+> equals_or_where) ] ]
-
-    -- Avoid printing a constraint tuple in the error message. Print
-    -- a plain old tuple instead (since that's what the user probably
-    -- wrote). See #14907
-    tc' = ppr $ fmap filterCTuple tc
-
+        = addFatalError $ Error (ErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc
 
 
 whereDots, equalsDots :: SDoc
@@ -848,10 +791,7 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
 checkDatatypeContext Nothing = return ()
 checkDatatypeContext (Just c)
     = do allowed <- getBit DatatypeContextsBit
-         unless allowed $
-             addError (getLoc c)
-                 (text "Illegal datatype context (use DatatypeContexts):"
-                  <+> pprLHsContext c)
+         unless allowed $ addError $ Error (ErrIllegalDataTypeContext c) [] (getLoc c)
 
 type LRuleTyTmVar = Located RuleTyTmVar
 data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
@@ -879,16 +819,15 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one)
 checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
   where check (L loc (Unqual occ)) = do
+          -- TODO: don't use string here, OccName has a Unique/FastString
           when ((occNameString occ ==) `any` ["forall","family","role"])
-               (addFatalError loc (text $ "parse error on input "
-                                    ++ occNameString occ))
+            (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc)
         check _ = panic "checkRuleTyVarBndrNames"
 
 checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
 checkRecordSyntax lr@(L loc r)
     = do allowed <- getBit TraditionalRecordSyntaxBit
-         unless allowed $ addError loc $
-           text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
+         unless allowed $ addError $ Error (ErrIllegalTraditionalRecordSyntax (ppr r)) [] loc
          return lr
 
 -- | Check if the gadt_constrlist is empty. Only raise parse error for
@@ -897,11 +836,7 @@ checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                 -> P (Located ([AddAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.
     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
-         unless gadtSyntax $ addError span $ vcat
-           [ text "Illegal keyword 'where' in data declaration"
-           , text "Perhaps you intended to use GADTs or a similar language"
-           , text "extension to enable syntax: data T where"
-           ]
+         unless gadtSyntax $ addError $ Error ErrIllegalWhereInDataDecl [] span
          return gadts
 checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.
 
@@ -923,7 +858,7 @@ checkTyClHdr is_cls ty
 
     -- workaround to define '*' despite StarIsType
     go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
-      = do { warnStarBndr l
+      = do { addWarning Opt_WarnStarBinder (WarnStarBinder l)
            ; let name = mkOccName tcClsName (starSym isUni)
            ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }
 
@@ -942,8 +877,7 @@ 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 l (text "Malformed head of type or class declaration:"
-                          <+> ppr ty)
+      = addFatalError $ Error (ErrMalformedTyOrClDecl ty) [] l
 
 -- | Yield a parse error if we have a function applied directly to a do block
 -- etc. and BlockArguments is not enabled.
@@ -954,34 +888,29 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
     checkExpr :: LHsExpr GhcPs -> PV ()
     checkExpr expr = do
      case unLoc expr of
-      HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr
-      HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr
-      HsLam {} -> check (text "lambda expression") expr
-      HsCase {} -> check (text "case expression") expr
-      HsLamCase {} -> check (text "lambda-case expression") expr
-      HsLet {} -> check (text "let expression") expr
-      HsIf {} -> check (text "if expression") expr
-      HsProc {} -> check (text "proc expression") expr
-      _ -> return ()
+      HsDo _ (DoExpr m) _  -> check (ErrDoInFunAppExpr m)     expr
+      HsDo _ (MDoExpr m) _ -> check (ErrMDoInFunAppExpr m)    expr
+      HsLam {}             -> check ErrLambdaInFunAppExpr     expr
+      HsCase {}            -> check ErrCaseInFunAppExpr       expr
+      HsLamCase {}         -> check ErrLambdaCaseInFunAppExpr expr
+      HsLet {}             -> check ErrLetInFunAppExpr        expr
+      HsIf {}              -> check ErrIfInFunAppExpr         expr
+      HsProc {}            -> check ErrProcInFunAppExpr       expr
+      _                    -> return ()
 
     checkCmd :: LHsCmd GhcPs -> PV ()
     checkCmd cmd = case unLoc cmd of
-      HsCmdLam {} -> check (text "lambda command") cmd
-      HsCmdCase {} -> check (text "case command") cmd
-      HsCmdIf {} -> check (text "if command") cmd
-      HsCmdLet {} -> check (text "let command") cmd
-      HsCmdDo {} -> check (text "do command") cmd
-      _ -> return ()
-
-    check :: Outputable a => SDoc -> Located a -> PV ()
-    check element a = do
+      HsCmdLam {}  -> check ErrLambdaCmdInFunAppCmd cmd
+      HsCmdCase {} -> check ErrCaseCmdInFunAppCmd   cmd
+      HsCmdIf {}   -> check ErrIfCmdInFunAppCmd     cmd
+      HsCmdLet {}  -> check ErrLetCmdInFunAppCmd    cmd
+      HsCmdDo {}   -> check ErrDoCmdInFunAppCmd     cmd
+      _            -> return ()
+
+    check err a = do
       blockArguments <- getBit BlockArgumentsBit
       unless blockArguments $
-        addError (getLoc a) $
-          text "Unexpected " <> element <> text " in function application:"
-           $$ nest 4 (ppr a)
-           $$ text "You could write it with parentheses"
-           $$ text "Or perhaps you meant to enable BlockArguments?"
+        addError $ Error (err a) [] (getLoc a)
 
 -- | Validate the context constraints and break up a context into a list
 -- of predicates.
@@ -1044,8 +973,8 @@ checkImportDecl mPre mPost = do
 checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
 checkPattern = runPV . checkLPat
 
-checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
-checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
+checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
+checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)
 
 checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
 checkLPat e@(L l _) = checkPat l e []
@@ -1059,7 +988,7 @@ checkPat loc (L l e@(PatBuilderVar (L _ c))) args
       , pat_args = PrefixCon args
       }
   | not (null args) && patIsRec c =
-      localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
+      add_hint SuggestRecursiveDo $
       patFail l (ppr e)
 checkPat loc (L _ (PatBuilderApp f e)) args
   = do p <- checkLPat e
@@ -1092,9 +1021,7 @@ checkAPat loc e0 = do
 
    -- Improve error messages for the @-operator when the user meant an @-pattern
    PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do
-     addError (getLoc op) $
-       text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$
-       perhaps_as_pat
+     addError $ Error ErrAtInPatPos [] (getLoc op)
      return (WildPat noExtField)
 
    PatBuilderOpApp l (L cl c) r
@@ -1126,14 +1053,11 @@ checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)
                              return (L l (fld { hsRecFieldArg = p }))
 
 patFail :: SrcSpan -> SDoc -> PV a
-patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
+patFail loc e = addFatalError $ Error (ErrParseErrorInPat e) [] loc
 
 patIsRec :: RdrName -> Bool
 patIsRec e = e == mkUnqual varName (fsLit "rec")
 
-opIsAt :: RdrName -> Bool
-opIsAt e = e == mkUnqual varName (fsLit "@")
-
 ---------------------------------------------------------------------------
 -- Check Equation Syntax
 
@@ -1166,7 +1090,7 @@ checkFunBind :: SrcStrictness
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
 checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
-  = do  ps <- runPV_msg param_hint (mapM checkLPat pats)
+  = do  ps <- runPV_hints param_hints (mapM checkLPat pats)
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
@@ -1181,14 +1105,9 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
   where
-    param_hint
-      | Infix <- is_infix
-      = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$
-        if opIsAt (unLoc fun) then perhaps_as_pat else empty
-      | otherwise = empty
-
-perhaps_as_pat :: SDoc
-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
+    param_hints
+      | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]
+      | otherwise         = []
 
 makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
@@ -1226,48 +1145,22 @@ checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
   = return lrdr
 
 checkValSigLhs lhs@(L l _)
-  = addFatalError l ((text "Invalid type signature:" <+>
-                       ppr lhs <+> text ":: ...")
-                      $$ text hint)
-  where
-    hint | foreign_RDR `looks_like` lhs
-         = "Perhaps you meant to use ForeignFunctionInterface?"
-         | default_RDR `looks_like` lhs
-         = "Perhaps you meant to use DefaultSignatures?"
-         | pattern_RDR `looks_like` lhs
-         = "Perhaps you meant to use PatternSynonyms?"
-         | otherwise
-         = "Should be of form <variable> :: <type>"
-
-    -- A common error is to forget the ForeignFunctionInterface flag
-    -- so check for that, and suggest.  cf #3805
-    -- Sadly 'foreign import' still barfs 'parse error' because
-    --  'import' is a keyword
-    looks_like s (L _ (HsVar _ (L _ v))) = v == s
-    looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs
-    looks_like _ _                       = False
-
-    foreign_RDR = mkUnqual varName (fsLit "foreign")
-    default_RDR = mkUnqual varName (fsLit "default")
-    pattern_RDR = mkUnqual varName (fsLit "pattern")
+  = addFatalError $ Error (ErrInvalidTypeSignature lhs) [] l
 
 checkDoAndIfThenElse
   :: (Outputable a, Outputable b, Outputable c)
-  => Located a -> Bool -> b -> Bool -> Located c -> PV ()
-checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
- | semiThen || semiElse
-    = do doAndIfThenElse <- getBit DoAndIfThenElseBit
-         unless doAndIfThenElse $ do
-             addError (combineLocs guardExpr elseExpr)
-                            (text "Unexpected semi-colons in conditional:"
-                          $$ nest 4 expr
-                          $$ text "Perhaps you meant to use DoAndIfThenElse?")
- | otherwise            = return ()
-    where pprOptSemi True  = semi
-          pprOptSemi False = empty
-          expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
-                 text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
-                 text "else" <+> ppr elseExpr
+  => (a -> Bool -> b -> Bool -> c -> ErrorDesc)
+  -> Located a -> Bool -> Located b -> Bool -> Located c -> PV ()
+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
+ | semiThen || semiElse = do
+      doAndIfThenElse <- getBit DoAndIfThenElseBit
+      let e   = err (unLoc guardExpr)
+                    semiThen (unLoc thenExpr)
+                    semiElse (unLoc elseExpr)
+          loc = combineLocs guardExpr elseExpr
+
+      unless doAndIfThenElse $ addError (Error e [] loc)
+  | otherwise = return ()
 
 isFunLhs :: Located (PatBuilder GhcPs)
       -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
@@ -1373,8 +1266,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 l $ text "Invalid infix hole, expected an infix operator"
+  mkHsInfixHolePV l   = addFatalError $ Error ErrInvalidInfixHole [] l
 
 -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
 -- parsing an expression, a command, or a pattern.
@@ -1530,13 +1422,10 @@ instance DisambECP (HsCmd GhcPs) where
     return $ L l (HsCmdApp noExtField c e)
   mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)
   mkHsIfPV l c semi1 a semi2 b = do
-    checkDoAndIfThenElse c semi1 a semi2 b
+    checkDoAndIfThenElse ErrSemiColonsInCondCmd c semi1 a semi2 b
     return $ L l (mkHsCmdIf c a b)
   mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)
-  mkHsDoPV l (Just m)    _ =
-    cmdFail l $
-      text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
-      $$ text "qualified 'do' is not supported in commands."
+  mkHsDoPV l (Just m)    _ = addFatalError $ Error (ErrQualifiedDoInCmd m) [] l
   mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
   mkHsVarPV (L l v) = cmdFail l (ppr v)
   mkHsLitPV (L l a) = cmdFail l (ppr a)
@@ -1565,15 +1454,12 @@ instance DisambECP (HsCmd GhcPs) where
   rejectPragmaPV _ = return ()
 
 cmdFail :: SrcSpan -> SDoc -> PV a
-cmdFail loc e = addFatalError loc $
-  hang (text "Parse error in command:") 2 (ppr e)
+cmdFail loc e = addFatalError $ Error (ErrParseErrorInCmd e) [] loc
 
 instance DisambECP (HsExpr GhcPs) where
   type Body (HsExpr GhcPs) = HsExpr
   ecpFromCmd' (L l c) = do
-    addError l $ vcat
-      [ text "Arrow command found where an expression was expected:",
-        nest 2 (ppr c) ]
+    addError $ Error (ErrArrowCmdInExpr c) [] l
     return (L l hsHoleExpr)
   ecpFromExp' = return
   mkHsLamPV l mg = return $ L l (HsLam noExtField mg)
@@ -1594,7 +1480,7 @@ instance DisambECP (HsExpr GhcPs) where
     checkExpBlockArguments e
     return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))
   mkHsIfPV l c semi1 a semi2 b = do
-    checkDoAndIfThenElse c semi1 a semi2 b
+    checkDoAndIfThenElse ErrSemiColonsInCondExpr c semi1 a semi2 b
     return $ L l (mkHsIf c a b)
   mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)
   mkHsParPV l e = return $ L l (HsPar noExtField e)
@@ -1610,76 +1496,42 @@ instance DisambECP (HsExpr GhcPs) where
     checkRecordSyntax (L l r)
   mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)
   mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)
-  mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
-  mkHsAsPatPV l v e =
-    patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
-    text "Type application syntax requires a space before '@'"
-  mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $
-    text "Did you mean to add a space after the '~'?"
-  mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
-    text "Did you mean to add a space after the '!'?"
+  mkHsViewPatPV l a b = addError (Error (ErrViewPatInExpr a b) [] l)
+                        >> return (L l hsHoleExpr)
+  mkHsAsPatPV l v e   = addError (Error (ErrTypeAppWithoutSpace (unLoc v) e) [] l)
+                        >> return (L l hsHoleExpr)
+  mkHsLazyPatPV l e   = addError (Error (ErrLazyPatWithoutSpace e) [] l)
+                        >> return (L l hsHoleExpr)
+  mkHsBangPatPV l e   = addError (Error (ErrBangPatWithoutSpace e) [] l)
+                        >> return (L l hsHoleExpr)
   mkSumOrTuplePV = mkSumOrTupleExpr
   rejectPragmaPV (L _ (OpApp _ _ _ e)) =
     -- assuming left-associative parsing of operators
     rejectPragmaPV e
-  rejectPragmaPV (L l (HsPragE _ prag _)) =
-    addError l $
-      hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
-  rejectPragmaPV _ = return ()
-
-patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
-patSynErr item l e explanation =
-  do { addError l $
-        sep [text item <+> text "in expression context:",
-             nest 4 (ppr e)] $$
-        explanation
-     ; return (L l hsHoleExpr) }
+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ Error (ErrUnallowedPragma prag) [] l
+  rejectPragmaPV _                        = return ()
 
 hsHoleExpr :: HsExpr GhcPs
 hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
 
--- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
-data PatBuilder p
-  = PatBuilderPat (Pat p)
-  | PatBuilderPar (Located (PatBuilder p))
-  | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
-  | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
-  | PatBuilderVar (Located RdrName)
-  | PatBuilderOverLit (HsOverLit GhcPs)
-
-instance Outputable (PatBuilder GhcPs) where
-  ppr (PatBuilderPat p) = ppr p
-  ppr (PatBuilderPar (L _ p)) = parens (ppr p)
-  ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
-  ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
-  ppr (PatBuilderVar v) = ppr v
-  ppr (PatBuilderOverLit l) = ppr l
-
 instance DisambECP (PatBuilder GhcPs) where
   type Body (PatBuilder GhcPs) = PatBuilder
-  ecpFromCmd' (L l c) =
-    addFatalError l $
-      text "Command syntax in pattern:" <+> ppr c
-  ecpFromExp' (L l e) =
-    addFatalError l $
-      text "Expression syntax in pattern:" <+> ppr e
-  mkHsLamPV l _ = addFatalError l $
-    text "Lambda-syntax in pattern." $$
-    text "Pattern matching on functions is not possible."
-  mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
+  ecpFromCmd' (L l c)    = addFatalError $ Error (ErrArrowCmdInPat c) [] l
+  ecpFromExp' (L l e)    = addFatalError $ Error (ErrArrowExprInPat e) [] l
+  mkHsLamPV l _          = addFatalError $ Error ErrLambdaInPat [] l
+  mkHsLetPV l _ _        = addFatalError $ Error ErrLetInPat [] l
   type InfixOp (PatBuilder GhcPs) = RdrName
   superInfixOp m = m
   mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2
-  mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
-  mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern"
+  mkHsCasePV l _ _       = addFatalError $ Error ErrCaseInPat [] l
+  mkHsLamCasePV l _      = addFatalError $ Error ErrLambdaCaseInPat [] l
   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
   superFunArg m = m
-  mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
-  mkHsAppTypePV l _ _ = addFatalError l $
-    text "Type applications in patterns are not yet supported"
-  mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
-  mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"
-  mkHsParPV l p = return $ L l (PatBuilderPar p)
+  mkHsAppPV l p1 p2     = return $ L l (PatBuilderApp p1 p2)
+  mkHsAppTypePV l _ _   = addFatalError $ Error ErrTypeAppInPat [] l
+  mkHsIfPV l _ _ _ _ _  = addFatalError $ Error ErrIfTheElseInPat [] l
+  mkHsDoPV l _ _        = addFatalError $ Error ErrDoNotationInPat [] l
+  mkHsParPV l p         = return $ L l (PatBuilderPar p)
   mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
     checkUnboxedStringLitPat lit
@@ -1723,7 +1575,7 @@ checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
 checkUnboxedStringLitPat (L loc lit) =
   case lit of
     HsStringPrim _ _  -- Trac #13260
-      -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
+      -> addFatalError $ Error (ErrIllegalUnboxedStringInPat lit) [] loc
     _ -> return ()
 
 mkPatRec ::
@@ -1739,7 +1591,7 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
          , pat_args = RecCon (HsRecFields fs dd)
          }
 mkPatRec p _ =
-  addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
+  addFatalError $ Error (ErrInvalidRecordCon (unLoc p)) [] (getLoc 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.
@@ -1770,34 +1622,6 @@ instance DisambTD (HsType GhcPs) where
   mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
   mkUnpackednessPV = addUnpackednessP
 
--- | An accumulator to build a prefix data constructor,
---   e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
---
---  @
---  1. PrefixDataConBuilder []        MkT
---  2. PrefixDataConBuilder [A]       MkT
---  3. PrefixDataConBuilder [A, B]    MkT
---  4. PrefixDataConBuilder [A, B, C] MkT
---  @
---
---  There are two reasons we have a separate builder type instead of using
---  @HsConDeclDetails GhcPs@ directly:
---
---  1. It's faster, because 'OrdList' gives us constant-time snoc.
---  2. Having a separate type helps ensure that we don't forget to finalize a
---     'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
---
---  See Note [PatBuilder] for another builder type used in the parser.
---  Here the technique is similar, but the motivation is different.
-data DataConBuilder
-  = PrefixDataConBuilder
-      (OrdList (LHsType GhcPs))  -- Data constructor fields
-      (Located RdrName)          -- Data constructor name
-  | InfixDataConBuilder
-      (LHsType GhcPs)   -- LHS field
-      (Located RdrName) -- Data constructor name
-      (LHsType GhcPs)   -- RHS field
-
 dataConBuilderCon :: DataConBuilder -> Located RdrName
 dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
 dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
@@ -1818,12 +1642,6 @@ dataConBuilderDetails (PrefixDataConBuilder flds _)
 dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
   = InfixCon (hsLinear lhs) (hsLinear rhs)
 
-instance Outputable DataConBuilder where
-  ppr (PrefixDataConBuilder flds data_con) =
-    hang (ppr data_con) 2 (sep (map ppr (toList flds)))
-  ppr (InfixDataConBuilder lhs data_con rhs) =
-    ppr lhs <+> ppr data_con <+> ppr rhs
-
 instance DisambTD DataConBuilder where
   mkHsAppTyHeadPV = tyToDataConBuilder
 
@@ -1837,9 +1655,7 @@ instance DisambTD DataConBuilder where
     panic "mkHsAppTyPV: InfixDataConBuilder"
 
   mkHsAppKindTyPV lhs l_at ki =
-    addFatalError l_at $
-    hang (text "Unexpected kind application in a data/newtype declaration:") 2
-      (ppr lhs <+> text "@" <> ppr ki)
+    addFatalError $ Error (ErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at
 
   mkHsOpTyPV lhs (L l_tc tc) rhs = do
       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
@@ -1849,9 +1665,7 @@ instance DisambTD DataConBuilder where
       l = combineLocs lhs rhs
       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
       check_no_ops (HsOpTy{}) =
-        addError l $
-          hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
-            2 (ppr lhs <+> ppr tc <+> ppr rhs)
+        addError $ Error (ErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l
       check_no_ops _ = return ()
 
   mkUnpackednessPV unpk constr_stuff
@@ -1862,8 +1676,7 @@ instance DisambTD DataConBuilder where
          let l = combineLocs unpk constr_stuff
          return $ L l (InfixDataConBuilder lhs' data_con rhs)
     | otherwise =
-      do addError (getLoc unpk) $
-           text "{-# UNPACK #-} cannot be applied to a data constructor."
+      do addError $ Error ErrUnpackDataCon [] (getLoc unpk)
          return constr_stuff
 
 tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)
@@ -1874,9 +1687,7 @@ tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
   let data_con = L l (getRdrName (tupleDataCon Boxed (length ts)))
   return $ L l (PrefixDataConBuilder (toOL ts) data_con)
 tyToDataConBuilder t =
-  addFatalError (getLoc t) $
-    hang (text "Cannot parse data constructor in a data/newtype declaration:")
-    2 (ppr t)
+  addFatalError $ Error (ErrInvalidDataCon (unLoc t)) [] (getLoc t)
 
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2325,7 +2136,7 @@ checkPrecP
 checkPrecP (L l (_,i)) (L _ ol)
  | 0 <= i, i <= maxPrecedence = pure ()
  | all specialOp ol = pure ()
- | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
+ | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l
   where
     -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
     specialOp op = unLoc op `elem` [ eqTyCon_RDR
@@ -2341,7 +2152,7 @@ mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
   | isRdrDataCon c
   = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp _ (fs,dd)
-  | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
+  | Just dd_loc <- dd = addFatalError $ Error ErrDotsInRecordUpdate [] dd_loc
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
@@ -2405,7 +2216,7 @@ 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 loc (text "Malformed entity string")
+        Nothing         -> addFatalError $ Error ErrMalformedEntityString [] loc
         Just importSpec -> returnSpec importSpec
 
     -- currently, all the other import conventions only support a symbol name in
@@ -2543,20 +2354,12 @@ mkModuleImpExp (L l specname) subs =
             in (\newName
                         -> IEThingWith noExtField (L l newName) pos ies [])
                <$> nameT
-          else addFatalError l
-            (text "Illegal export form (use PatternSynonyms to enable)")
+          else addFatalError $ Error ErrIllegalPatSynExport [] l
   where
     name = ieNameVal specname
     nameT =
       if isVarNameSpace (rdrNameSpace name)
-        then addFatalError l
-              (text "Expecting a type constructor but found a variable,"
-               <+> quotes (ppr name) <> text "."
-              $$ if isSymOcc $ rdrNameOcc name
-                   then text "If" <+> quotes (ppr name)
-                        <+> text "is a type constructor"
-           <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
-                   else empty)
+        then addFatalError $ Error (ErrVarForTyCon name) [] l
         else return $ ieNameFromSpec specname
 
     ieNameVal (ImpExpQcName ln)  = unLoc ln
@@ -2573,8 +2376,7 @@ mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
 mkTypeImpExp name =
   do allowed <- getBit ExplicitNamespacesBit
-     unless allowed $ addError (getLoc name) $
-       text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
+     unless allowed $ addError $ Error ErrIllegalExplicitNamespace [] (getLoc name)
      return (fmap (`setRdrNameSpace` tcClsName) name)
 
 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
@@ -2584,9 +2386,7 @@ checkImportSpec ie@(L _ specs) =
       (l:_) -> importSpecError l
   where
     importSpecError l =
-      addFatalError l
-        (text "Illegal import form, this syntax can only be used to bundle"
-        $+$ text "pattern synonyms with types in module exports.")
+      addFatalError $ Error ErrIllegalImportBundleForm [] l
 
 -- In the correct order
 mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
@@ -2607,53 +2407,21 @@ isImpExpQcWildcard _                = False
 
 warnPrepositiveQualifiedModule :: SrcSpan -> P ()
 warnPrepositiveQualifiedModule span =
-  addWarning Opt_WarnPrepositiveQualifiedModule span msg
-  where
-    msg = text "Found" <+> quotes (text "qualified")
-           <+> text "in prepositive position"
-       $$ text "Suggested fix: place " <+> quotes (text "qualified")
-           <+> text "after the module name instead."
-       $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+  addWarning Opt_WarnPrepositiveQualifiedModule (WarnImportPreQualified span)
 
 failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()
-failOpNotEnabledImportQualifiedPost loc = addError loc msg
-  where
-    msg = text "Found" <+> quotes (text "qualified")
-          <+> text "in postpositive position. "
-      $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
+failOpNotEnabledImportQualifiedPost loc = addError $ Error ErrImportPostQualified [] loc
 
 failOpImportQualifiedTwice :: SrcSpan -> P ()
-failOpImportQualifiedTwice loc = addError loc msg
-  where
-    msg = text "Multiple occurrences of 'qualified'"
+failOpImportQualifiedTwice loc = addError $ Error ErrImportQualifiedTwice [] loc
 
 warnStarIsType :: SrcSpan -> P ()
-warnStarIsType span = addWarning Opt_WarnStarIsType span msg
-  where
-    msg =  text "Using" <+> quotes (text "*")
-           <+> text "(or its Unicode variant) to mean"
-           <+> quotes (text "Data.Kind.Type")
-        $$ text "relies on the StarIsType extension, which will become"
-        $$ text "deprecated in the future."
-        $$ text "Suggested fix: use" <+> quotes (text "Type")
-           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
-
-warnStarBndr :: SrcSpan -> P ()
-warnStarBndr span = addWarning Opt_WarnStarBinder span msg
-  where
-    msg =  text "Found binding occurrence of" <+> quotes (text "*")
-           <+> text "yet StarIsType is enabled."
-        $$ text "NB. To use (or export) this operator in"
-           <+> text "modules with StarIsType,"
-        $$ text "    including the definition module, you must qualify it."
+warnStarIsType span = addWarning Opt_WarnStarIsType (WarnStarIsType span)
 
 failOpFewArgs :: MonadP m => Located RdrName -> m a
 failOpFewArgs (L loc op) =
   do { star_is_type <- getBit StarIsTypeBit
-     ; let msg = too_few $$ starInfo star_is_type op
-     ; addFatalError loc msg }
-  where
-    too_few = text "Operator applied to too few arguments:" <+> ppr op
+     ; addFatalError $ Error (ErrOpFewArgs (StarIsType star_is_type) op) [] loc }
 
 -----------------------------------------------------------------------------
 -- Misc utils
@@ -2661,12 +2429,13 @@ failOpFewArgs (L loc op) =
 data PV_Context =
   PV_Context
     { pv_options :: ParserOpts
-    , pv_hint :: SDoc  -- See Note [Parser-Validator Hint]
+    , pv_hints   :: [Hint]  -- See Note [Parser-Validator Hint]
     }
 
 data PV_Accum =
   PV_Accum
-    { pv_messages :: DynFlags -> Messages
+    { pv_warnings :: Bag Warning
+    , pv_errors   :: Bag Error
     , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
     , pv_comment_q :: [RealLocated AnnotationComment]
     , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
@@ -2709,22 +2478,24 @@ instance Monad PV where
       PV_Failed acc' -> PV_Failed acc'
 
 runPV :: PV a -> P a
-runPV = runPV_msg empty
+runPV = runPV_hints []
 
-runPV_msg :: SDoc -> PV a -> P a
-runPV_msg msg m =
+runPV_hints :: [Hint] -> PV a -> P a
+runPV_hints hints m =
   P $ \s ->
     let
       pv_ctx = PV_Context
         { pv_options = options s
-        , pv_hint = msg }
+        , pv_hints   = hints }
       pv_acc = PV_Accum
-        { pv_messages = messages s
+        { pv_warnings = warnings s
+        , pv_errors   = errors s
         , pv_annotations = annotations s
         , pv_comment_q = comment_q s
         , pv_annotations_comments = annotations_comments s }
       mkPState acc' =
-        s { messages = pv_messages acc'
+        s { warnings = pv_warnings acc'
+          , errors   = pv_errors acc'
           , annotations = pv_annotations acc'
           , comment_q = pv_comment_q acc'
           , annotations_comments = pv_annotations_comments acc' }
@@ -2733,21 +2504,24 @@ runPV_msg msg m =
         PV_Ok acc' a -> POk (mkPState acc') a
         PV_Failed acc' -> PFailed (mkPState acc')
 
-localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
-localPV_msg f m =
-  let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in
+add_hint :: Hint -> 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 srcspan msg =
-    PV $ \ctx acc@PV_Accum{pv_messages=m} ->
-      let msg' = msg $$ pv_hint ctx in
-      PV_Ok acc{pv_messages=appendError srcspan msg' m} ()
-  addWarning option srcspan warning =
-    PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->
-      PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()
-  addFatalError srcspan msg =
-    addError srcspan msg >> PV (const PV_Failed)
+  addError err@(Error e hints loc) =
+    PV $ \ctx acc ->
+      let err' | null (pv_hints ctx) = err
+               | otherwise           = Error 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 ()
+  addFatalError err =
+    addError err >> PV (const PV_Failed)
   getBit ext =
     PV $ \ctx acc ->
       let b = ext `xtest` pExtsBitmap (pv_options ctx) in
@@ -2802,7 +2576,7 @@ We attempt to detect such cases and add a hint to the error messages:
     Possibly caused by a missing 'do'?
 
 The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
-as the 'pv_hint' field 'PV_Context'. When validating in a context other than
+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.
 
@@ -2813,27 +2587,7 @@ hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
 hintBangPat span e = do
     bang_on <- getBit BangPatBit
     unless bang_on $
-      addError span
-        (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
-
-data SumOrTuple b
-  = Sum ConTag Arity (Located b)
-  | Tuple [Located (Maybe (Located b))]
-
-pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
-pprSumOrTuple boxity = \case
-    Sum alt arity e ->
-      parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
-              <+> parClose
-    Tuple xs ->
-      parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
-              <> parClose
-  where
-    ppr_bars n = hsep (replicate n (Outputable.char '|'))
-    (parOpen, parClose) =
-      case boxity of
-        Boxed -> (text "(", text ")")
-        Unboxed -> (text "(#", text "#)")
+      addError $ Error (ErrIllegalBangPattern e) [] span
 
 mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
 
@@ -2848,8 +2602,7 @@ mkSumOrTupleExpr l boxity (Tuple es) =
 mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
     return $ L l (ExplicitSum noExtField alt arity e)
 mkSumOrTupleExpr l Boxed a@Sum{} =
-    addFatalError l (hang (text "Boxed sums not supported:") 2
-                      (pprSumOrTuple Boxed a))
+    addFatalError $ Error (ErrUnsupportedBoxedSumExpr a) [] l
 
 mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
 
@@ -2860,7 +2613,7 @@ mkSumOrTuplePat l boxity (Tuple ps) = do
   where
     toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
     toTupPat (L l p) = case p of
-      Nothing -> addFatalError l (text "Tuple section in pattern context")
+      Nothing -> addFatalError $ Error ErrTupleSectionInPat [] l
       Just p' -> checkLPat p'
 
 -- Sum
@@ -2868,8 +2621,7 @@ mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
    p' <- checkLPat p
    return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))
 mkSumOrTuplePat l Boxed a@Sum{} =
-    addFatalError l (hang (text "Boxed sums not supported:") 2
-                      (pprSumOrTuple Boxed a))
+    addFatalError $ Error (ErrUnsupportedBoxedSumPat a) [] l
 
 mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy x op y =
@@ -2886,7 +2638,3 @@ mkMultTy t = HsExplicitMult t
 starSym :: Bool -> String
 starSym True = "★"
 starSym False = "*"
-
-forallSym :: Bool -> String
-forallSym True = "∀"
-forallSym False = "forall"
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index feb0a32351..47e6756408 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -56,7 +56,6 @@ import GHC.Hs
 
 import GHC.Types.SrcLoc
 import GHC.Driver.Session ( WarningFlag(..) )
-import GHC.Utils.Outputable hiding ( (<>) )
 import GHC.Utils.Panic
 import GHC.Data.Bag
 
@@ -73,6 +72,7 @@ import Data.Coerce
 import qualified Data.Monoid
 
 import GHC.Parser.Lexer
+import GHC.Parser.Errors
 import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))
 
 {- Note [Adding Haddock comments to the syntax tree]
@@ -193,12 +193,9 @@ addHaddockToModule lmod = do
 
 reportHdkWarning :: HdkWarn -> P ()
 reportHdkWarning (HdkWarnInvalidComment (L l _)) =
-  addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $
-    text "A Haddock comment cannot appear in this position and will be ignored."
+  addWarning Opt_WarnInvalidHaddock $ WarnHaddockInvalidPos (mkSrcSpanPs l)
 reportHdkWarning (HdkWarnExtraComment (L l _)) =
-  addWarning Opt_WarnInvalidHaddock l $
-    text "Multiple Haddock comments for a single entity are not allowed." $$
-    text "The extraneous comment will be ignored."
+  addWarning Opt_WarnInvalidHaddock $ WarnHaddockIgnoreMulti l
 
 collectHdkWarnings :: HdkSt -> [HdkWarn]
 collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =
diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs
new file mode 100644
index 0000000000..26795def9f
--- /dev/null
+++ b/compiler/GHC/Parser/Types.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module GHC.Parser.Types
+   ( SumOrTuple(..)
+   , pprSumOrTuple
+   , PatBuilder(..)
+   , DataConBuilder(..)
+   )
+where
+
+import GHC.Prelude
+import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Name.Reader
+import GHC.Hs.Extension
+import GHC.Hs.Lit
+import GHC.Hs.Pat
+import GHC.Hs.Type
+import GHC.Utils.Outputable as Outputable
+import GHC.Data.OrdList
+
+import Data.Foldable
+
+data SumOrTuple b
+  = Sum ConTag Arity (Located b)
+  | Tuple [Located (Maybe (Located b))]
+
+pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
+pprSumOrTuple boxity = \case
+    Sum alt arity e ->
+      parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
+              <+> parClose
+    Tuple xs ->
+      parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
+              <> parClose
+  where
+    ppr_bars n = hsep (replicate n (Outputable.char '|'))
+    (parOpen, parClose) =
+      case boxity of
+        Boxed -> (text "(", text ")")
+        Unboxed -> (text "(#", text "#)")
+
+-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] in
+-- GHC.parser.PostProcess
+data PatBuilder p
+  = PatBuilderPat (Pat p)
+  | PatBuilderPar (Located (PatBuilder p))
+  | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
+  | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
+  | PatBuilderVar (Located RdrName)
+  | PatBuilderOverLit (HsOverLit GhcPs)
+
+instance Outputable (PatBuilder GhcPs) where
+  ppr (PatBuilderPat p) = ppr p
+  ppr (PatBuilderPar (L _ p)) = parens (ppr p)
+  ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
+  ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
+  ppr (PatBuilderVar v) = ppr v
+  ppr (PatBuilderOverLit l) = ppr l
+
+-- | An accumulator to build a prefix data constructor,
+--   e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
+--
+--  @
+--  1. PrefixDataConBuilder []        MkT
+--  2. PrefixDataConBuilder [A]       MkT
+--  3. PrefixDataConBuilder [A, B]    MkT
+--  4. PrefixDataConBuilder [A, B, C] MkT
+--  @
+--
+--  There are two reasons we have a separate builder type instead of using
+--  @HsConDeclDetails GhcPs@ directly:
+--
+--  1. It's faster, because 'OrdList' gives us constant-time snoc.
+--  2. Having a separate type helps ensure that we don't forget to finalize a
+--     'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
+--
+--  See Note [PatBuilder] for another builder type used in the parser.
+--  Here the technique is similar, but the motivation is different.
+data DataConBuilder
+  = PrefixDataConBuilder
+      (OrdList (LHsType GhcPs))  -- Data constructor fields
+      (Located RdrName)          -- Data constructor name
+  | InfixDataConBuilder
+      (LHsType GhcPs)   -- LHS field
+      (Located RdrName) -- Data constructor name
+      (LHsType GhcPs)   -- RHS field
+
+instance Outputable DataConBuilder where
+  ppr (PrefixDataConBuilder flds data_con) =
+    hang (ppr data_con) 2 (sep (map ppr (toList flds)))
+  ppr (InfixDataConBuilder lhs data_con rhs) =
+    ppr lhs <+> ppr data_con <+> ppr rhs
+
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 13978bf4f1..3344c7e3a1 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -57,7 +57,7 @@ import GHC.Types.Name.Reader
 import GHC.Driver.Types
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Monad
-import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )
+import GHC.Parser.PostProcess ( setRdrNameSpace )
 import GHC.Builtin.RebindableNames
 import GHC.Builtin.Types
 import GHC.Types.Name
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 5c56abed90..27f1e20661 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -65,7 +65,10 @@ module GHC.Types.Name.Reader (
         importSpecLoc, importSpecModule, isExplicitItem, bestImport,
 
         -- * Utils for StarIsType
-        starInfo
+        starInfo,
+
+        -- * Utils
+        opIsAt,
   ) where
 
 #include "HsVersions.h"
@@ -1402,3 +1405,7 @@ starInfo star_is_type rdr_name =
       = let fs = occNameFS occName
         in fs == fsLit "*" || fs == fsLit "★"
       | otherwise = False
+
+-- | Indicate if the given name is the "@" operator
+opIsAt :: RdrName -> Bool
+opIsAt e = e == mkUnqual varName (fsLit "@")
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index bad8a8b092..72b469f7d3 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -16,13 +16,12 @@ module GHC.Utils.Error (
         Severity(..),
 
         -- * Messages
-        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
-        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
+        ErrMsg(..),
+        ErrDoc(..), errDoc,
         mapErrDoc,
         WarnMsg, MsgDoc,
         Messages, ErrorMessages, WarningMessages,
         unionMessages,
-        errMsgSpan, errMsgContext,
         errorsFound, isEmptyMessages,
         isWarnMsgFatal,
         warningsToMessages,
@@ -194,7 +193,6 @@ data Severity
 instance ToJson Severity where
   json s = JSString (show s)
 
-
 instance Show ErrMsg where
     show em = errMsgShortString em
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0266513a13..20854a2a29 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -375,7 +375,6 @@ Library
         GHC.Driver.Make
         GHC.Plugins
         GHC.Prelude
-        GHC.Parser.Header
         GHC.Driver.Main
         GHC.Hs.Stats
         GHC.Driver.Types
@@ -399,13 +398,17 @@ Library
         GHC.Settings.IO
         GHC.SysTools.Elf
         GHC.Iface.Tidy
+        GHC.Parser
+        GHC.Parser.Annotation
         GHC.Parser.CharClass
+        GHC.Parser.Errors
+        GHC.Parser.Errors.Ppr
+        GHC.Parser.Header
         GHC.Parser.Lexer
-        GHC.Core.Coercion.Opt
-        GHC.Parser
         GHC.Parser.PostProcess
         GHC.Parser.PostProcess.Haddock
-        GHC.Parser.Annotation
+        GHC.Parser.Types
+        GHC.Core.Coercion.Opt
         GHC.Types.ForeignCall
         GHC.Builtin.Uniques
         GHC.Builtin.Utils
diff --git a/testsuite/tests/parser/should_fail/T8501a.stderr b/testsuite/tests/parser/should_fail/T8501a.stderr
index d85dfc29f9..44431fca77 100644
--- a/testsuite/tests/parser/should_fail/T8501a.stderr
+++ b/testsuite/tests/parser/should_fail/T8501a.stderr
@@ -1,4 +1,5 @@
 
 T8501a.hs:5:3: error:
     Parse error in pattern: rec
+    Possibly caused by a missing 'do'?
     Perhaps you intended to use RecursiveDo
diff --git a/testsuite/tests/parser/should_fail/readFail018.stderr b/testsuite/tests/parser/should_fail/readFail018.stderr
index d07aa622c0..1391d5736c 100644
--- a/testsuite/tests/parser/should_fail/readFail018.stderr
+++ b/testsuite/tests/parser/should_fail/readFail018.stderr
@@ -1,2 +1,2 @@
 
-readFail018.hs:3:1: unterminated `{-'
+readFail018.hs:3:1: error: unterminated `{-' at end of input
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs
index ae344aaf49..5c7cb0eef3 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.hs
+++ b/testsuite/tests/parser/should_run/CountParserDeps.hs
@@ -28,7 +28,7 @@ main = do
   [libdir] <- getArgs
   modules <- parserDeps libdir
   let num = sizeUniqSet modules
-      max_num = 201
+      max_num = 203
       min_num = max_num - 10 -- so that we don't forget to change the number
                              -- when the number of dependencies decreases
   -- putStrLn $ "Found " ++ show num ++ " parser module dependencies"
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index d8176cd644..c6902d48be 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -33,6 +33,7 @@ import GHC.Cmm.Pipeline
 import GHC.Cmm.Parser
 import GHC.Cmm.Info
 import GHC.Cmm
+import GHC.Parser.Errors.Ppr
 import GHC.Unit.Module
 import GHC.Cmm.DebugBlock
 import GHC
@@ -109,7 +110,9 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
     hscEnv <- newHscEnv dflags
 
     -- parse the cmm file and output any warnings or errors
-    ((warningMsgs, errorMsgs), parsedCmm) <- parseCmmFile dflags cmmFile
+    (warnings, errors, parsedCmm) <- parseCmmFile dflags cmmFile
+    let warningMsgs = fmap pprWarning warnings
+        errorMsgs   = fmap pprError errors
 
     -- print parser errors or warnings
     mapM_ (printBagOfErrors dflags) [warningMsgs, errorMsgs]
diff --git a/utils/haddock b/utils/haddock
-Subproject a18c3af7f983f3b6d3cd84093c9079031da5846
+Subproject 7b5972402afad755cd45aaad1a96aac509e9d5d