Report multiple errorswip/trac-16270

5 files changed, 96 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) =
diff --git a/testsuite/tests/parser/should_fail/T16270.hs b/testsuite/tests/parser/should_fail/T16270.hs
new file mode 100644
index 0000000000..fa788c2eb0
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T16270.hs
@@ -0,0 +1,29 @@
+{-# 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
+--
+-- :(
+
+c = do
+  if c then
+    False
+  else
+    True
+
+f = id do { 1 }
+g = id \x -> x
+
+data Num a => D a
+
+data Pair a b = Pair { fst :: a, snd :: b }
+t = p { fst = 1, snd = True }
+
+z = if True; then (); else ();
+
+data G a where
diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr
new file mode 100644
index 0000000000..7877a28751
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T16270.stderr
@@ -0,0 +1,38 @@
+
+T16270.hs:14:6: error:
+    Unexpected semi-colons in conditional:
+        if c then False; else True
+    Perhaps you meant to use DoAndIfThenElse?
+
+T16270.hs:19: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:
+    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:
+    Illegal datatype context (use DatatypeContexts): Num a =>
+
+T16270.hs:24:22: error:
+    Illegal record syntax (use TraditionalRecordSyntax): {fst :: a,
+                                                          snd :: b}
+
+T16270.hs:25:5: error:
+    Illegal record syntax (use TraditionalRecordSyntax): p {fst = 1,
+                                                            snd = True}
+
+T16270.hs:27:8: error:
+    Unexpected semi-colons in conditional:
+        if True; then (); else ()
+    Perhaps you meant to use DoAndIfThenElse?
+
+T16270.hs:29: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
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 2d7c241ed0..62ff1df665 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -140,3 +140,4 @@ test('strictnessDataCon_B', normal, compile_fail, [''])
 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, [''])