From 9f3011896aa3dc8cc14bd61ccb68ab09e17c330e Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 11 Dec 2022 13:34:24 +0000
Subject: [PATCH] EPA: When splitting out header comments, keep ones for first
decl
Any comments immediately preceding the first declaration are no longer
kept as header comments, but attach to the first declaration instead.
---
compiler/GHC/Parser/Lexer.x | 26 +++-
.../tests/ghc-api/exactprint/Test20239.stderr | 17 +--
.../should_compile/DumpParsedAstComments.hs | 4 +
.../DumpParsedAstComments.stderr | 112 +++++++++++-------
testsuite/tests/printer/Ppr031.hs | 1 +
5 files changed, 105 insertions(+), 55 deletions(-)
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index a116aec66cdc..dfccebce86d6 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3676,6 +3676,25 @@ allocateComments ss comment_q =
in
(comment_q', reverse newAnns)
+-- Comments appearing without a line-break before the first
+-- declaration are associated with the declaration
+splitPriorComments
+ :: RealSrcSpan
+ -> [LEpaComment]
+ -> ([LEpaComment], [LEpaComment])
+splitPriorComments ss prior_comments =
+ let
+ -- True if there is only one line between the earlier and later span
+ cmp later earlier
+ = srcSpanStartLine later - srcSpanEndLine earlier == 1
+
+ go decl _ [] = ([],decl)
+ go decl r (c@(L l _):cs) = if cmp r (anchor l)
+ then go (c:decl) (anchor l) cs
+ else (reverse (c:cs), decl)
+ in
+ go [] ss prior_comments
+
allocatePriorComments
:: RealSrcSpan
-> [LEpaComment]
@@ -3684,12 +3703,13 @@ allocatePriorComments
allocatePriorComments ss comment_q mheader_comments =
let
cmp (L l _) = anchor l <= ss
- (before,after) = partition cmp comment_q
- newAnns = before
+ (newAnns,after) = partition cmp comment_q
comment_q'= after
+ (prior_comments, decl_comments) = splitPriorComments ss newAnns
in
case mheader_comments of
- Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])
+ Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
+ -- Strict.Nothing -> (Strict.Just [], comment_q', newAnns)
Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)
allocateFinalComments
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
index 2bac5ab5320f..bcbb818b0541 100644
--- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
@@ -19,14 +19,7 @@
[]
[]))
(EpaCommentsBalanced
- [(L
- (Anchor
- { Test20239.hs:3:1-28 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- | Leading Haddock Comment")
- { Test20239.hs:1:18-22 }))]
+ []
[(L
(Anchor
{ Test20239.hs:8:1 }
@@ -53,6 +46,14 @@
[])
(EpaComments
[(L
+ (Anchor
+ { Test20239.hs:3:1-28 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- | Leading Haddock Comment")
+ { Test20239.hs:1:18-22 }))
+ ,(L
(Anchor
{ Test20239.hs:7:34-63 }
(UnchangedAnchor))
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs b/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
index d7c51b23b140..62dc878213cc 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
@@ -4,6 +4,10 @@
-}
module DumpParsedAstComments where
+-- Other comment
+
+-- comment 1 for foo
+-- comment 2 for foo
foo = do
-- normal comment
1
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
index d453ae5de1c4..0f451eeb1498 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
@@ -34,15 +34,23 @@
(UnchangedAnchor))
(EpaComment
(EpaBlockComment
- "{-\n Block comment at the beginning\n -}")
- { DumpParsedAstComments.hs:1:1-28 }))]
+ "{-/n Block comment at the beginning/n -}")
+ { DumpParsedAstComments.hs:1:1-28 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:7:1-16 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Other comment")
+ { DumpParsedAstComments.hs:5:30-34 }))]
[(L
(Anchor
- { DumpParsedAstComments.hs:13:1 }
+ { DumpParsedAstComments.hs:17:1 }
(UnchangedAnchor))
(EpaComment
(EpaEofComment)
- { DumpParsedAstComments.hs:13:1 }))]))
+ { DumpParsedAstComments.hs:17:1 }))]))
(VirtualBraces
(1))
(Nothing)
@@ -56,47 +64,63 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,1)-(9,3) }
+ { DumpParsedAstComments.hs:(11,1)-(13,3) }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:11:1-20 }
+ { DumpParsedAstComments.hs:9:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 1 for foo")
+ { DumpParsedAstComments.hs:7:1-16 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:10:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 2 for foo")
+ { DumpParsedAstComments.hs:9:1-20 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:15:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- | Haddock comment")
- { DumpParsedAstComments.hs:9:3
- }))])) { DumpParsedAstComments.hs:(7,1)-(9,3) })
+ { DumpParsedAstComments.hs:13:3
+ }))])) { DumpParsedAstComments.hs:(11,1)-(13,3) })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
(Unqual
{OccName: foo}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
})
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
})
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,1)-(9,3) }
+ { DumpParsedAstComments.hs:(11,1)-(13,3) }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
(Unqual
{OccName: foo}))
(Prefix)
@@ -108,72 +132,72 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:(7,5)-(9,3) })
+ { DumpParsedAstComments.hs:(11,5)-(13,3) })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,5)-(9,3) }
+ { DumpParsedAstComments.hs:(11,5)-(13,3) }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:7:5 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:11:5 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,7)-(9,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,7)-(13,3)
})
(HsDo
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(7,7)-(9,3) }
+ { DumpParsedAstComments.hs:(11,7)-(13,3) }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
- [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:7:7-8 }))]
+ [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:11:7-8 }))]
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:8:3-19 }
+ { DumpParsedAstComments.hs:12:3-19 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- normal comment")
- { DumpParsedAstComments.hs:7:7-8 }))]))
+ { DumpParsedAstComments.hs:11:7-8 }))]))
(DoExpr
(Nothing))
(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
[]
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:9:3 })
+ [])) { DumpParsedAstComments.hs:13:3 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
(BodyStmt
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
(HsOverLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:9:3 }
+ { DumpParsedAstComments.hs:13:3 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -192,37 +216,37 @@
,(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:1-23 }
+ { DumpParsedAstComments.hs:16:1-23 }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:12:1-23 })
+ [])) { DumpParsedAstComments.hs:16:1-23 })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
(Unqual
{OccName: main}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:1-23 }
+ { DumpParsedAstComments.hs:16:1-23 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
(Unqual
{OccName: main}))
(Prefix)
@@ -234,42 +258,42 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:12:6-23 })
+ { DumpParsedAstComments.hs:16:6-23 })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:6-23 }
+ { DumpParsedAstComments.hs:16:6-23 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:12:6 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:16:6 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-23 })
(HsApp
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:8-23 }
+ { DumpParsedAstComments.hs:16:8-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
(HsVar
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
(Unqual
{OccName: putStrLn}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:17-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:17-23 })
(HsLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:12:17-23 }
+ { DumpParsedAstComments.hs:16:17-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
diff --git a/testsuite/tests/printer/Ppr031.hs b/testsuite/tests/printer/Ppr031.hs
index b31896a9fce2..78396c4220cc 100644
--- a/testsuite/tests/printer/Ppr031.hs
+++ b/testsuite/tests/printer/Ppr031.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}
+
spec :: Spec
spec = do
describe "split4'8" $ do
--
GitLab