From 18f4ff84b323236f6dfd07f3bbc2842308a01e91 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Thu, 2 May 2024 18:23:31 +0100
Subject: [PATCH] EPA: fix mkHsOpTyPV duplicating comments
Closes #24753
---
compiler/GHC/Parser/PostProcess.hs | 12 ++++++++----
testsuite/tests/printer/Makefile | 5 +++++
testsuite/tests/printer/Test24753.hs | 8 ++++++++
testsuite/tests/printer/all.T | 1 +
4 files changed, 22 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/printer/Test24753.hs
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index f08ec34f5641..4b057cd1f812 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/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@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
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index abcafdaae78e..e55e969fc59b 100644
--- a/testsuite/tests/printer/Makefile
+++ b/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
diff --git a/testsuite/tests/printer/Test24753.hs b/testsuite/tests/printer/Test24753.hs
new file mode 100644
index 000000000000..4b429bb9c4fa
--- /dev/null
+++ b/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
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 42bf07478449..a7feccb09b93 100644
--- a/testsuite/tests/printer/all.T
+++ b/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'])
--
GitLab