From 26036f96919b1a8b99715dd99724163012c719fc Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 15 Apr 2024 22:06:44 +0100
Subject: [PATCH] EPA: Fix span for PatBuilderAppType
Include the location of the prefix @ in the span for InVisPat.
Also removes unnecessary annotations from HsTP.
Contributes to #24669
---
compiler/GHC/Hs/Type.hs | 10 ++---
compiler/GHC/Parser.y | 2 +-
compiler/GHC/Parser/PostProcess.hs | 12 +++---
compiler/GHC/ThToHs.hs | 6 +--
.../tests/rename/should_fail/T17594b.stderr | 42 +++++++++----------
.../typecheck/should_fail/T17594c.stderr | 2 +-
.../typecheck/should_fail/T17594d.stderr | 2 +-
.../typecheck/should_fail/T17594g.stderr | 2 +-
8 files changed, 40 insertions(+), 38 deletions(-)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 4d925a58c000..2d401e1807b3 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -219,7 +219,7 @@ type instance XHsPS GhcPs = EpAnnCO
type instance XHsPS GhcRn = HsPSRn
type instance XHsPS GhcTc = HsPSRn
-type instance XHsTP GhcPs = EpAnnCO
+type instance XHsTP GhcPs = NoExtField
type instance XHsTP GhcRn = HsTyPatRn
type instance XHsTP GhcTc = DataConCantHappen
@@ -295,9 +295,9 @@ mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType ann x = HsPS { hsps_ext = ann
, hsps_body = x }
-mkHsTyPat :: EpAnnCO -> LHsType GhcPs -> HsTyPat GhcPs
-mkHsTyPat ann x = HsTP { hstp_ext = ann
- , hstp_body = x }
+mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs
+mkHsTyPat x = HsTP { hstp_ext = noExtField
+ , hstp_body = x }
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
@@ -589,7 +589,7 @@ mkHsAppTys = foldl' mkHsAppTy
mkHsAppKindTy :: XAppKindTy (GhcPass p)
-> LHsType (GhcPass p) -> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-mkHsAppKindTy x ty k = addCLocA ty k (HsAppKindTy x ty k)
+mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)
{-
************************************************************************
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index da2a2d8be79c..171e174e2a71 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -3401,7 +3401,7 @@ bindpat : exp {% -- See Note [Parser-Validator Details] in GHC.Parse
argpat :: { LPat GhcPs }
argpat : apat { $1 }
- | PREFIX_AT atype { L (getLocAnn (reLoc $2)) (InvisPat (epTok $1) (mkHsTyPat noAnn $2)) }
+ | PREFIX_AT atype { sLLa $1 $> (InvisPat (epTok $1) (mkHsTyPat $2)) }
argpats :: { [LPat GhcPs] }
: argpat argpats { $1 : $2 }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 42938aed32b9..ebb05f97c823 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1457,9 +1457,12 @@ isFunLhs e = go e [] [] []
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
(L loc' op) r (reverse ops ++ cps))
reassociate _other = Nothing
- go (L _ (PatBuilderAppType pat tok ty_pat@(HsTP _ (L loc _)))) es ops cps
- = go pat (L loc (ArgPatBuilderArgPat invis_pat) : es) ops cps
+ go (L _ (PatBuilderAppType pat tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
+ = go pat (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
where invis_pat = InvisPat tok ty_pat
+ anc' = case tok of
+ NoEpTok -> anc
+ EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]
go _ _ _ _ = return Nothing
data ArgPatBuilder p
@@ -1919,8 +1922,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
mkHsAppTypePV l p at t = do
!cs <- getCommentsFor (locA l)
- let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs
- return $ L l (PatBuilderAppType p at (mkHsTyPat anns t))
+ return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
@@ -1977,7 +1979,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkSumOrTuplePV = mkSumOrTuplePat
mkHsEmbTyPV l toktype ty =
return $ L (noAnnSrcSpan l) $
- PatBuilderPat (EmbTyPat toktype (mkHsTyPat noAnn ty))
+ PatBuilderPat (EmbTyPat toktype (mkHsTyPat ty))
rejectPragmaPV _ = return ()
-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 8a023c56bc87..8f8f11d672e2 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1446,7 +1446,7 @@ cvtp (ConP s ts ps) = do { s' <- cNameN s
; ps' <- cvtPats ps
; ts' <- mapM cvtType ts
; let pps = map (parenthesizePat appPrec) ps'
- pts = map (\t -> HsConPatTyArg noAnn (mkHsTyPat noAnn t)) ts'
+ pts = map (\t -> HsConPatTyArg noAnn (mkHsTyPat t)) ts'
; return $ ConPat
{ pat_con_ext = noAnn
, pat_con = s'
@@ -1489,9 +1489,9 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noAnn e' p'}
cvtp (TypeP t) = do { t' <- cvtType t
- ; return $ EmbTyPat noAnn (mkHsTyPat noAnn t') }
+ ; return $ EmbTyPat noAnn (mkHsTyPat t') }
cvtp (InvisP t) = do { t' <- cvtType t
- ; pure (InvisPat noAnn (mkHsTyPat noAnn t'))}
+ ; pure (InvisPat noAnn (mkHsTyPat t'))}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
diff --git a/testsuite/tests/rename/should_fail/T17594b.stderr b/testsuite/tests/rename/should_fail/T17594b.stderr
index e74145f6f0a0..5682c42ffb15 100644
--- a/testsuite/tests/rename/should_fail/T17594b.stderr
+++ b/testsuite/tests/rename/should_fail/T17594b.stderr
@@ -1,84 +1,84 @@
-T17594b.hs:7:6: error: [GHC-78249]
+T17594b.hs:7:5: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:10:6: error: [GHC-78249]
+T17594b.hs:10:5: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:14:6: error: [GHC-78249]
+T17594b.hs:14:5: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:6: error: [GHC-78249]
+T17594b.hs:17:5: error: [GHC-78249]
Illegal invisible type pattern: t1
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:10: error: [GHC-78249]
+T17594b.hs:17:9: error: [GHC-78249]
Illegal invisible type pattern: t2
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:14: error: [GHC-78249]
+T17594b.hs:17:13: error: [GHC-78249]
Illegal invisible type pattern: t3
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:27: error: [GHC-78249]
+T17594b.hs:17:26: error: [GHC-78249]
Illegal invisible type pattern: t4
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:31: error: [GHC-78249]
+T17594b.hs:17:30: error: [GHC-78249]
Illegal invisible type pattern: t5
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:17:35: error: [GHC-78249]
+T17594b.hs:17:34: error: [GHC-78249]
Illegal invisible type pattern: t6
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:20:11: error: [GHC-78249]
+T17594b.hs:20:10: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:22:20: error: [GHC-78249]
+T17594b.hs:22:19: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:25:10: error: [GHC-78249]
+T17594b.hs:25:9: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:6: error: [GHC-78249]
+T17594b.hs:28:5: error: [GHC-78249]
Illegal invisible type pattern: t1
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:10: error: [GHC-78249]
+T17594b.hs:28:9: error: [GHC-78249]
Illegal invisible type pattern: t2
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:32: error: [GHC-78249]
+T17594b.hs:28:31: error: [GHC-78249]
Illegal invisible type pattern: t3
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:58: error: [GHC-78249]
+T17594b.hs:28:57: error: [GHC-78249]
Illegal invisible type pattern: t4
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:62: error: [GHC-78249]
+T17594b.hs:28:61: error: [GHC-78249]
Illegal invisible type pattern: t5
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:28:71: error: [GHC-78249]
+T17594b.hs:28:70: error: [GHC-78249]
Illegal invisible type pattern: t6
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:31:11: error: [GHC-78249]
+T17594b.hs:31:10: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:34:11: error: [GHC-78249]
+T17594b.hs:34:10: error: [GHC-78249]
Illegal invisible type pattern: t
Suggested fix: Perhaps you intended to use TypeAbstractions
-T17594b.hs:37:7: error: [GHC-78249]
+T17594b.hs:37:6: error: [GHC-78249]
Illegal invisible type pattern: ($(TH.varT (TH.mkName "t")))
Suggested fix: Perhaps you intended to use TypeAbstractions
diff --git a/testsuite/tests/typecheck/should_fail/T17594c.stderr b/testsuite/tests/typecheck/should_fail/T17594c.stderr
index 878f9393558d..bda3ad39be51 100644
--- a/testsuite/tests/typecheck/should_fail/T17594c.stderr
+++ b/testsuite/tests/typecheck/should_fail/T17594c.stderr
@@ -1,5 +1,5 @@
-T17594c.hs:5:11: error: [GHC-14964]
+T17594c.hs:5:10: error: [GHC-14964]
• Invisible type pattern t has no associated forall
• In the expression: \ @t -> undefined :: t
In the expression: [\ @t -> undefined :: t]
diff --git a/testsuite/tests/typecheck/should_fail/T17594d.stderr b/testsuite/tests/typecheck/should_fail/T17594d.stderr
index c9917d917659..178ec3cd4f54 100644
--- a/testsuite/tests/typecheck/should_fail/T17594d.stderr
+++ b/testsuite/tests/typecheck/should_fail/T17594d.stderr
@@ -1,4 +1,4 @@
-T17594d.hs:8:6: error: [GHC-14964]
+T17594d.hs:8:5: error: [GHC-14964]
• Invisible type pattern t has no associated forall
• In an equation for ‘id'’: id' @t x = x :: t
diff --git a/testsuite/tests/typecheck/should_fail/T17594g.stderr b/testsuite/tests/typecheck/should_fail/T17594g.stderr
index f070c722215e..8ecba0854278 100644
--- a/testsuite/tests/typecheck/should_fail/T17594g.stderr
+++ b/testsuite/tests/typecheck/should_fail/T17594g.stderr
@@ -1,4 +1,4 @@
-T17594g.hs:6:6: error: [GHC-14964]
+T17594g.hs:6:5: error: [GHC-14964]
• Invisible type pattern a has no associated forall
• In an equation for ‘id'’: id' @a x = x
--
GitLab