[Git][ghc/ghc][master] EPA: Improve annotation management in getMonoBind
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jul 19 07:37:00 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
9c8fdda3 by Alan Zimmerman at 2023-07-19T03:36:29-04:00
EPA: Improve annotation management in getMonoBind
Ensure the LHsDecl for a FunBind has the correct leading comments and
trailing annotations.
See the added note for details.
- - - - -
4 changed files:
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test19784.hs
Changes:
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -82,7 +82,8 @@ module GHC.Parser.Annotation (
-- ** Working with comments in annotations
noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
addCommentsToEpAnn, setCommentsEpAnn,
- transferAnnsA, commentsOnlyA, removeCommentsA,
+ transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, commentsOnlyA,
+ removeCommentsA,
placeholderRealSpan,
) where
@@ -1154,6 +1155,26 @@ transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to
(SrcSpanAnn (EpAnn a an' cs') loc)
-> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc
+-- | Transfer trailing items from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferAnnsOnlyA (SrcSpanAnn EpAnnNotUsed l) ss2
+ = (SrcSpanAnn EpAnnNotUsed l, ss2)
+transferAnnsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn EpAnnNotUsed l')
+ = (SrcSpanAnn (EpAnn a mempty cs) l, SrcSpanAnn (EpAnn (spanAsAnchor l') an emptyComments) l')
+transferAnnsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn (EpAnn a' an' cs') l')
+ = (SrcSpanAnn (EpAnn a mempty cs) l, SrcSpanAnn (EpAnn a' (an' <> an) cs') l')
+
+-- | Transfer comments from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferCommentsOnlyA (SrcSpanAnn EpAnnNotUsed l) ss2
+ = (SrcSpanAnn EpAnnNotUsed l, ss2)
+transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn EpAnnNotUsed l')
+ = (SrcSpanAnn (EpAnn a an emptyComments ) l, SrcSpanAnn (EpAnn (spanAsAnchor l') mempty cs) l')
+transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn (EpAnn a' an' cs') l')
+ = (SrcSpanAnn (EpAnn a an emptyComments) l, SrcSpanAnn (EpAnn a' an' (cs <> cs')) l')
+
-- | Remove the exact print annotations payload, leaving only the
-- anchor and comments.
commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -587,11 +587,14 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))
binds
| has_args m1
- = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []
+ = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds []
where
- go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
- -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
- -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ
+ -- See Note [Exact Print Annotations for FunBind]
+ go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun
+ -> SrcSpanAnnA -- current top level loc
+ -> [LHsDecl GhcPs] -- Any docbinds seen
+ -> [LHsDecl GhcPs] -- rest of decls to be processed
+ -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls
go mtchs loc
((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
, fun_matches =
@@ -605,13 +608,61 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
= let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
- = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))
- , (reverse doc_decls) ++ binds)
+ = let
+ L llm last_m = head mtchs -- Guaranteed at least one
+ (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing
+
+ matches' = reverse (L llm' last_m:tail mtchs)
+ L lfm first_m = head matches'
+ (lfm', loc'') = transferCommentsOnlyA lfm loc'
+ in
+ ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches')))
+ , (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments
getMonoBind bind binds = (bind, binds)
+{- Note [Exact Print Annotations for FunBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+An individual Match that ends up in a FunBind MatchGroup is initially
+parsed as a LHsDecl. This takes the form
+
+ L loc (ValD NoExtField (FunBind ... [L lm (Match ..)]))
+
+The loc contains the annotations, in particular comments, which are to
+precede the declaration when printed, and [TrailingAnn] which are to
+follow it. The [TrailingAnn] captures semicolons that may appear after
+it when using the braces and semis style of coding.
+
+The match location (lm) has only a location in it at this point, no
+annotations. Its location is the same as the top level location in
+loc.
+
+What getMonoBind does it to take a sequence of FunBind LHsDecls that
+belong to the same function and group them into a single function with
+the component declarations all combined into the single MatchGroup as
+[LMatch GhcPs].
+
+Given that when exact printing a FunBind the exact printer simply
+iterates over all the matches and prints each in turn, the simplest
+behaviour would be to simply take the top level annotations (loc) for
+each declaration, and use them for the individual component matches
+(lm).
+
+The problem is the exact printer first has to deal with the top level
+LHsDecl, which means annotations for the loc. This needs to be able to
+be exact printed in the context of surrounding declarations, and if
+some refactor decides to move the declaration elsewhere, the leading
+comments and trailing semicolons need to be handled at that level.
+
+So the solution is to combine all the matches into one, pushing the
+annotations into the LMatch's, and then at the end extract the
+comments from the first match and [TrailingAnn] from the last to go in
+the top level LHsDecl.
+-}
+
-- Group together adjacent FunBinds for every function.
getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
getMonoBindAll [] = []
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1349,7 +1349,12 @@
{ DumpSemis.hs:32:1-7 }
(UnchangedAnchor))
(AnnListItem
- [])
+ [(AddSemiAnn
+ (EpaSpan { DumpSemis.hs:33:1 }))
+ ,(AddSemiAnn
+ (EpaSpan { DumpSemis.hs:34:6 }))
+ ,(AddSemiAnn
+ (EpaSpan { DumpSemis.hs:34:7 }))])
(EpaComments
[])) { DumpSemis.hs:32:1-7 })
(ValD
@@ -1370,12 +1375,7 @@
{ DumpSemis.hs:32:1-7 }
(UnchangedAnchor))
(AnnListItem
- [(AddSemiAnn
- (EpaSpan { DumpSemis.hs:33:1 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:6 }))
- ,(AddSemiAnn
- (EpaSpan { DumpSemis.hs:34:7 }))])
+ [])
(EpaComments
[])) { DumpSemis.hs:32:1-7 })
(Match
@@ -1707,7 +1707,8 @@
{ DumpSemis.hs:(36,1)-(44,4) }
(UnchangedAnchor))
(AnnListItem
- [])
+ [(AddSemiAnn
+ (EpaSpan { DumpSemis.hs:45:1 }))])
(EpaComments
[])) { DumpSemis.hs:(36,1)-(44,4) })
(ValD
@@ -1728,8 +1729,7 @@
{ DumpSemis.hs:(36,1)-(44,4) }
(UnchangedAnchor))
(AnnListItem
- [(AddSemiAnn
- (EpaSpan { DumpSemis.hs:45:1 }))])
+ [])
(EpaComments
[])) { DumpSemis.hs:(36,1)-(44,4) })
(Match
@@ -2100,5 +2100,3 @@
(NoExtField)))))]))))))]
(EmptyLocalBinds
(NoExtField)))))])))))]))
-
-
=====================================
testsuite/tests/printer/Test19784.hs
=====================================
@@ -2,4 +2,9 @@ module Test19784 where
{
a 0 = 1;
a _ = 2;
+
+-- c0
+b 0 = 1; -- c1
+b 1 = 2; -- c2
+b 2 = 3; -- c3
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c8fdda3458a72be9ea90d45ab379444ab0cfb30
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c8fdda3458a72be9ea90d45ab379444ab0cfb30
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/20230719/4721111c/attachment-0001.html>
More information about the ghc-commits
mailing list