[Git][ghc/ghc][wip/az/T24755-epa-checktyclhdr-comments] EPA: preserve comments in class and data decls
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Fri May 3 18:02:57 UTC 2024
Alan Zimmerman pushed to branch wip/az/T24755-epa-checktyclhdr-comments at Glasgow Haskell Compiler / GHC
Commits:
0f1763a5 by Alan Zimmerman at 2024-05-03T19:02:46+01:00
EPA: preserve comments in class and data decls
Fix checkTyClHdr which was discarding comments.
Closes #24755
- - - - -
4 changed files:
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24755.hs
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -204,11 +204,11 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
- ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
+ = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+ ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
; tyvars <- checkTyVars (text "class") whereDots cls tparams
; let anns' = annsIn Semi.<> ann
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
@@ -231,12 +231,12 @@ mkTyData :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons (L _ maybe_deriv) annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
+ ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (DataDecl { tcdDExt = anns',
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -263,14 +263,14 @@ mkTySynonym :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (text "type") equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; return (L (noAnnSrcSpan loc) (SynDecl
- { tcdSExt = anns'
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (SynDecl { tcdSExt = anns'
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
@@ -303,8 +303,9 @@ mkTyFamInstEqn :: SrcSpan
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn loc bndrs lhs rhs anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (L (noAnnSrcSpan loc) $ FamEqn
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' $ FamEqn
{ feqn_ext = anns `mappend` ann
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -324,10 +325,11 @@ mkDataFamInst :: SrcSpan
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons (L _ maybe_deriv) anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
- ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
(FamEqn { feqn_ext = ann Semi.<> anns
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -368,10 +370,10 @@ mkFamDecl :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl loc info topLevel lhs ksig injAnn annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
- ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
- (FamilyDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (FamDecl noExtField (FamilyDecl
{ fdExt = annsIn Semi.<> ann
, fdTopLevel = topLevel
, fdInfo = info, fdLName = tc
@@ -1040,45 +1042,46 @@ checkTyClHdr :: Bool -- True <=> class header
-> P (LocatedN RdrName, -- the head symbol (type or class name)
[LHsTypeArg GhcPs], -- parameters of head symbol
LexicalFixity, -- the declaration is in infix format
- [AddEpAnn]) -- API Annotation for HsParTy
+ [AddEpAnn], -- API Annotation for HsParTy
-- when stripping parens
+ EpAnnComments) -- Accumulated comments from re-arranging
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
-- Int :*: Bool into (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr is_cls ty
- = goL ty [] [] [] Prefix
+ = goL emptyComments ty [] [] [] Prefix
where
- goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
+ goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix
-- workaround to define '*' despite StarIsType
- go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
+ go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
= do { addPsMessage (locA l) PsWarnStarBinder
; let name = mkOccNameFS tcClsName (starSym isUni)
; let a' = newAnns ll l an
; return (L a' (Unqual name), acc, fix
- , (reverse ops') ++ cps') }
+ , (reverse ops') ++ cps', cs) }
- go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
- | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
- go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+ go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+ | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
where lhs = HsValArg noExtField t1
rhs = HsValArg noExtField t2
- go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
+ go cs l (HsParTy _ ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
where
(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
+ go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
+ go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
+ go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (l2l l) (nameRdrName tup_name)
- , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
+ , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
- go l _ _ _ _ _
+ go _ l _ _ _ _ _
= addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrMalformedTyOrClDecl ty)
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -856,3 +856,8 @@ Test24749:
Test24754:
$(CHECK_PPR) $(LIBDIR) Test24754.hs
$(CHECK_EXACT) $(LIBDIR) Test24754.hs
+
+.PHONY: Test24755
+Test24755:
+ $(CHECK_PPR) $(LIBDIR) Test24755.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24755.hs
=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24755 where
+
+class
+ a -- Before operator
+ :+
+ b -- After operator
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -204,3 +204,4 @@ test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
test('Test24749', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24749'])
test('Test24754', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24754'])
+test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f1763a51973ea37fa041901acb8efc4a38d9cd0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f1763a51973ea37fa041901acb8efc4a38d9cd0
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/20240503/39d73c86/attachment-0001.html>
More information about the ghc-commits
mailing list