Report multiple errors

2 files changed, 28 insertions, 21 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index c4d0d4d127..0606c56297 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -57,7 +57,7 @@ module Lexer (
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..), getBit,
-   addWarning,
+   addWarning, addError,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
    commentToAnnotation
@@ -2479,6 +2479,17 @@ mkPStatePure options buf loc =
       annotations_comments = []
     }
 
+addError :: SrcSpan -> SDoc -> P ()
+addError srcspan msg
+ = P $ \s@PState{messages=m} ->
+       let
+           m' d =
+               let (ws, es) = m d
+                   errormsg = mkErrMsg d srcspan alwaysQualify msg
+                   es' = es `snocBag` errormsg
+               in (ws, es')
+       in POk s{messages=m'} ()
+
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=m, options=o} ->
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 45fc5a0972..6a756544d9 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -884,7 +884,7 @@ checkDatatypeContext Nothing = return ()
 checkDatatypeContext (Just c)
     = do allowed <- getBit DatatypeContextsBit
          unless allowed $
-             parseErrorSDoc (getLoc c)
+             addError (getLoc c)
                  (text "Illegal datatype context (use DatatypeContexts):"
                   <+> pprLHsContext c)
 
@@ -921,11 +921,9 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
 checkRecordSyntax lr@(dL->L loc r)
     = do allowed <- getBit TraditionalRecordSyntaxBit
-         if allowed
-             then return lr
-             else parseErrorSDoc loc
-                   (text "Illegal record syntax (use TraditionalRecordSyntax):"
-                    <+> ppr r)
+         unless allowed $ addError loc $
+           text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
+         return lr
 
 -- | Check if the gadt_constrlist is empty. Only raise parse error for
 -- `data T where` to avoid affecting existing error message, see #8258.
@@ -933,13 +931,12 @@ checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                 -> P (Located ([AddAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(dL->L span (_, []))           -- Empty GADT declaration.
     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
-         if gadtSyntax
-            then return gadts
-            else parseErrorSDoc 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 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"
+           ]
+         return gadts
 checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.
 
 checkTyClHdr :: Bool               -- True  <=> class header
@@ -999,7 +996,7 @@ checkBlockArguments expr = case unLoc expr of
     check element = do
       blockArguments <- getBit BlockArgumentsBit
       unless blockArguments $
-        parseErrorSDoc (getLoc expr) $
+        addError (getLoc expr) $
           text "Unexpected " <> text element <> text " in function application:"
            $$ nest 4 (ppr expr)
            $$ text "You could write it with parentheses"
@@ -1041,7 +1038,7 @@ checkNoDocs msg ty = go ty
   where
     go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
     go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
-    go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
+    go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep
                                   [ text "Unexpected haddock", quotes (ppr ds)
                                   , text "on", msg, quotes (ppr t) ]
     go _ = pure ()
@@ -1288,7 +1285,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse
     = do doAndIfThenElse <- getBit DoAndIfThenElseBit
          unless doAndIfThenElse $ do
-             parseErrorSDoc (combineLocs guardExpr elseExpr)
+             addError (combineLocs guardExpr elseExpr)
                             (text "Unexpected semi-colons in conditional:"
                           $$ nest 4 expr
                           $$ text "Perhaps you meant to use DoAndIfThenElse?")
@@ -2209,10 +2206,9 @@ mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
 mkTypeImpExp name =
   do allowed <- getBit ExplicitNamespacesBit
-     if allowed
-       then return (fmap (`setRdrNameSpace` tcClsName) name)
-       else parseErrorSDoc (getLoc name)
-              (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
+     unless allowed $ addError (getLoc name) $
+       text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
+     return (fmap (`setRdrNameSpace` tcClsName) name)
 
 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
 checkImportSpec ie@(dL->L _ specs) =