From 6a848bd21c9c54f47c309887ded8c15578bb2aba Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 21 Dec 2021 13:00:28 +0000 Subject: Fix panic trying to -ddump-parsed-ast for implicit fixity A declaration such as infixr ++++ is supplied with an implicit fixity of 9 in the parser, but uses an invalid SrcSpan to capture this. Use of this span triggers a panic. Fix the problem by not recording an exact print annotation for the non-existent fixity source. Closes #20846 --- compiler/GHC/Parser.y | 22 ++- testsuite/tests/parser/should_compile/T20846.hs | 4 + .../tests/parser/should_compile/T20846.stderr | 155 +++++++++++++++++++++ testsuite/tests/parser/should_compile/all.T | 3 +- testsuite/tests/printer/Makefile | 5 + testsuite/tests/printer/Test20846.hs | 3 + testsuite/tests/printer/all.T | 1 + 7 files changed, 185 insertions(+), 8 deletions(-) create mode 100644 testsuite/tests/parser/should_compile/T20846.hs create mode 100644 testsuite/tests/parser/should_compile/T20846.stderr create mode 100644 testsuite/tests/printer/Test20846.hs diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index d768ef2d04..b7c2655f36 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1158,10 +1158,10 @@ impspec :: { Located (Bool, LocatedL [LIE GhcPs]) } ----------------------------------------------------------------------------- -- Fixity Declarations -prec :: { Located (SourceText,Int) } - : {- empty -} { noLoc (NoSourceText,9) } +prec :: { Maybe (Located (SourceText,Int)) } + : {- empty -} { Nothing } | INTEGER - { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) } + { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) } infix :: { Located FixityDirection } : 'infix' { sL1 $1 InfixN } @@ -2552,10 +2552,18 @@ sigdecl :: { LHsDecl GhcPs } ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }} | infix prec ops - {% checkPrecP $2 $3 >> - acsA (\cs -> sLL $1 $> $ SigD noExtField - (FixSig (EpAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3) - (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) } + {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3 + ; pure (mj AnnVal l2) }) + $2 + ; let (fixText, fixPrec) = case $2 of + -- If an explicit precedence isn't supplied, + -- it defaults to maxPrecedence + Nothing -> (NoSourceText, maxPrecedence) + Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) + ; acsA (\cs -> sLL $1 $> $ SigD noExtField + (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3) + (Fixity fixText fixPrec (unLoc $1))))) + }} | pattern_synonym_sig { sL1 $1 . SigD noExtField . unLoc $ $1 } diff --git a/testsuite/tests/parser/should_compile/T20846.hs b/testsuite/tests/parser/should_compile/T20846.hs new file mode 100644 index 0000000000..7d67ce73b4 --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20846.hs @@ -0,0 +1,4 @@ +module T20846 where + +infixr ++++ +(++++) = undefined diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr new file mode 100644 index 0000000000..f68526360d --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20846.stderr @@ -0,0 +1,155 @@ + +==================== Parser AST ==================== + +(L + { T20846.hs:1:1 } + (HsModule + (EpAnn + (Anchor + { T20846.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnModule (EpaSpan { T20846.hs:1:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T20846.hs:1:15-19 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (EpaCommentsBalanced + [] + [(L + (Anchor + { T20846.hs:5:1 } + (UnchangedAnchor)) + (EpaComment + (EpaEofComment) + { T20846.hs:5:1 }))])) + (VirtualBraces + (1)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:1:8-13 }) + {ModuleName: T20846})) + (Nothing) + [] + [(L + (SrcSpanAnn (EpAnn + (Anchor + { T20846.hs:3:1-11 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [])) { T20846.hs:3:1-11 }) + (SigD + (NoExtField) + (FixSig + (EpAnn + (Anchor + { T20846.hs:3:1-6 } + (UnchangedAnchor)) + [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))] + (EpaComments + [])) + (FixitySig + (NoExtField) + [(L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:3:8-11 }) + (Unqual + {OccName: ++++}))] + {Fixity: infixr 9})))) + ,(L + (SrcSpanAnn (EpAnn + (Anchor + { T20846.hs:4:1-18 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [])) { T20846.hs:4:1-18 }) + (ValD + (NoExtField) + (FunBind + (NoExtField) + (L + (SrcSpanAnn (EpAnn + (Anchor + { T20846.hs:4:1-6 } + (UnchangedAnchor)) + (NameAnn + (NameParens) + (EpaSpan { T20846.hs:4:1 }) + (EpaSpan { T20846.hs:4:2-5 }) + (EpaSpan { T20846.hs:4:6 }) + []) + (EpaComments + [])) { T20846.hs:4:1-6 }) + (Unqual + {OccName: ++++})) + (MG + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:1-18 }) + [(L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:1-18 }) + (Match + (EpAnn + (Anchor + { T20846.hs:4:1-18 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (FunRhs + (L + (SrcSpanAnn (EpAnn + (Anchor + { T20846.hs:4:1-6 } + (UnchangedAnchor)) + (NameAnn + (NameParens) + (EpaSpan { T20846.hs:4:1 }) + (EpaSpan { T20846.hs:4:2-5 }) + (EpaSpan { T20846.hs:4:6 }) + []) + (EpaComments + [])) { T20846.hs:4:1-6 }) + (Unqual + {OccName: ++++})) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + (EpaComments + []) + [(L + (SrcSpanAnn + (EpAnnNotUsed) + { T20846.hs:4:8-18 }) + (GRHS + (EpAnn + (Anchor + { T20846.hs:4:8-18 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddEpAnn AnnEqual (EpaSpan { T20846.hs:4:8 }))) + (EpaComments + [])) + [] + (L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:10-18 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:10-18 }) + (Unqual + {OccName: undefined}))))))] + (EmptyLocalBinds + (NoExtField)))))]) + (FromSource)) + [])))] + (Nothing) + (Nothing))) diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index 5f81a651c3..8820d7545a 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -180,4 +180,5 @@ test('T19521', normal, compile, ['']) test('T20186', normal, compile, ['']) test('T20452', normal, compile, ['']) -test('DumpSemis', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) +test('DumpSemis', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) +test('T20846', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) \ No newline at end of file diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 95364cc563..749315c60a 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -743,3 +743,8 @@ Test20258: Test20297: $(CHECK_PPR) $(LIBDIR) Test20297.hs $(CHECK_EXACT) $(LIBDIR) Test20297.hs + +.PHONY: Test20846 +Test20846: + $(CHECK_PPR) $(LIBDIR) Test20846.hs + $(CHECK_EXACT) $(LIBDIR) Test20846.hs diff --git a/testsuite/tests/printer/Test20846.hs b/testsuite/tests/printer/Test20846.hs new file mode 100644 index 0000000000..6a5bd48d59 --- /dev/null +++ b/testsuite/tests/printer/Test20846.hs @@ -0,0 +1,3 @@ +module Test20846 where + +infixr ++++ diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 18ba7ca5d7..3d7c28e453 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -175,3 +175,4 @@ test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['Ppr test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243']) test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258']) test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297']) +test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846']) -- cgit v1.2.1