[Git][ghc/ghc][master] EPA: Better fix for #22919
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 27 17:39:04 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
69fdbece by Alan Zimmerman at 2023-05-27T13:38:45-04:00
EPA: Better fix for #22919
The original fix for #22919 simply removed the ability to match up
prior comments with the first declaration in the file.
Restore it, but add a check that the comment is on a single line, by
ensuring that it comes immediately prior to the next thing (comment or
start of declaration), and that the token preceding it is not on the
same line.
closes #22919
- - - - -
5 changed files:
- compiler/GHC/Parser/Lexer.x
- testsuite/tests/ghc-api/exactprint/Test20239.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3816,14 +3816,19 @@ splitPriorComments
-> ([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)
+ -- True if there is only one line between the earlier and later span,
+ -- And the token preceding the comment is on a different line
+ cmp :: RealSrcSpan -> LEpaComment -> Bool
+ cmp later (L l c)
+ = srcSpanStartLine later - srcSpanEndLine (anchor l) == 1
+ && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (anchor l)
+
+ go :: [LEpaComment] -> RealSrcSpan -> [LEpaComment]
+ -> ([LEpaComment], [LEpaComment])
+ go decl_comments _ [] = ([],decl_comments)
+ go decl_comments r (c@(L l _):cs) = if cmp r c
+ then go (c:decl_comments) (anchor l) cs
+ else (reverse (c:cs), decl_comments)
in
go [] ss prior_comments
@@ -3837,10 +3842,7 @@ allocatePriorComments ss comment_q mheader_comments =
cmp (L l _) = anchor l <= ss
(newAnns,after) = partition cmp comment_q
comment_q'= after
- (prior_comments, decl_comments)
- = case mheader_comments of
- Strict.Nothing -> (reverse newAnns, [])
- _ -> splitPriorComments ss newAnns
+ (prior_comments, decl_comments) = splitPriorComments ss newAnns
in
case mheader_comments of
Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.hs
=====================================
@@ -1,6 +1,7 @@
module Test20239 where
-- | Leading Haddock Comment
+-- Running over two lines
data instance Method PGMigration = MigrationQuery Query
-- ^ Run a query against the database
| MigrationCode (Connection -> IO (Either String ()))
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -15,25 +15,18 @@
[]
(Just
((,)
- { Test20239.hs:8:1 }
- { Test20239.hs:7:34-63 })))
+ { Test20239.hs:9:1 }
+ { Test20239.hs:8:34-63 })))
(EpaCommentsBalanced
+ []
[(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 }
+ { Test20239.hs:8:34-63 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- ^ Run any arbitrary IO code")
- { Test20239.hs:6:86 }))]))
+ { Test20239.hs:7:86 }))]))
(VirtualBraces
(1))
(Nothing)
@@ -47,12 +40,27 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { Test20239.hs:(4,1)-(6,86) }
+ { Test20239.hs:(5,1)-(7,86) }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
- [])) { Test20239.hs:(4,1)-(6,86) })
+ [(L
+ (Anchor
+ { Test20239.hs:3:1-28 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- | Leading Haddock Comment")
+ { Test20239.hs:1:18-22 }))
+ ,(L
+ (Anchor
+ { Test20239.hs:4:1-25 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Running over two lines")
+ { Test20239.hs:3:1-28 }))])) { Test20239.hs:(5,1)-(7,86) })
(InstD
(NoExtField)
(DataFamInstD
@@ -61,40 +69,40 @@
(FamEqn
(EpAnn
(Anchor
- { Test20239.hs:(4,1)-(6,86) }
+ { Test20239.hs:(5,1)-(7,86) }
(UnchangedAnchor))
- [(AddEpAnn AnnData (EpaSpan { Test20239.hs:4:1-4 }))
- ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:4:6-13 }))
- ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:4:34 }))]
+ [(AddEpAnn AnnData (EpaSpan { Test20239.hs:5:1-4 }))
+ ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:5:6-13 }))
+ ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:5:34 }))]
(EpaComments
[(L
(Anchor
- { Test20239.hs:5:34-70 }
+ { Test20239.hs:6:34-70 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- ^ Run a query against the database")
- { Test20239.hs:4:51-55 }))]))
+ { Test20239.hs:5:51-55 }))]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:15-20 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:15-20 })
(Unqual
{OccName: Method}))
(HsOuterImplicit
(NoExtField))
[(HsValArg
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:22-32 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:4:22-32 }
+ { Test20239.hs:5:22-32 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:22-32 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:22-32 })
(Unqual
{OccName: PGMigration})))))]
(Prefix)
@@ -108,23 +116,23 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { Test20239.hs:4:36-55 }
+ { Test20239.hs:5:36-55 }
(UnchangedAnchor))
(AnnListItem
[(AddVbarAnn
- (EpaSpan { Test20239.hs:6:34 }))])
+ (EpaSpan { Test20239.hs:7:34 }))])
(EpaComments
- [])) { Test20239.hs:4:36-55 })
+ [])) { Test20239.hs:5:36-55 })
(ConDeclH98
(EpAnn
(Anchor
- { Test20239.hs:4:36-55 }
+ { Test20239.hs:5:36-55 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:36-49 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:36-49 })
(Unqual
{OccName: MigrationQuery}))
(False)
@@ -142,33 +150,33 @@
(NoTokenLoc)
(HsNormalTok))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:51-55 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:4:51-55 }
+ { Test20239.hs:5:51-55 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:4:51-55 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:5:51-55 })
(Unqual
{OccName: Query})))))])
(Nothing)))
,(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-86 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:36-86 })
(ConDeclH98
(EpAnn
(Anchor
- { Test20239.hs:6:36-86 }
+ { Test20239.hs:7:36-86 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:36-48 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:36-48 })
(Unqual
{OccName: MigrationCode}))
(False)
@@ -186,24 +194,24 @@
(NoTokenLoc)
(HsNormalTok))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:50-86 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:50-86 })
(HsParTy
(EpAnn
(Anchor
- { Test20239.hs:6:50 }
+ { Test20239.hs:7:50 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
- (EpaSpan { Test20239.hs:6:50 })
- (EpaSpan { Test20239.hs:6:86 }))
+ (EpaSpan { Test20239.hs:7:50 })
+ (EpaSpan { Test20239.hs:7:86 }))
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-85 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:51-85 })
(HsFunTy
(EpAnn
(Anchor
- { Test20239.hs:6:51-60 }
+ { Test20239.hs:7:51-60 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -211,104 +219,104 @@
(HsUnrestrictedArrow
(L
(TokenLoc
- (EpaSpan { Test20239.hs:6:62-63 }))
+ (EpaSpan { Test20239.hs:7:62-63 }))
(HsNormalTok)))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:51-60 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:6:51-60 }
+ { Test20239.hs:7:51-60 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:51-60 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:51-60 })
(Unqual
{OccName: Connection}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-85 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:65-85 })
(HsAppTy
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:65-66 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:6:65-66 }
+ { Test20239.hs:7:65-66 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:65-66 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:65-66 })
(Unqual
{OccName: IO}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:68-85 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:68-85 })
(HsParTy
(EpAnn
(Anchor
- { Test20239.hs:6:68 }
+ { Test20239.hs:7:68 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
- (EpaSpan { Test20239.hs:6:68 })
- (EpaSpan { Test20239.hs:6:85 }))
+ (EpaSpan { Test20239.hs:7:68 })
+ (EpaSpan { Test20239.hs:7:85 }))
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-84 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:69-84 })
(HsAppTy
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-81 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:69-81 })
(HsAppTy
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:69-74 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:6:69-74 }
+ { Test20239.hs:7:69-74 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:69-74 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:69-74 })
(Unqual
{OccName: Either}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:76-81 })
(HsTyVar
(EpAnn
(Anchor
- { Test20239.hs:6:76-81 }
+ { Test20239.hs:7:76-81 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(NotPromoted)
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:76-81 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:76-81 })
(Unqual
{OccName: String}))))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:6:83-84 })
+ (SrcSpanAnn (EpAnnNotUsed) { Test20239.hs:7:83-84 })
(HsTupleTy
(EpAnn
(Anchor
- { Test20239.hs:6:83 }
+ { Test20239.hs:7:83 }
(UnchangedAnchor))
(AnnParen
(AnnParens)
- (EpaSpan { Test20239.hs:6:83 })
- (EpaSpan { Test20239.hs:6:84 }))
+ (EpaSpan { Test20239.hs:7:83 })
+ (EpaSpan { Test20239.hs:7:84 }))
(EpaComments
[]))
(HsBoxedOrConstraintTuple)
@@ -318,5 +326,5 @@
-Test20239.hs:4:15: [GHC-76037]
+Test20239.hs:5:15: [GHC-76037]
Not in scope: type constructor or class ‘Method’
=====================================
testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
=====================================
@@ -25,15 +25,7 @@
(EpaComment
(EpaLineComment
"-- leading comments")
- { ZeroWidthSemi.hs:1:22-26 }))
- ,(L
- (Anchor
- { ZeroWidthSemi.hs:5:1-19 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- Function comment")
- { ZeroWidthSemi.hs:3:1-19 }))]
+ { ZeroWidthSemi.hs:1:22-26 }))]
[(L
(Anchor
{ ZeroWidthSemi.hs:8:1-58 }
@@ -60,7 +52,14 @@
(AnnListItem
[])
(EpaComments
- [])) { ZeroWidthSemi.hs:6:1-5 })
+ [(L
+ (Anchor
+ { ZeroWidthSemi.hs:5:1-19 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Function comment")
+ { ZeroWidthSemi.hs:3:1-19 }))])) { ZeroWidthSemi.hs:6:1-5 })
(ValD
(NoExtField)
(FunBind
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -34,23 +34,7 @@
(EpaComment
(EpaBlockComment
"{-/n Block comment at the beginning/n -}")
- { DumpParsedAstComments.hs:1:1-28 }))
- ,(L
- (Anchor
- { DumpParsedAstComments.hs:7:1-20 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- comment 1 for bar")
- { DumpParsedAstComments.hs:5:30-34 }))
- ,(L
- (Anchor
- { DumpParsedAstComments.hs:8:1-20 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- comment 2 for bar")
- { DumpParsedAstComments.hs:7:1-20 }))]
+ { DumpParsedAstComments.hs:1:1-28 }))]
[]))
(VirtualBraces
(1))
@@ -70,7 +54,23 @@
(AnnListItem
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:9:1-7 })
+ [(L
+ (Anchor
+ { DumpParsedAstComments.hs:7:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 1 for bar")
+ { DumpParsedAstComments.hs:5:30-34 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:8:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 2 for bar")
+ { DumpParsedAstComments.hs:7:1-20
+ }))])) { DumpParsedAstComments.hs:9:1-7 })
(ValD
(NoExtField)
(FunBind
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69fdbece5f6ca0a718bb9f1fef7b0ab57cf6b664
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69fdbece5f6ca0a718bb9f1fef7b0ab57cf6b664
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230527/551c1653/attachment-0001.html>
More information about the ghc-commits
mailing list