From a79960fec0d65574015aae56f42f26b501a48f07 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Thu, 3 Aug 2023 20:53:02 +0100
Subject: [PATCH] EPA: Tuple Present no longer has annotation
The Present constructor for a Tuple argument will never have an exact
print annotation. So make this impossible.
---
compiler/GHC/Hs/Expr.hs | 2 +-
compiler/GHC/Hs/Utils.hs | 2 +-
compiler/GHC/Parser/PostProcess.hs | 2 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 2 +-
compiler/GHC/ThToHs.hs | 2 +-
utils/check-exact/ExactPrint.hs | 4 ++--
6 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index ffba60e9d8c6..d4d4c45f31d8 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -416,7 +416,7 @@ type instance XXPragE (GhcPass _) = DataConCantHappen
type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel
type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen
-type instance XPresent (GhcPass _) = EpAnn [AddEpAnn]
+type instance XPresent (GhcPass _) = NoExtField
type instance XMissing GhcPs = EpAnn EpaLocation
type instance XMissing GhcRn = NoExtField
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index efb5ffff7b94..6b7a6e6c5fca 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -666,7 +666,7 @@ mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] _ = e
mkLHsTupleExpr es ext
- = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed
+ = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed
mkLHsVarTuple :: IsSrcSpanAnn p a
=> [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 75d63e70447c..ddca8efe5d46 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -3151,7 +3151,7 @@ mkSumOrTupleExpr l boxity (Tuple es) anns = do
where
toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs
toTupArg (Left ann) = missingTupArg ann
- toTupArg (Right a) = Present noAnn a
+ toTupArg (Right a) = Present noExtField a
-- Sum
-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index d26b7d1cdf1c..16f2859a51c1 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -1037,7 +1037,7 @@ tcPatToExpr args pat = go pat
; return $ ExplicitList noExtField exprs }
go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
; return $ ExplicitTuple noExtField
- (map (Present noAnn) exprs) box }
+ (map (Present noExtField) exprs) box }
go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat)
; return $ ExplicitSum noExtField alt arity
(noLocA expr)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index e47bbeff4dbb..4c9f1cd793f0 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1218,7 +1218,7 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; retur
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup es boxity = do { let cvtl_maybe Nothing = return (missingTupArg noAnn)
- cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e)
+ cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e)
; es' <- mapM cvtl_maybe es
; return $ ExplicitTuple
noAnn
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index cfcd1a5773a3..37e6303b9a5a 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -3431,10 +3431,10 @@ instance ExactPrint (DotFieldOcc GhcPs) where
-- ---------------------------------------------------------------------
instance ExactPrint (HsTupArg GhcPs) where
- getAnnotationEntry (Present an _) = fromAnn an
+ getAnnotationEntry (Present _ _) = NoEntryVal
getAnnotationEntry (Missing an) = fromAnn an
- setAnnotationAnchor (Present an a) anc ts cs = Present (setAnchorEpa an anc ts cs) a
+ setAnnotationAnchor (Present a b) _ _ _ = Present a b
setAnnotationAnchor (Missing an) anc ts cs = Missing (setAnchorEpa an anc ts cs)
exact (Present a e) = Present a <$> markAnnotated e
--
GitLab