[Git][ghc/ghc][wip/az/T24771-datadecl-comments] EPA: preserve comments in data decls

[Alan Zimmerman (@alanz)]

Alan Zimmerman pushed to branch wip/az/T24771-datadecl-comments at Glasgow Haskell Compiler / GHC


Commits:
a70c45ce by Alan Zimmerman at 2024-05-06T15:18:08+01:00
EPA: preserve comments in data decls

Closes #24771

- - - - -


6 changed files:

- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/Test24755.hs
- + testsuite/tests/printer/Test24771.hs
- testsuite/tests/printer/all.T


Changes:

=====================================
compiler/GHC/Parser.y
=====================================
@@ -2486,9 +2486,8 @@ forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
 constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
-        : infixtype       {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,
-                                                        dataConBuilderDetails b))))
-                                  (runPV $1) }
+        : infixtype       {% do { b <- runPV $1
+                                ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}
         | '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}
 
 usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -236,7 +236,8 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
        ; let anns' = annsIn Semi.<> ann
        ; 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
+       ; !cs' <- getCommentsFor loc'
+       ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)
        ; return (L loc (DataDecl { tcdDExt = anns',
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
@@ -2065,25 +2066,26 @@ instance DisambTD (HsType GhcPs) where
     return (L (addCommentsToEpAnn l cs) ty)
   mkUnpackednessPV = addUnpackednessP
 
-dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
+dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc
+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc
 
-dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
+dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
 
 -- Detect when the record syntax is used:
 --   data T = MkT { ... }
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
   | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
   = RecCon (L (EpAnn anc an cs) fields)
 
 -- Normal prefix constructor, e.g.  data T = MkT A B C
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
   = PrefixCon noTypeArgs (map hsLinear (toList flds))
 
 -- Infix constructor, e.g. data T = Int :! Bool
-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
-  = InfixCon (hsLinear lhs) (hsLinear rhs)
+dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
+  = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+
 
 instance DisambTD DataConBuilder where
   mkHsAppTyHeadPV = tyToDataConBuilder


=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -866,3 +866,8 @@ Test24755:
 Test24753:
 	$(CHECK_PPR)   $(LIBDIR) Test24753.hs
 	$(CHECK_EXACT) $(LIBDIR) Test24753.hs
+
+.PHONY: Test24771
+Test24771:
+	$(CHECK_PPR)   $(LIBDIR) Test24771.hs
+	$(CHECK_EXACT) $(LIBDIR) Test24771.hs


=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -3,6 +3,6 @@
 module Test24755 where
 
 class
-    a -- Before operator
-    :+
-    b -- After operator
+    a  -- c1
+    :+ -- c2
+    b  -- c3


=====================================
testsuite/tests/printer/Test24771.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24771 where
+
+data Foo
+  =  Int     -- c1
+       :*    -- c2
+     String  -- c3


=====================================
testsuite/tests/printer/all.T
=====================================
@@ -206,3 +206,4 @@ 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'])
 test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
+test('Test24771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24771'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a70c45ce50c82795f90b29af1c86f4b6847ec40f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a70c45ce50c82795f90b29af1c86f4b6847ec40f
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/20240506/af932163/attachment-0001.html>