Commit eeabeb92 authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

Report multiple errors

parent 8dcd00ce
...@@ -57,7 +57,7 @@ module Lexer ( ...@@ -57,7 +57,7 @@ module Lexer (
activeContext, nextIsEOF, activeContext, nextIsEOF,
getLexState, popLexState, pushLexState, getLexState, popLexState, pushLexState,
ExtBits(..), getBit, ExtBits(..), getBit,
addWarning, addWarning, addError,
lexTokenStream, lexTokenStream,
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
commentToAnnotation commentToAnnotation
...@@ -2479,6 +2479,17 @@ mkPStatePure options buf loc = ...@@ -2479,6 +2479,17 @@ mkPStatePure options buf loc =
annotations_comments = [] 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 :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning addWarning option srcspan warning
= P $ \s@PState{messages=m, options=o} -> = P $ \s@PState{messages=m, options=o} ->
......
...@@ -884,7 +884,7 @@ checkDatatypeContext Nothing = return () ...@@ -884,7 +884,7 @@ checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just c) checkDatatypeContext (Just c)
= do allowed <- getBit DatatypeContextsBit = do allowed <- getBit DatatypeContextsBit
unless allowed $ unless allowed $
parseErrorSDoc (getLoc c) addError (getLoc c)
(text "Illegal datatype context (use DatatypeContexts):" (text "Illegal datatype context (use DatatypeContexts):"
<+> pprLHsContext c) <+> pprLHsContext c)
...@@ -921,11 +921,9 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) ...@@ -921,11 +921,9 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
checkRecordSyntax :: Outputable a => Located a -> P (Located a) checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(dL->L loc r) checkRecordSyntax lr@(dL->L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit = do allowed <- getBit TraditionalRecordSyntaxBit
if allowed unless allowed $ addError loc $
then return lr text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r
else parseErrorSDoc loc return lr
(text "Illegal record syntax (use TraditionalRecordSyntax):"
<+> ppr r)
-- | Check if the gadt_constrlist is empty. Only raise parse error for -- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258. -- `data T where` to avoid affecting existing error message, see #8258.
...@@ -933,13 +931,12 @@ checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) ...@@ -933,13 +931,12 @@ checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs])) -> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
if gadtSyntax unless gadtSyntax $ addError span $ vcat
then return gadts [ text "Illegal keyword 'where' in data declaration"
else parseErrorSDoc span $ vcat , text "Perhaps you intended to use GADTs or a similar language"
[ text "Illegal keyword 'where' in data declaration" , text "extension to enable syntax: data T where"
, 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. checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration.
checkTyClHdr :: Bool -- True <=> class header checkTyClHdr :: Bool -- True <=> class header
...@@ -999,7 +996,7 @@ checkBlockArguments expr = case unLoc expr of ...@@ -999,7 +996,7 @@ checkBlockArguments expr = case unLoc expr of
check element = do check element = do
blockArguments <- getBit BlockArgumentsBit blockArguments <- getBit BlockArgumentsBit
unless blockArguments $ unless blockArguments $
parseErrorSDoc (getLoc expr) $ addError (getLoc expr) $
text "Unexpected " <> text element <> text " in function application:" text "Unexpected " <> text element <> text " in function application:"
$$ nest 4 (ppr expr) $$ nest 4 (ppr expr)
$$ text "You could write it with parentheses" $$ text "You could write it with parentheses"
...@@ -1041,7 +1038,7 @@ checkNoDocs msg ty = go ty ...@@ -1041,7 +1038,7 @@ checkNoDocs msg ty = go ty
where where
go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki
go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 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 "Unexpected haddock", quotes (ppr ds)
, text "on", msg, quotes (ppr t) ] , text "on", msg, quotes (ppr t) ]
go _ = pure () go _ = pure ()
...@@ -1288,7 +1285,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr ...@@ -1288,7 +1285,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse | semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit = do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do unless doAndIfThenElse $ do
parseErrorSDoc (combineLocs guardExpr elseExpr) addError (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:" (text "Unexpected semi-colons in conditional:"
$$ nest 4 expr $$ nest 4 expr
$$ text "Perhaps you meant to use DoAndIfThenElse?") $$ text "Perhaps you meant to use DoAndIfThenElse?")
...@@ -2209,10 +2206,9 @@ mkTypeImpExp :: Located RdrName -- TcCls or Var name space ...@@ -2209,10 +2206,9 @@ mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName) -> P (Located RdrName)
mkTypeImpExp name = mkTypeImpExp name =
do allowed <- getBit ExplicitNamespacesBit do allowed <- getBit ExplicitNamespacesBit
if allowed unless allowed $ addError (getLoc name) $
then return (fmap (`setRdrNameSpace` tcClsName) name) text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
else parseErrorSDoc (getLoc name) return (fmap (`setRdrNameSpace` tcClsName) name)
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
checkImportSpec ie@(dL->L _ specs) = checkImportSpec ie@(dL->L _ specs) =
......
{-# 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
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
...@@ -140,3 +140,4 @@ test('strictnessDataCon_B', normal, compile_fail, ['']) ...@@ -140,3 +140,4 @@ test('strictnessDataCon_B', normal, compile_fail, [''])
test('unpack_empty_type', normal, compile_fail, ['']) test('unpack_empty_type', normal, compile_fail, [''])
test('unpack_inside_type', normal, compile_fail, ['']) test('unpack_inside_type', normal, compile_fail, [''])
test('unpack_before_opr', normal, compile_fail, ['']) test('unpack_before_opr', normal, compile_fail, [''])
test('T16270', normal, compile_fail, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment