[Git][ghc/ghc][master] EPA: fix mkHsOpTyPV duplicating comments

[Marge Bot (@marge-bot)]

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


Commits:
18f4ff84 by Alan Zimmerman at 2024-05-05T19:36:32-04:00
EPA: fix mkHsOpTyPV duplicating comments

Closes #24753

- - - - -


4 changed files:

- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24753.hs
- testsuite/tests/printer/all.T


Changes:

=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2059,7 +2059,10 @@ instance DisambTD (HsType GhcPs) where
   mkHsAppTyHeadPV = return
   mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
   mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
-  mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
+  mkHsOpTyPV prom t1 op t2 = do
+    let (L l ty) = mkLHsOpTy prom t1 op t2
+    !cs <- getCommentsFor (locA l)
+    return (L (addCommentsToEpAnn l cs) ty)
   mkUnpackednessPV = addUnpackednessP
 
 dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
@@ -2101,8 +2104,9 @@ instance DisambTD DataConBuilder where
   mkHsOpTyPV prom lhs tc rhs = do
       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
       data_con <- eitherToP $ tyConToDataCon tc
+      !cs <- getCommentsFor (locA l)
       checkNotPromotedDataCon prom data_con
-      return $ L l (InfixDataConBuilder lhs data_con rhs)
+      return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
     where
       l = combineLocsA lhs rhs
       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
@@ -3223,8 +3227,8 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
 
 mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy prom x op y =
-  let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
-  in L loc (mkHsOpTy prom x op y)
+  let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
+  in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
 
 mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
 mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr


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


=====================================
testsuite/tests/printer/Test24753.hs
=====================================
@@ -0,0 +1,8 @@
+module Test24753 where
+
+type ErrorChoiceApi
+     = "path0" :> Get '[JSON] Int                                     -- c0
+  :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- c4
+             :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- c5
+  :<|> "path5" :> (ReqBody '[JSON] Int      :> Post '[PlainText] Int  -- c6
+             :<|>  ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7


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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18f4ff84b323236f6dfd07f3bbc2842308a01e91
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/50ac3e00/attachment-0001.html>