From 5dab36f354cab645133d9743867e4fa5401acad0 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 21 May 2022 18:53:24 +0100 Subject: EPA: Comment Order Reversed Make sure comments captured in the exact print annotations are in order of increasing location Closes #20718 (cherry picked from commit e2520df3fffa0cf22fb19c5fb872832d11c07d35) --- compiler/GHC/Parser/Lexer.x | 24 ++- compiler/GHC/Parser/PostProcess.hs | 2 +- .../should_compile/DumpParsedAstComments.stderr | 12 +- testsuite/tests/parser/should_compile/T20718.hs | 11 ++ .../tests/parser/should_compile/T20718.stderr | 162 +++++++++++++++++++++ testsuite/tests/parser/should_compile/T20718b.hs | 7 + .../tests/parser/should_compile/T20718b.stderr | 70 +++++++++ testsuite/tests/parser/should_compile/all.T | 3 + 8 files changed, 270 insertions(+), 21 deletions(-) create mode 100644 testsuite/tests/parser/should_compile/T20718.hs create mode 100644 testsuite/tests/parser/should_compile/T20718.stderr create mode 100644 testsuite/tests/parser/should_compile/T20718b.hs create mode 100644 testsuite/tests/parser/should_compile/T20718b.stderr diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 82a5b9bb38..f3a3109c42 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -3009,7 +3009,7 @@ instance MonadP P where POk s { header_comments = header_comments', comment_q = comment_q' - } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getCommentsFor (RealSrcSpan l _) = allocateCommentsP l @@ -3554,7 +3554,7 @@ allocateComments ss comment_q = comment_q' = before ++ after newAnns = middle in - (comment_q', newAnns) + (comment_q', reverse newAnns) allocatePriorComments :: RealSrcSpan @@ -3569,24 +3569,20 @@ allocatePriorComments ss comment_q mheader_comments = comment_q'= after in case mheader_comments of - Strict.Nothing -> (Strict.Just newAnns, comment_q', []) - Strict.Just _ -> (mheader_comments, comment_q', newAnns) + Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', []) + Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns) allocateFinalComments :: RealSrcSpan -> [LEpaComment] -> Strict.Maybe [LEpaComment] -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) -allocateFinalComments ss comment_q mheader_comments = - let - cmp (L l _) = anchor l <= ss - (before,after) = partition cmp comment_q - newAnns = after - comment_q'= before - in - case mheader_comments of - Strict.Nothing -> (Strict.Just newAnns, [], comment_q') - Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns) +allocateFinalComments _ss comment_q mheader_comments = + -- We ignore the RealSrcSpan as the parser currently provides a + -- point span at (1,1). + case mheader_comments of + Strict.Nothing -> (Strict.Just (reverse comment_q), [], []) + Strict.Just _ -> (mheader_comments, [], reverse comment_q) commentToAnnotation :: RealLocated Token -> LEpaComment commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index b9bd342dba..92afef026b 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2967,7 +2967,7 @@ instance MonadP PV where PV_Ok s { pv_header_comments = header_comments', pv_comment_q = comment_q' - } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) {- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr index 34d759a794..f25f99cd32 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr @@ -21,20 +21,20 @@ (EpaCommentsBalanced [(L (Anchor - { DumpParsedAstComments.hs:(2,1)-(4,4) } + { DumpParsedAstComments.hs:1:1-28 } (UnchangedAnchor)) (EpaComment (EpaBlockComment - "{-/n Block comment at the beginning/n -}") - { DumpParsedAstComments.hs:1:1-28 })) + "{-# LANGUAGE Haskell2010 #-}") + { DumpParsedAstComments.hs:1:1 })) ,(L (Anchor - { DumpParsedAstComments.hs:1:1-28 } + { DumpParsedAstComments.hs:(2,1)-(4,4) } (UnchangedAnchor)) (EpaComment (EpaBlockComment - "{-# LANGUAGE Haskell2010 #-}") - { DumpParsedAstComments.hs:1:1 }))] + "{-/n Block comment at the beginning/n -}") + { DumpParsedAstComments.hs:1:1-28 }))] [(L (Anchor { DumpParsedAstComments.hs:13:1 } diff --git a/testsuite/tests/parser/should_compile/T20718.hs b/testsuite/tests/parser/should_compile/T20718.hs new file mode 100644 index 0000000000..0b1a3e6a0f --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20718.hs @@ -0,0 +1,11 @@ +-- top of file 1 +-- top of file 2 +module T20718 where + +-- before 1 +-- before 2 + +x = 1 + +-- end 1 +-- end 2 diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr new file mode 100644 index 0000000000..c041db260a --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20718.stderr @@ -0,0 +1,162 @@ + +==================== Parser AST ==================== + +(L + { T20718.hs:1:1 } + (HsModule + (EpAnn + (Anchor + { T20718.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnModule (EpaSpan { T20718.hs:3:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T20718.hs:3:15-19 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (EpaCommentsBalanced + [(L + (Anchor + { T20718.hs:1:1-16 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- top of file 1") + { T20718.hs:1:1 })) + ,(L + (Anchor + { T20718.hs:2:1-16 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- top of file 2") + { T20718.hs:1:1-16 })) + ,(L + (Anchor + { T20718.hs:5:1-11 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- before 1") + { T20718.hs:3:15-19 })) + ,(L + (Anchor + { T20718.hs:6:1-11 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- before 2") + { T20718.hs:5:1-11 }))] + [(L + (Anchor + { T20718.hs:12:1 } + (UnchangedAnchor)) + (EpaComment + (EpaEofComment) + { T20718.hs:11:1-8 }))])) + (VirtualBraces + (1)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:3:8-13 }) + {ModuleName: T20718})) + (Nothing) + [] + [(L + (SrcSpanAnn (EpAnn + (Anchor + { T20718.hs:8:1-5 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [(L + (Anchor + { T20718.hs:10:1-8 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- end 1") + { T20718.hs:8:5 })) + ,(L + (Anchor + { T20718.hs:11:1-8 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- end 2") + { T20718.hs:10:1-8 }))])) { T20718.hs:8:1-5 }) + (ValD + (NoExtField) + (FunBind + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1 }) + (Unqual + {OccName: x})) + (MG + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1-5 }) + [(L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1-5 }) + (Match + (EpAnn + (Anchor + { T20718.hs:8:1-5 } + (UnchangedAnchor)) + [] + (EpaComments + [])) + (FunRhs + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1 }) + (Unqual + {OccName: x})) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + (EpaComments + []) + [(L + (SrcSpanAnn + (EpAnnNotUsed) + { T20718.hs:8:3-5 }) + (GRHS + (EpAnn + (Anchor + { T20718.hs:8:3-5 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddEpAnn AnnEqual (EpaSpan { T20718.hs:8:3 }))) + (EpaComments + [])) + [] + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:5 }) + (HsOverLit + (EpAnn + (Anchor + { T20718.hs:8:5 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 1) + (False) + (1))))))))] + (EmptyLocalBinds + (NoExtField)))))]) + (FromSource)) + [])))] + (Nothing) + (Nothing))) diff --git a/testsuite/tests/parser/should_compile/T20718b.hs b/testsuite/tests/parser/should_compile/T20718b.hs new file mode 100644 index 0000000000..9896dd933e --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20718b.hs @@ -0,0 +1,7 @@ +-- header comment 1 +-- header comment 2 + +module T20718b where + +-- trailing comment 1 +-- trailing comment 2 diff --git a/testsuite/tests/parser/should_compile/T20718b.stderr b/testsuite/tests/parser/should_compile/T20718b.stderr new file mode 100644 index 0000000000..d359e5c5cf --- /dev/null +++ b/testsuite/tests/parser/should_compile/T20718b.stderr @@ -0,0 +1,70 @@ + +==================== Parser AST ==================== + +(L + { T20718b.hs:1:1 } + (HsModule + (EpAnn + (Anchor + { T20718b.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnModule (EpaSpan { T20718b.hs:4:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T20718b.hs:4:16-20 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (EpaCommentsBalanced + [(L + (Anchor + { T20718b.hs:1:1-19 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- header comment 1") + { T20718b.hs:1:1 })) + ,(L + (Anchor + { T20718b.hs:2:1-19 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- header comment 2") + { T20718b.hs:1:1-19 })) + ,(L + (Anchor + { T20718b.hs:6:1-21 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- trailing comment 1") + { T20718b.hs:4:16-20 })) + ,(L + (Anchor + { T20718b.hs:7:1-21 } + (UnchangedAnchor)) + (EpaComment + (EpaLineComment + "-- trailing comment 2") + { T20718b.hs:6:1-21 }))] + [(L + (Anchor + { T20718b.hs:8:1 } + (UnchangedAnchor)) + (EpaComment + (EpaEofComment) + { T20718b.hs:7:1-21 }))])) + (VirtualBraces + (1)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { T20718b.hs:4:8-14 }) + {ModuleName: T20718b})) + (Nothing) + [] + [] + (Nothing) + (Nothing))) diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index e5116ffd02..ffadeeaf1c 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -188,3 +188,6 @@ test('T20551', normal, compile, ['']) test('OpaqueParseWarn1', normal, compile, ['']) test('T20385', normal, compile, ['']) test('T20385S', normal, compile, ['']) + +test('T20718', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments']) +test('T20718b', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments']) \ No newline at end of file -- cgit v1.2.1