[Git][ghc/ghc][master] EPA: preserve comments in class and data decls

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sun May 5 16:53:16 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
35d34fde by Alan Zimmerman at 2024-05-05T12:52:40-04: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/35d34fde62cd9e0002ac42f10bf705552f5c654e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35d34fde62cd9e0002ac42f10bf705552f5c654e
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/20240505/fadb9e7d/attachment-0001.html>


More information about the ghc-commits mailing list