[Git][ghc/ghc][wip/az/locateda-epa-improve-2023-03-27] EPA: Improve annotation management in getMonoBind
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sat Jul 8 14:26:46 UTC 2023
Alan Zimmerman pushed to branch wip/az/locateda-epa-improve-2023-03-27 at Glasgow Haskell Compiler / GHC
Commits:
695c6584 by Alan Zimmerman at 2023-07-08T15:26:29+01: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.
- - - - -
6 changed files:
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/printer/Test19784.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -95,7 +95,7 @@ module GHC.Parser.Annotation (
setCommentsSrcAnn, setCommentsEpAnnS,
addCommentsToEpAnnS,
addCommentsToEpAnn, setCommentsEpAnn,
- transferAnnsA, commentsOnlyA, commentsOnlyI,
+ transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, commentsOnlyA, commentsOnlyI,
removeCommentsA, removeCommentsI,
placeholderRealSpan,
@@ -1400,6 +1400,18 @@ transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
transferAnnsA (EpAnnS a an cs) (EpAnnS a' an' cs')
= (EpAnnS a mempty emptyComments, EpAnnS a' (an' <> an) (cs' <> cs))
+-- | Transfer comments and trailing items from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferAnnsOnlyA (EpAnnS a an cs) (EpAnnS a' an' cs')
+ = (EpAnnS a mempty cs, EpAnnS a' (an' <> an) cs')
+
+-- | Transfer comments from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferCommentsOnlyA (EpAnnS a an cs) (EpAnnS a' an' cs')
+ = (EpAnnS a an emptyComments, EpAnnS a' an' (cs <> cs'))
+
-- | Remove the exact print annotations payload, leaving only the
-- anchor and comments.
commentsOnlyA :: Monoid ann => EpAnnS ann -> EpAnnS ann
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -576,11 +576,15 @@ 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 (commentsOnlyA loc1) mtchs1] (removeCommentsA 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 =
@@ -595,15 +599,59 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'
go mtchs loc binds doc_decls
= let
- L lm m = head mtchs -- Guaranteed at least one
- (lm',loc') = transferAnnsA lm loc
- in ( L loc' (makeFunBind fun_id1 (mkLocatedList $ reverse (L lm' m:tail mtchs)))
+ 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/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -223,7 +223,7 @@
[])))
(HsParTy
(EpAnn
- (EpaSpan { Test20239.hs:7:50 })
+ (EpaSpan { Test20239.hs:7:50-86 })
(AnnParen
(AnnParens)
(EpaSpan { Test20239.hs:7:50 })
@@ -239,7 +239,7 @@
[])))
(HsFunTy
(EpAnn
- (EpaSpan { Test20239.hs:7:51-60 })
+ (EpaSpan { Test20239.hs:7:51-85 })
(NoEpAnns)
(EpaComments
[]))
@@ -312,7 +312,7 @@
[])))
(HsParTy
(EpAnn
- (EpaSpan { Test20239.hs:7:68 })
+ (EpaSpan { Test20239.hs:7:68-85 })
(AnnParen
(AnnParens)
(EpaSpan { Test20239.hs:7:68 })
@@ -392,7 +392,7 @@
[])))
(HsTupleTy
(EpAnn
- (EpaSpan { Test20239.hs:7:83 })
+ (EpaSpan { Test20239.hs:7:83-84 })
(AnnParen
(AnnParens)
(EpaSpan { Test20239.hs:7:83 })
=====================================
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
}
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -415,7 +415,7 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- EpaSpan _ -> setAcceptSpan False
p <- getPosP
pe0 <- getPriorEndD
- debugM $ "enterAnn:starting:(p,pe,anchor',a) =" ++ show (p, pe0, eloc2str anchor', astId a)
+ debugM $ "enterAnn:starting:(anchor',p,pe,a) =" ++ show (eloc2str anchor', p, pe0, astId a)
debugM $ "enterAnn:anchor_op=" ++ showGhc (anchor_op anchor')
prevAnchor <- getAnchorU
let curAnchor = case anchor' of
@@ -549,7 +549,7 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- Deal with exit from the current anchor
p1 <- getPosP
pe1 <- getPriorEndD
- debugM $ "enterAnn:done:(p,pe,anchor,a) =" ++ show (p1, pe1, eloc2str anchor', astId a')
+ debugM $ "enterAnn:done:(anchor',p,pe,a) =" ++ show (eloc2str anchor', p1, pe1, astId a')
case anchor' of
-- EpaDelta _ _ -> setPriorEndD p1
=====================================
utils/check-exact/Main.hs
=====================================
@@ -99,7 +99,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr007.hs" Nothing
-- "../../testsuite/tests/printer/Ppr008.hs" Nothing
-- "../../testsuite/tests/printer/Ppr009.hs" Nothing
- "../../testsuite/tests/printer/Ppr011.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr011.hs" Nothing
-- "../../testsuite/tests/printer/Ppr012.hs" Nothing
-- "../../testsuite/tests/printer/Ppr013.hs" Nothing
-- "../../testsuite/tests/printer/Ppr014.hs" Nothing
@@ -134,7 +134,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr043.hs" Nothing
-- "../../testsuite/tests/printer/Ppr044.hs" Nothing
-- "../../testsuite/tests/printer/Ppr045.hs" Nothing
- -- "../../testsuite/tests/printer/Ppr046.hs" Nothing
+ "../../testsuite/tests/printer/Ppr046.hs" Nothing
-- "../../testsuite/tests/printer/Ppr048.hs" Nothing
-- "../../testsuite/tests/printer/Ppr049.hs" Nothing
-- "../../testsuite/tests/printer/Ppr050.hs" Nothing
@@ -211,7 +211,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Test20297.hs" Nothing
-- "../../testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.hs" Nothing
-- "../../testsuite/tests/typecheck/should_fail/tcfail181.hs" Nothing
--- cloneT does not need a test, function can be retired
+ -- "../../testsuite/tests/printer/PprBracesSemiDataDecl.hs" Nothing
-- exact = ppr
@@ -593,8 +593,9 @@ changeWhereIn3b _libdir (L l p) = do
de1' = setEntryDP de1 (DifferentLine 2 0)
d2' = setEntryDP d2 (DifferentLine 2 0)
decls' = d2':de1':de0':tdecls
+ -- decls' = de1':de0:tdecls
-- decls' = decls
- debugM $ unlines w
+ -- debugM $ unlines w
-- debugM $ "changeWhereIn3b:de1':" ++ showAst de1'
let p2 = p { hsmodDecls = decls'}
return (L l p2)
@@ -610,6 +611,7 @@ addLocaLDecl1 libdir top = do
let lp = top
(de1:d2:d3:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
+ -- let (de1'',d2') = (de1, d2)
(de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
return ((wrapDecl decl' : d),Nothing)
replaceDecls lp [de1', d2', d3]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/695c6584d8a6c6bbf8f8567451bdfaac05e3e98c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/695c6584d8a6c6bbf8f8567451bdfaac05e3e98c
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/20230708/6c11dd31/attachment-0001.html>
More information about the ghc-commits
mailing list