[Git][ghc/ghc][master] EPA: Capture all comments in a ClassDecl
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Apr 9 12:53:00 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
be3bddde by Alan Zimmerman at 2024-04-09T08:52:26-04:00
EPA: Capture all comments in a ClassDecl
Hopefully the final fix needed for #24533
- - - - -
3 changed files:
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Test24533.hs
- testsuite/tests/printer/Test24533.stdout
Changes:
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -942,11 +942,10 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
- chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))
+ chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))
= let
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- lcs = epAnnComments l
- lt' = setCommentsEpAnn lt lcs
+ (_,lt') = transferCommentsOnlyA l lt
in
chkParens (o:ops) (c:cps) bvis (L lt' ty)
chkParens ops cps bvis ty = chk ops cps bvis ty
@@ -1053,7 +1052,7 @@ checkTyClHdr :: Bool -- True <=> class header
checkTyClHdr is_cls ty
= goL ty [] [] [] Prefix
where
- goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix
+ goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
-- workaround to define '*' despite StarIsType
go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
@@ -1071,11 +1070,11 @@ checkTyClHdr is_cls ty
rhs = HsValArg noExtField t2
go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
where
- (o,c) = mkParensEpAnn (realSrcSpan l)
+ (o,c) = mkParensEpAnn (realSrcSpan (locA l))
go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
- = return (L (noAnnSrcSpan l) (nameRdrName tup_name)
+ = return (L (l2l l) (nameRdrName tup_name)
, map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
where
arity = length ts
@@ -1083,17 +1082,17 @@ checkTyClHdr is_cls ty
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
go l _ _ _ _ _
- = addFatalError $ mkPlainErrorMsgEnvelope l $
+ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrMalformedTyOrClDecl ty)
-- Combine the annotations from the HsParTy and HsStarTy into a
-- new one for the LocatedN RdrName
- newAnns :: SrcSpan -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
- newAnns l (EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =
+ newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN
+ newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =
let
- lr = combineSrcSpans (RealSrcSpan (anchor ap) Strict.Nothing) l
+ lr = combineSrcSpans (locA l1) (locA l)
in
- EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) csp
+ EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) (csp0 Semi.<> csp)
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
=====================================
testsuite/tests/printer/Test24533.hs
=====================================
@@ -7,7 +7,9 @@ instance
) =>
Read (a, b)
-class Foo (a :: Type {- Weird -})
+{- Weird before -}
+class {- Weird0 -} Foo {- Weird1 -} ({- Weird2 -} a {- Weird3 -} :: {- Weird4 -} Type {- Weird5 -}) {- Weird6 -}
+{- Weird after -}
instance Eq Foo where
-- Weird
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -13,8 +13,8 @@
[]
(Just
((,)
- { Test24533.hs:15:1 }
- { Test24533.hs:14:16-19 })))
+ { Test24533.hs:17:1 }
+ { Test24533.hs:16:16-19 })))
(EpaCommentsBalanced
[(L
(EpaSpan
@@ -276,22 +276,42 @@
(Nothing)))))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:10:1-33 })
+ (EpaSpan { Test24533.hs:11:1-99 })
(AnnListItem
[])
(EpaComments
- []))
+ [(L
+ (EpaSpan
+ { Test24533.hs:10:1-18 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird before -}")
+ { Test24533.hs:8:13 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:7-18 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird0 -}")
+ { Test24533.hs:11:1-5 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:24-35 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird1 -}")
+ { Test24533.hs:11:20-22 }))]))
(TyClD
(NoExtField)
(ClassDecl
((,,)
- [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:10:1-5 }))]
+ [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:11:1-5 }))]
(EpNoLayout)
(NoAnnSortKey))
(Nothing)
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:7-9 })
+ (EpaSpan { Test24533.hs:11:20-22 })
(NameAnnTrailing
[])
(EpaComments
@@ -302,26 +322,47 @@
(NoExtField)
[(L
(EpAnn
- (EpaSpan { Test24533.hs:10:11-33 })
+ (EpaSpan { Test24533.hs:11:37-99 })
(AnnListItem
[])
(EpaComments
[(L
(EpaSpan
- { Test24533.hs:10:22-32 })
+ { Test24533.hs:11:38-49 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird2 -}")
+ { Test24533.hs:11:37 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:87-98 })
(EpaComment
(EpaBlockComment
- "{- Weird -}")
- { Test24533.hs:10:17-20 }))]))
+ "{- Weird5 -}")
+ { Test24533.hs:11:82-85 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:53-64 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird3 -}")
+ { Test24533.hs:11:51 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:69-80 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird4 -}")
+ { Test24533.hs:11:66-67 }))]))
(KindedTyVar
- [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:10:11 }))
- ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:10:33 }))
- ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:10:14-15 }))]
+ [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:11:37 }))
+ ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:11:99 }))
+ ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:11:66-67 }))]
(HsBndrRequired
(NoExtField))
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:12 })
+ (EpaSpan { Test24533.hs:11:51 })
(NameAnnTrailing
[])
(EpaComments
@@ -330,7 +371,7 @@
{OccName: a}))
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:17-20 })
+ (EpaSpan { Test24533.hs:11:82-85 })
(AnnListItem
[])
(EpaComments
@@ -340,7 +381,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:10:17-20 })
+ (EpaSpan { Test24533.hs:11:82-85 })
(NameAnnTrailing
[])
(EpaComments
@@ -357,17 +398,31 @@
[])))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:(12,1)-(14,19) })
+ (EpaSpan { Test24533.hs:(14,1)-(16,19) })
(AnnListItem
[])
(EpaComments
[(L
(EpaSpan
- { Test24533.hs:13:3-10 })
+ { Test24533.hs:15:3-10 })
(EpaComment
(EpaLineComment
"-- Weird")
- { Test24533.hs:12:17-21 }))]))
+ { Test24533.hs:14:17-21 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:11:101-112 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird6 -}")
+ { Test24533.hs:11:99 }))
+ ,(L
+ (EpaSpan
+ { Test24533.hs:12:1-17 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird after -}")
+ { Test24533.hs:11:101-112 }))]))
(InstD
(NoExtField)
(ClsInstD
@@ -375,12 +430,12 @@
(ClsInstDecl
((,,)
(Nothing)
- [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:12:1-8 }))
- ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:12:17-21 }))]
+ [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:14:1-8 }))
+ ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:14:17-21 }))]
(NoAnnSortKey))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-15 })
+ (EpaSpan { Test24533.hs:14:10-15 })
(AnnListItem
[])
(EpaComments
@@ -391,7 +446,7 @@
(NoExtField))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-15 })
+ (EpaSpan { Test24533.hs:14:10-15 })
(AnnListItem
[])
(EpaComments
@@ -400,7 +455,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-11 })
+ (EpaSpan { Test24533.hs:14:10-11 })
(AnnListItem
[])
(EpaComments
@@ -410,7 +465,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:10-11 })
+ (EpaSpan { Test24533.hs:14:10-11 })
(NameAnnTrailing
[])
(EpaComments
@@ -419,7 +474,7 @@
{OccName: Eq}))))
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:13-15 })
+ (EpaSpan { Test24533.hs:14:13-15 })
(AnnListItem
[])
(EpaComments
@@ -429,7 +484,7 @@
(NotPromoted)
(L
(EpAnn
- (EpaSpan { Test24533.hs:12:13-15 })
+ (EpaSpan { Test24533.hs:14:13-15 })
(NameAnnTrailing
[])
(EpaComments
@@ -439,7 +494,7 @@
{Bag(LocatedA (HsBind GhcPs)):
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnListItem
[])
(EpaComments
@@ -448,7 +503,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:7-8 })
+ (EpaSpan { Test24533.hs:16:7-8 })
(NameAnnTrailing
[])
(EpaComments
@@ -459,7 +514,7 @@
(FromSource)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnList
(Nothing)
(Nothing)
@@ -470,7 +525,7 @@
[]))
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-19 })
+ (EpaSpan { Test24533.hs:16:3-19 })
(AnnListItem
[])
(EpaComments
@@ -480,7 +535,7 @@
(FunRhs
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:7-8 })
+ (EpaSpan { Test24533.hs:16:7-8 })
(NameAnnTrailing
[])
(EpaComments
@@ -491,7 +546,7 @@
(NoSrcStrict))
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-5 })
+ (EpaSpan { Test24533.hs:16:3-5 })
(AnnListItem
[])
(EpaComments
@@ -500,7 +555,7 @@
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:3-5 })
+ (EpaSpan { Test24533.hs:16:3-5 })
(NameAnnTrailing
[])
(EpaComments
@@ -512,7 +567,7 @@
[])))
,(L
(EpAnn
- (EpaSpan { Test24533.hs:14:10-12 })
+ (EpaSpan { Test24533.hs:16:10-12 })
(AnnListItem
[])
(EpaComments
@@ -521,7 +576,7 @@
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:10-12 })
+ (EpaSpan { Test24533.hs:16:10-12 })
(NameAnnTrailing
[])
(EpaComments
@@ -536,22 +591,22 @@
[])
[(L
(EpAnn
- (EpaSpan { Test24533.hs:14:14-19 })
+ (EpaSpan { Test24533.hs:16:14-19 })
(NoEpAnns)
(EpaComments
[]))
(GRHS
(EpAnn
- (EpaSpan { Test24533.hs:14:14-19 })
+ (EpaSpan { Test24533.hs:16:14-19 })
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:14:14 })))
+ (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:16:14 })))
(EpaComments
[]))
[]
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:16-19 })
+ (EpaSpan { Test24533.hs:16:16-19 })
(AnnListItem
[])
(EpaComments
@@ -560,7 +615,7 @@
(NoExtField)
(L
(EpAnn
- (EpaSpan { Test24533.hs:14:16-19 })
+ (EpaSpan { Test24533.hs:16:16-19 })
(NameAnnTrailing
[])
(EpaComments
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be3bdddebdf119007d753bebe32709a1ce726cc0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be3bdddebdf119007d753bebe32709a1ce726cc0
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/20240409/440cf9b9/attachment-0001.html>
More information about the ghc-commits
mailing list