diff options
-rw-r--r-- | compiler/parser/Lexer.x | 13 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 36 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T16270.hs | 29 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T16270.stderr | 38 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/all.T | 1 |
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, ['']) |