Fix warnings and fatal parsing errorswip/parse-errors

18 files changed, 194 insertions, 151 deletions

diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index e10d6d1..d7763f7 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -82,8 +82,7 @@ doBackpack [src_filename] = do
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
     case unP parseBackpack (mkPState dflags buf loc) of
-        PFailed _ span err -> do
-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
+        PFailed pst -> throwErrors (getErrorMessages pst dflags)
         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/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
index 821c0a6..a04c4ad 100644
--- a/compiler/cmm/CmmMonad.hs
+++ b/compiler/cmm/CmmMonad.hs
@@ -50,7 +50,7 @@ thenPD :: PD a -> (a -> PD b) -> PD b
 (PD m) `thenPD` k = PD $ \d s ->
         case m d s of
                 POk s1 a         -> unPD (k a) d s1
-                PFailed warnFn span err -> PFailed warnFn span err
+                PFailed s1 -> PFailed s1
 
 failPD :: String -> PD a
 failPD = liftP . fail
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index e580368..bb389d1 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1424,11 +1424,8 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
   case unPD cmmParse dflags init_state of
-    PFailed warnFn span err -> do
-        let msg = mkPlainErrMsg dflags span err
-            errMsgs = (emptyBag, unitBag msg)
-            warnMsgs = warnFn dflags
-        return (unionMessages warnMsgs errMsgs, Nothing)
+    PFailed pst ->
+        return (getMessages pst dflags, Nothing)
     POk pst code -> do
         st <- initC
         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index ac97f17..9ee6856 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -22,6 +22,7 @@ module ErrUtils (
         errMsgSpan, errMsgContext,
         errorsFound, isEmptyMessages,
         isWarnMsgFatal,
+        warningsToMessages,
 
         -- ** Formatting
         pprMessageBag, pprErrMsgBagWithLoc,
@@ -359,6 +360,15 @@ isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
 errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
+warningsToMessages :: DynFlags -> WarningMessages -> Messages
+warningsToMessages dflags =
+  partitionBagWith $ \warn ->
+    case isWarnMsgFatal dflags warn of
+      Nothing -> Left warn
+      Just err_reason ->
+        Right warn{ errMsgSeverity = SevError
+                  , errMsgReason = ErrReason err_reason }
+
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle dflags unqual
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index a1cc4a7..9e58f35 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -337,7 +337,7 @@ import Annotations
 import Module
 import Panic
 import Platform
-import Bag              ( listToBag, unitBag )
+import Bag              ( listToBag )
 import ErrUtils
 import MonadUtils
 import Util
@@ -1363,9 +1363,9 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
-    PFailed _ span err ->
+    PFailed pst ->
         do dflags <- getDynFlags
-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           throwErrors (getErrorMessages pst dflags)
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1376,9 +1376,9 @@ getRichTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
-    PFailed _ span err ->
+    PFailed pst ->
         do dflags <- getDynFlags
-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           throwErrors (getErrorMessages pst dflags)
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1553,9 +1553,9 @@ parser str dflags filename =
    in
    case unP Parser.parseModule (mkPState dflags buf loc) of
 
-     PFailed warnFn span err   ->
-         let (warns,_) = warnFn dflags in
-         (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
+     PFailed pst ->
+         let (warns,errs) = getMessages pst dflags in
+         (warns, Left errs)
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst dflags in
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 3fd510b..450ac95 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -66,9 +66,9 @@ getImports :: DynFlags
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
   case unP parseHeader (mkPState dflags buf loc) of
-    PFailed _ span err -> do
+    PFailed pst -> do
         -- assuming we're not logging warnings here as per below
-      parseError dflags span err
+      throwErrors (getErrorMessages pst dflags)
     POk pst rdr_module -> do
       let _ms@(_warns, errs) = getMessages pst dflags
       -- don't log warnings: they'll be reported when we parse the file
@@ -136,9 +136,6 @@ mkPrelImports this_mod loc implicit_prelude import_decls
                                 ideclAs        = Nothing,
                                 ideclHiding    = Nothing  }
 
-parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
-parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
-
 --------------------------------------------------------------
 -- Get options
 --------------------------------------------------------------
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9a4dd4a..5bc0f38 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -233,9 +233,15 @@ logWarningsReportErrors (warns,errs) = do
     logWarnings warns
     when (not $ isEmptyBag errs) $ throwErrors errs
 
--- | Throw some errors.
-throwErrors :: ErrorMessages -> Hsc a
-throwErrors = liftIO . throwIO . mkSrcErr
+-- | 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
+    logWarnings warns
+    dflags <- getDynFlags
+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
+    liftIO $ printBagOfErrors dflags wWarns
+    throwErrors (unionBags errs wErrs)
 
 -- | Deal with errors and warnings returned by a compilation step
 --
@@ -341,19 +347,18 @@ hscParse' mod_summary
                  | otherwise = parseModule
 
     case unP parseMod (mkPState dflags buf loc) of
-        PFailed warnFn span err -> do
-            logWarningsReportErrors (warnFn dflags)
-            handleWarnings
-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
-
+        PFailed pst ->
+            handleWarningsThrowErrors (getMessages pst dflags)
         POk pst rdr_module -> do
-            logWarningsReportErrors (getMessages pst dflags)
+            let (warns, errs) = getMessages pst dflags
+            logWarnings warns
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
                                    ppr rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
                                    showAstData NoBlankSrcSpan rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
                                    ppSourceStats False rdr_module
+            when (not $ isEmptyBag errs) $ throwErrors errs
 
             -- To get the list of extra source files, we take the list
             -- that the parser gave us,
@@ -1022,7 +1027,7 @@ checkSafeImports tcg_env
         | imv_is_safe v1 /= imv_is_safe v2
         = do
             dflags <- getDynFlags
-            throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
+            throwOneError $ mkPlainErrMsg dflags (imv_span v1)
               (text "Module" <+> ppr (imv_name v1) <+>
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
@@ -1088,7 +1093,7 @@ hscCheckSafe' m l = do
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
-            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
+            Nothing -> throwOneError $ mkPlainErrMsg dflags l
                          $ text "Can't load the interface file for" <+> ppr m
                            <> text ", to check that it can be safely imported"
 
@@ -1759,7 +1764,7 @@ hscParseExpr expr = do
   maybe_stmt <- hscParseStmt expr
   case maybe_stmt of
     Just (L _ (BodyStmt _ expr _ _)) -> return expr
-    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+    _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
       (text "not an expression:" <+> quotes (text expr))
 
 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
@@ -1793,11 +1798,8 @@ hscParseThingWithLocation source linenumber parser str
         loc = mkRealSrcLoc (fsLit source) linenumber 1
 
     case unP parser (mkPState dflags buf loc) of
-        PFailed warnFn span err -> do
-            logWarningsReportErrors (warnFn dflags)
-            handleWarnings
-            let msg = mkPlainErrMsg dflags span err
-            throwErrors $ unitBag msg
+        PFailed pst -> do
+            handleWarningsThrowErrors (getMessages pst dflags)
 
         POk pst thing -> do
             logWarningsReportErrors (getMessages pst dflags)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index d17fa5f..0ca7bda 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -133,7 +133,7 @@ module HscTypes (
 
         -- * Compilation errors and warnings
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
-        throwOneError, handleSourceError,
+        throwOneError, throwErrors, handleSourceError,
         handleFlagWarnings, printOrThrowWarnings,
 
         -- * COMPLETE signature
@@ -278,8 +278,11 @@ srcErrorMessages (SourceError msgs) = msgs
 mkApiErr :: DynFlags -> SDoc -> GhcApiError
 mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
 
-throwOneError :: MonadIO m => ErrMsg -> m ab
-throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
+throwErrors :: MonadIO io => ErrorMessages -> io a
+throwErrors = liftIO . throwIO . mkSrcErr
+
+throwOneError :: MonadIO io => ErrMsg -> io a
+throwOneError = throwErrors . unitBag
 
 -- | A source error is an error that is caused by one or more errors in the
 -- source code.  A 'SourceError' is thrown by many functions in the
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 4e6d26b..5ff1b03 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -816,14 +816,14 @@ isStmt :: DynFlags -> String -> Bool
 isStmt dflags stmt =
   case parseThing Parser.parseStmt dflags stmt of
     Lexer.POk _ _ -> True
-    Lexer.PFailed _ _ _ -> False
+    Lexer.PFailed _ -> False
 
 -- | Returns @True@ if passed string has an import declaration.
 hasImport :: DynFlags -> String -> Bool
 hasImport dflags stmt =
   case parseThing Parser.parseModule dflags stmt of
     Lexer.POk _ thing -> hasImports thing
-    Lexer.PFailed _ _ _ -> False
+    Lexer.PFailed _ -> False
   where
     hasImports = not . null . hsmodImports . unLoc
 
@@ -832,7 +832,7 @@ isImport :: DynFlags -> String -> Bool
 isImport dflags stmt =
   case parseThing Parser.parseImport dflags stmt of
     Lexer.POk _ _ -> True
-    Lexer.PFailed _ _ _ -> False
+    Lexer.PFailed _ -> False
 
 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
 isDecl :: DynFlags -> String -> Bool
@@ -842,7 +842,7 @@ isDecl dflags stmt = do
       case unLoc thing of
         SpliceD _ _ -> False
         _ -> True
-    Lexer.PFailed _ _ _ -> False
+    Lexer.PFailed _ -> False
 
 parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
 parseThing parser dflags stmt = do
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9eed1e6..b7d8fb8 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -51,13 +51,13 @@ module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
    P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
    getRealSrcLoc, getPState, withThisPackage,
-   failLocMsgP, failSpanMsgP, srcParseFail,
-   getMessages,
+   failLocMsgP, srcParseFail,
+   getErrorMessages, getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..), getBit,
-   addWarning, addError,
+   addWarning, addError, addFatalError,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
    commentToAnnotation
@@ -977,7 +977,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 failSpanMsgP (RealSrcSpan span) (text "Missing block")
+              else addFatalError (RealSrcSpan span) (text "Missing block")
 
 pop_and :: Action -> Action
 pop_and act span buf len = do _ <- popLexState
@@ -1925,15 +1925,9 @@ data LayoutContext
 
 data ParseResult a
   = POk PState a
-  | PFailed
-        (DynFlags -> Messages) -- A function that returns warnings that
-                               -- accumulated during parsing, including
-                               -- the warnings related to tabs.
-        SrcSpan                -- The start and end of the text span related
-                               -- to the error.  Might be used in environments
-                               -- which can show this span, e.g. by
-                               -- highlighting it.
-        MsgDoc                 -- The error message
+  | PFailed PState
+             -- The parsing state right before failure.
+             -- 'getMessages' must return a non-empty bag of errors.
 
 -- | Test whether a 'WarningFlag' is set
 warnopt :: WarningFlag -> ParserFlags -> Bool
@@ -2019,7 +2013,7 @@ instance Monad P where
 #endif
 
 instance MonadFail.MonadFail P where
-  fail = failP
+  fail = failMsgP
 
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
@@ -2028,27 +2022,16 @@ thenP :: P a -> (a -> P b) -> P b
 (P m) `thenP` k = P $ \ s ->
         case m s of
                 POk s1 a         -> (unP (k a)) s1
-                PFailed warnFn span err -> PFailed warnFn span err
-
-failP :: String -> P a
-failP msg =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
+                PFailed s1 -> PFailed s1
 
 failMsgP :: String -> P a
-failMsgP msg =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (last_loc s)) (text msg)
+failMsgP msg = do
+  pState <- getPState
+  addFatalError (RealSrcSpan (last_loc pState)) (text msg)
 
 failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
 failLocMsgP loc1 loc2 str =
-  P $ \s ->
-    PFailed (getMessages s) (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
-
-failSpanMsgP :: SrcSpan -> SDoc -> P a
-failSpanMsgP span msg =
-  P $ \s ->
-    PFailed (getMessages s) span msg
+  addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
 
 getPState :: P PState
 getPState = P $ \s -> POk s s
@@ -2488,6 +2471,10 @@ addError srcspan msg
                in (ws, es')
        in POk s{messages=m'} ()
 
+addFatalError :: SrcSpan -> SDoc -> P a
+addFatalError span msg =
+  addError span msg >> P PFailed
+
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=m, options=o} ->
@@ -2522,6 +2509,10 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d =
   in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
                  mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
 
+getErrorMessages :: PState -> DynFlags -> ErrorMessages
+getErrorMessages PState{messages=m} d =
+  let (_, es) = m d in es
+
 getMessages :: PState -> DynFlags -> Messages
 getMessages p@PState{messages=m} d =
   let (ws, es) = m d
@@ -2542,7 +2533,7 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
         (_:tl) ->
           POk s{ context = tl } ()
         []     ->
-          PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
+          unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
 
 -- Push a new layout context at the indentation of the last token read.
 pushCurrentContext :: GenSemic -> P ()
@@ -2602,7 +2593,7 @@ srcParseErr options buf len
 srcParseFail :: P a
 srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
                             last_loc = last_loc } ->
-    PFailed (getMessages s) (RealSrcSpan last_loc) (srcParseErr o buf len)
+    unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
 
 -- A lexical error is reported at a particular position in the source file,
 -- not over a token range.
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 69114ee..78f1013 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -973,13 +973,13 @@ maybe_safe :: { ([AddAnn],Bool) }
         | {- empty -}                           { ([],False) }
 
 maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
-        : STRING  {% let pkgFS = getSTRING $1 in
-                     if looksLikePackageName (unpackFS pkgFS)
-                        then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))
-                        else parseErrorSDoc (getLoc $1) $ vcat [
-                             text "parse error" <> colon <+> quotes (ppr pkgFS),
+        : 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"] }
+                             text "character in package name"]
+                        ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }
         | {- empty -}                           { ([],Nothing) }
 
 optqualified :: { ([AddAnn],Bool) }
@@ -3668,7 +3668,7 @@ 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 failSpanMsgP (getLoc lt) (text err)
+                   then addFatalError (getLoc lt) (text err)
                    else return s
 
 -- Utilities for combining source spans
@@ -3756,23 +3756,15 @@ fileSrcSpan = do
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
   mwiEnabled <- getBit MultiWayIfBit
-  unless mwiEnabled $ parseErrorSDoc span $
+  unless mwiEnabled $ addError span $
     text "Multi-way if-expressions need MultiWayIf turned on"
 
--- Hint about if usage for beginners
-hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs)
-hintIf span msg = do
-  mwiEnabled <- getBit MultiWayIfBit
-  if mwiEnabled
-    then parseErrorSDoc span $ text $ "parse error in if statement"
-    else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
-
 -- Hint about explicit-forall
 hintExplicitForall :: Located Token -> P ()
 hintExplicitForall tok = do
     forall   <- getBit ExplicitForallBit
     rulePrag <- getBit InRulePragBit
-    unless (forall || rulePrag) $ parseErrorSDoc (getLoc tok) $ vcat
+    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:" <+>
@@ -3803,13 +3795,13 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a
 reportEmptyDoubleQuotes span = do
     thQuotes <- getBit ThQuotesBit
     if thQuotes
-      then parseErrorSDoc span $ vcat
+      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 parseErrorSDoc span $ vcat
+      else addFatalError span $ vcat
         [ text "Parser error on `''`"
         , text "Character literals may not be empty"
         ]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index ddbd885..606e2e7 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -60,7 +60,7 @@ module   RdrHsSyn (
         checkRuleTyVarBndrNames,
         checkRecordSyntax,
         checkEmptyGADTs,
-        parseErrorSDoc, hintBangPat,
+        addFatalError, hintBangPat,
         TyEl(..), mergeOps, mergeDataCon,
 
         -- Help with processing exports
@@ -357,7 +357,7 @@ mkRoleAnnotDecl loc tycon roles
             let nearby = fuzzyLookup (unpackFS role)
                   (mapFst unpackFS possible_roles)
             in
-            parseErrorSDoc loc_role
+            addFatalError loc_role
               (text "Illegal role name" <+> quotes (ppr role) $$
                suggestions nearby)
     parse_role _ = panic "parse_role: Impossible Match"
@@ -427,7 +427,7 @@ cvBindsAndSigs fb = go (fromOL fb)
                DocD _ d
                  -> return (bs, ss, ts, tfis, dfis, cL l d : docs)
                SpliceD _ d
-                 -> parseErrorSDoc l $
+                 -> addFatalError l $
                     hang (text "Declaration splices are allowed only" <+>
                           text "at the top level:")
                        2 (ppr d)
@@ -620,23 +620,23 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) =
     fromDecl (dL->L loc decl) = extraDeclErr loc decl
 
     extraDeclErr loc decl =
-        parseErrorSDoc loc $
+        addFatalError loc $
         text "pattern synonym 'where' clause must contain a single binding:" $$
         ppr decl
 
     wrongNameBindingErr loc decl =
-      parseErrorSDoc loc $
+      addFatalError loc $
       text "pattern synonym 'where' clause must bind the pattern synonym's name"
       <+> quotes (ppr patsyn_name) $$ ppr decl
 
     wrongNumberErr loc =
-      parseErrorSDoc loc $
+      addFatalError loc $
       text "pattern synonym 'where' clause cannot be empty" $$
       text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)
 
 recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
 recordPatSynErr loc pat =
-    parseErrorSDoc loc $
+    addFatalError loc $
     text "record syntax not supported for pattern synonym declarations:" $$
     ppr pat
 
@@ -816,7 +816,7 @@ checkTyVarsP pp_what equals_or_where tc tparms
 
 eitherToP :: Either (SrcSpan, SDoc) a -> P a
 -- Adapts the Either monad to the P monad
-eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
+eitherToP (Left (loc, doc)) = addFatalError loc doc
 eitherToP (Right thing)     = return thing
 
 checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
@@ -915,7 +915,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P ()
 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
   where check (dL->L loc (Unqual occ)) = do
           when ((occNameString occ ==) `any` ["forall","family","role"])
-               (parseErrorSDoc loc (text $ "parse error on input "
+               (addFatalError loc (text $ "parse error on input "
                                     ++ occNameString occ))
         check _ = panic "checkRuleTyVarBndrNames"
 
@@ -977,7 +977,7 @@ checkTyClHdr is_cls ty
                  | otherwise = getName (tupleTyCon Boxed arity)
           -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)
     go l _ _ _ _
-      = parseErrorSDoc l (text "Malformed head of type or class declaration:"
+      = addFatalError l (text "Malformed head of type or class declaration:"
                           <+> ppr ty)
 
 -- | Yield a parse error if we have a function applied directly to a do block
@@ -1087,7 +1087,7 @@ checkAPat msg loc e0 = do
    EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
    HsLit _ (HsStringPrim _ _) -- (#13260)
-       -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:"
+       -> addFatalError loc (text "Illegal unboxed string literal in pattern:"
                               $$ ppr e0)
 
    HsLit _ l  -> return (LitPat noExt l)
@@ -1137,7 +1137,7 @@ checkAPat msg loc e0 = do
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
                                            [e | (dL->L _ (Present _ e)) <- es]
                                    return (TuplePat noExt ps b)
-     | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:"
+     | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
                                         $$ ppr e0)
 
    ExplicitSum _ alt arity expr -> do
@@ -1168,7 +1168,7 @@ checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
                                      return (cL l (fld { hsRecFieldArg = p }))
 
 patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
-patFail msg loc e = parseErrorSDoc loc err
+patFail msg loc e = addFatalError loc err
     where err = text "Parse error in pattern:" <+> ppr e
              $$ msg
 
@@ -1250,7 +1250,7 @@ checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
   = return lrdr
 
 checkValSigLhs lhs@(dL->L l _)
-  = parseErrorSDoc l ((text "Invalid type signature:" <+>
+  = addFatalError l ((text "Invalid type signature:" <+>
                        ppr lhs <+> text ":: ...")
                       $$ text hint)
   where
@@ -1482,7 +1482,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
                     bt = HsBangTy noExt strictMark a
               ; addAnnsAt bl anns
               ; return (cL bl bt) }
-      else parseErrorSDoc l unpkError
+      else addFatalError l unpkError
       where
         unpkSDoc = case unpkSrc of
           NoSourceText -> ppr unpk
@@ -1951,9 +1951,9 @@ checkCmdGRHS = locMap $ const convert
 
 
 cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
-cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
+cmdFail loc e = addFatalError loc (text "Parse error in command:" <+> ppr e)
 cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
-cmdStmtFail loc e = parseErrorSDoc loc
+cmdStmtFail loc e = addFatalError loc
                     (text "Parse error in command statement:" <+> ppr e)
 
 ---------------------------------------------------------------------------
@@ -1968,7 +1968,7 @@ checkPrecP
 checkPrecP (dL->L l (_,i)) (dL->L _ ol)
  | 0 <= i, i <= maxPrecedence = pure ()
  | all specialOp ol = pure ()
- | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
+ | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))
   where
     specialOp op = unLoc op `elem` [ eqTyCon_RDR
                                    , getRdrName funTyCon ]
@@ -1983,7 +1983,7 @@ mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
   | isRdrDataCon c
   = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp _ (fs,dd)
-  | Just dd_loc <- dd = parseErrorSDoc dd_loc (text "You cannot use `..' in a record update")
+  | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")
   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
@@ -2051,7 +2051,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 (cL loc esrc) of
-        Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
+        Nothing         -> addFatalError loc (text "Malformed entity string")
         Just importSpec -> returnSpec importSpec
 
     -- currently, all the other import conventions only support a symbol name in
@@ -2189,13 +2189,13 @@ mkModuleImpExp (dL->L l specname) subs =
             in (\newName
                         -> IEThingWith noExt (cL l newName) pos ies [])
                <$> nameT
-          else parseErrorSDoc l
+          else addFatalError l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
     name = ieNameVal specname
     nameT =
       if isVarNameSpace (rdrNameSpace name)
-        then parseErrorSDoc l
+        then addFatalError l
               (text "Expecting a type constructor but found a variable,"
                <+> quotes (ppr name) <> text "."
               $$ if isSymOcc $ rdrNameOcc name
@@ -2230,7 +2230,7 @@ checkImportSpec ie@(dL->L _ specs) =
       (l:_) -> importSpecError l
   where
     importSpecError l =
-      parseErrorSDoc l
+      addFatalError l
         (text "Illegal import form, this syntax can only be used to bundle"
         $+$ text "pattern synonyms with types in module exports.")
 
@@ -2275,39 +2275,36 @@ failOpFewArgs :: Located RdrName -> P a
 failOpFewArgs (dL->L loc op) =
   do { star_is_type <- getBit StarIsTypeBit
      ; let msg = too_few $$ starInfo star_is_type op
-     ; parseErrorSDoc loc msg }
+     ; addFatalError loc msg }
   where
     too_few = text "Operator applied to too few arguments:" <+> ppr op
 
 failOpDocPrev :: SrcSpan -> P a
-failOpDocPrev loc = parseErrorSDoc loc msg
+failOpDocPrev loc = addFatalError loc msg
   where
     msg = text "Unexpected documentation comment."
 
 failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
-failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg
+failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg
   where
     msg = text "Strictness annotation applied to a compound type." $$
           text "Did you mean to add parentheses?" $$
           nest 2 (ppr str <> parens (ppr ty))
 
 failOpStrictnessPosition :: Located SrcStrictness -> P a
-failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg
+failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
   where
     msg = text "Strictness annotation cannot appear in this position."
 
 -----------------------------------------------------------------------------
 -- Misc utils
 
-parseErrorSDoc :: SrcSpan -> SDoc -> P a
-parseErrorSDoc span s = failSpanMsgP span s
-
 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
 hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
 hintBangPat span e = do
     bang_on <- getBit BangPatBit
     unless bang_on $
-      parseErrorSDoc span
+      addFatalError span
         (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
 
 data SumOrTuple
@@ -2323,7 +2320,7 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
 mkSumOrTuple Unboxed _ (Sum alt arity e) =
     return (ExplicitSum noExt alt arity e)
 mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) =
-    parseErrorSDoc l (hang (text "Boxed sums not supported:") 2
+    addFatalError l (hang (text "Boxed sums not supported:") 2
                       (ppr_boxed_sum alt arity e))
   where
     ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
diff --git a/testsuite/tests/parser/should_fail/T16270.hs b/testsuite/tests/parser/should_fail/T16270.hs
index fa788c2..0c5166d 100644
--- a/testsuite/tests/parser/should_fail/T16270.hs
+++ b/testsuite/tests/parser/should_fail/T16270.hs
@@ -1,20 +1,13 @@
-{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse #-}
-
--- module T16270 (type G) where
---
--- ^ Uncommenting this line prevents other errors from printing
--- because HeaderInfo.getImports fails fast on parsing imports:
---
---      if errorsFound dflags ms
---        then throwIO $ mkSrcErr errs
---
--- :(
+{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse, NoMultiWayIf #-}
+{-# OPTIONS -Werror=missing-space-after-bang #-}
+
+module T16270 where
 
 c = do
-  if c then
-    False
-  else
-    True
+	if c then
+		False
+	else
+		True
 
 f = id do { 1 }
 g = id \x -> x
@@ -24,6 +17,20 @@ data Num a => D a
 data Pair a b = Pair { fst :: a, snd :: b }
 t = p { fst = 1, snd = True }
 
+z :: forall a. ()
 z = if True; then (); else ();
 
 data G a where
+
+multiWayIf !i = (a, b)
+  where
+    a = if | i -> True
+           | otherwise -> False
+    b = if | i -> False
+           | otherwise -> True
+
+-- a fatal error.
+k = let
+
+-- not reported, as the previous one was fatal.
+k = let
diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr
index 7877a28..7eccd95 100644
--- a/testsuite/tests/parser/should_fail/T16270.stderr
+++ b/testsuite/tests/parser/should_fail/T16270.stderr
@@ -1,38 +1,61 @@
 
-T16270.hs:14:6: error:
+T16270.hs:7:1: warning: [-Wtabs (in -Wdefault)]
+    Tab character found here, and in five further locations.
+    Please use spaces instead.
+
+T16270.hs:7:12: error:
     Unexpected semi-colons in conditional:
         if c then False; else True
     Perhaps you meant to use DoAndIfThenElse?
 
-T16270.hs:19:8: error:
+T16270.hs:12:8: error:
     Unexpected do block in function application:
         do 1
     You could write it with parentheses
     Or perhaps you meant to enable BlockArguments?
 
-T16270.hs:20:8: error:
+T16270.hs:13:8: error:
     Unexpected lambda expression in function application:
         \ x -> x
     You could write it with parentheses
     Or perhaps you meant to enable BlockArguments?
 
-T16270.hs:22:6: error:
+T16270.hs:15:6: error:
     Illegal datatype context (use DatatypeContexts): Num a =>
 
-T16270.hs:24:22: error:
+T16270.hs:17:22: error:
     Illegal record syntax (use TraditionalRecordSyntax): {fst :: a,
                                                           snd :: b}
 
-T16270.hs:25:5: error:
+T16270.hs:18:5: error:
     Illegal record syntax (use TraditionalRecordSyntax): p {fst = 1,
                                                             snd = True}
 
-T16270.hs:27:8: error:
+T16270.hs:20:6: error:
+    Illegal symbol ‘forall’ in type
+    Perhaps you intended to use RankNTypes or a similar language
+    extension to enable explicit-forall syntax: forall <tvs>. <type>
+
+T16270.hs:21:8: error:
     Unexpected semi-colons in conditional:
         if True; then (); else ()
     Perhaps you meant to use DoAndIfThenElse?
 
-T16270.hs:29:10: error:
+T16270.hs:23:10: error:
     Illegal keyword 'where' in data declaration
     Perhaps you intended to use GADTs or a similar language
     extension to enable syntax: data T where
+
+T16270.hs:25:12: error: [-Wmissing-space-after-bang (in -Wdefault), -Werror=missing-space-after-bang]
+    Did you forget to enable BangPatterns?
+    If you mean to bind (!) then perhaps you want
+    to add a space after the bang for clarity.
+
+T16270.hs:27:9: error:
+    Multi-way if-expressions need MultiWayIf turned on
+
+T16270.hs:29:9: error:
+    Multi-way if-expressions need MultiWayIf turned on
+
+T16270.hs:36:1: error:
+    parse error (possibly incorrect indentation or mismatched brackets)
diff --git a/testsuite/tests/parser/should_fail/T16270h.hs b/testsuite/tests/parser/should_fail/T16270h.hs
new file mode 100644
index 0000000..c44d6ed
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T16270h.hs
@@ -0,0 +1,13 @@
+-- We can't test module header parsing errors using the same file as other
+-- parsing errors (in ../T16270.hs) because HeaderInfo.getImports fails fast
+-- on parsing imports:
+--
+--      if errorsFound dflags ms
+--        then throwIO $ mkSrcErr errs
+--
+module T16270h (type G) where
+
+import "pkg?" M
+import "pkg!" M
+
+data G a
diff --git a/testsuite/tests/parser/should_fail/T16270h.stderr b/testsuite/tests/parser/should_fail/T16270h.stderr
new file mode 100644
index 0000000..fb7fc43
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T16270h.stderr
@@ -0,0 +1,11 @@
+
+T16270h.hs:8:22: error:
+    Illegal keyword 'type' (use ExplicitNamespaces to enable)
+
+T16270h.hs:10:8: error:
+    Parse error: ‘pkg?’
+    Version number or non-alphanumeric character in package name
+
+T16270h.hs:11:8: error:
+    Parse error: ‘pkg!’
+    Version number or non-alphanumeric character in package name
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 1a049bb..aa089de 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -142,3 +142,4 @@ test('unpack_empty_type', normal, compile_fail, [''])
 test('unpack_inside_type', normal, compile_fail, [''])
 test('unpack_before_opr', normal, compile_fail, [''])
 test('T16270', normal, compile_fail, [''])
+test('T16270h', normal, compile_fail, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject 3ee6526d4ae7bf4deb7cd1caf24b3d735557357
+Subproject 8a735d45a15f3b930637e9b9877331c635aedf9