From a7492048b616c9fc38af4cad40928ff4e5e7ae96 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 30 Jul 2023 16:56:27 +0100
Subject: [PATCH] EPA: get rid of AnchorOperation
Now that the Anchor type is an alias for EpaLocation, remove
AnchorOperation.
Updates haddock submodule
---
compiler/GHC/Parser.y | 4 ++--
compiler/GHC/Parser/Annotation.hs | 21 ++-------------------
compiler/GHC/Parser/PostProcess.hs | 9 ++++-----
utils/check-exact/ExactPrint.hs | 22 +++++++++-------------
utils/check-exact/Transform.hs | 10 ----------
utils/haddock | 2 +-
6 files changed, 18 insertions(+), 50 deletions(-)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 23d17463cece..6bcbb2a5b959 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -3392,9 +3392,9 @@ apats :: { [LPat GhcPs] }
stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }
: '{' stmts '}' { $2 >>= \ $2 ->
- amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
+ amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
| vocurly stmts close { $2 >>= \ $2 -> amsrl
- (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
+ (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index fd1f85c42280..de074daad0e9 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -18,8 +18,8 @@ module GHC.Parser.Annotation (
getTokenSrcSpan,
DeltaPos(..), deltaPos, getDeltaLine,
- EpAnn(..), Anchor, AnchorOperation(..),
- anchor, anchor_op,
+ EpAnn(..), Anchor,
+ anchor,
spanAsAnchor, realSpanAsAnchor, spanFromAnchor,
noSpanAnchor,
NoAnn(..),
@@ -517,15 +517,6 @@ data EpAnn ann
-- e.g. from TH, deriving, etc.
deriving (Data, Eq, Functor)
--- | If tools modify the parsed source, the 'MovedAnchor' variant can
--- directly provide the spacing for this item relative to the previous
--- one when printing. This allows AST fragments with a particular
--- anchor to be freely moved, without worrying about recalculating the
--- appropriate anchor span.
-data AnchorOperation = UnchangedAnchor
- | MovedAnchor !DeltaPos ![LEpaComment]
- deriving (Data, Eq, Show)
-
-- | An 'Anchor' records the base location for the start of the
-- syntactic element holding the annotations, and is used as the point
-- of reference for calculating delta positions for contained
@@ -539,10 +530,6 @@ anchor :: Anchor -> RealSrcSpan
anchor (EpaSpan r _) = r
anchor _ = panic "anchor"
-anchor_op :: Anchor -> AnchorOperation
-anchor_op (EpaSpan _ _) = UnchangedAnchor
-anchor_op (EpaDelta dp cs) = MovedAnchor dp cs
-
spanAsAnchor :: SrcSpan -> Anchor
spanAsAnchor (RealSrcSpan r mb) = EpaSpan r mb
spanAsAnchor s = EpaSpan (realSrcSpan s) Strict.Nothing
@@ -1457,10 +1444,6 @@ instance (Outputable a) => Outputable (EpAnn a) where
instance Outputable NoEpAnns where
ppr NoEpAnns = text "NoEpAnns"
-instance Outputable AnchorOperation where
- ppr UnchangedAnchor = text "UnchangedAnchor"
- ppr (MovedAnchor d cs) = text "MovedAnchor" <+> ppr d <+> ppr cs
-
instance Outputable DeltaPos where
ppr (SameLine c) = text "SameLine" <+> ppr c
ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 2e1e83c71ae3..4faf076e61c7 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -503,12 +503,11 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor
+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor
stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan r rb)) _), _))
- = widenAnchorS (EpaSpan l mb) (RealSrcSpan r rb)
-stmtsAnchor (L (RealSrcSpan l mb) _) = EpaSpan l mb
-stmtsAnchor _ = panic "stmtsAnchor"
--- stmtsAnchor _ = Nothing
+ = Just $ widenAnchorS (EpaSpan l mb) (RealSrcSpan r rb)
+stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan l mb
+stmtsAnchor _ = Nothing
stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan
stmtsLoc (L l ((ConsOL aa _), _))
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index f8852bbe2d26..f5bf1bf598ff 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -420,7 +420,6 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
p <- getPosP
pe0 <- getPriorEndD
debugM $ "enterAnn:starting:(p,pe,anchor',a) =" ++ show (p, pe0, showAst anchor', astId a)
- debugM $ "enterAnn:anchor_op=" ++ showGhc (anchor_op anchor')
prevAnchor <- getAnchorU
let curAnchor = case anchor' of
EpaSpan r _ -> r
@@ -442,8 +441,8 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
printCommentsBefore curAnchor
priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop
-- -------------------------
- case anchor_op anchor' of
- MovedAnchor dp _ -> do
+ case anchor' of
+ EpaDelta dp _ -> do
debugM $ "enterAnn: MovedAnchor:" ++ show dp
-- Set the original anchor as prior end, so the rest of this AST
-- fragment has a reference
@@ -484,8 +483,8 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- changed.
off (ss2delta priorEndAfterComments curAnchor)
debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)
- let edp'' = case anchor_op anchor' of
- MovedAnchor dp _ -> dp
+ let edp'' = case anchor' of
+ EpaDelta dp _ -> dp
_ -> edp'
-- ---------------------------------------------
-- let edp = edp''
@@ -506,7 +505,7 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
modify (\s -> s { dPriorEndPosition = spanStart } ))
- debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)
+ debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor)
-- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
p0 <- getPosP
d <- getPriorEndD
@@ -1402,15 +1401,12 @@ printCommentsIn ss = do
printOneComment :: (Monad m, Monoid w) => Comment -> EP w m ()
printOneComment c@(Comment _str loc _r _mo) = do
debugM $ "printOneComment:c=" ++ showGhc c
- dp <-case anchor_op loc of
- MovedAnchor dp _ -> return dp
- _ -> do
+ dp <-case loc of
+ EpaDelta dp _ -> return dp
+ EpaSpan r _ -> do
pe <- getPriorEndD
debugM $ "printOneComment:pe=" ++ showGhc pe
- -- let dp = ss2delta pe (anchor loc)
- let dp = case loc of
- EpaSpan r _ -> ss2delta pe r
- EpaDelta dp1 _ -> dp1
+ let dp = ss2delta pe r
debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)
adjustDeltaForOffsetM dp
mep <- getExtraDP
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index 8e25227f7699..6897e459199e 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -51,7 +51,6 @@ module Transform
, noAnnSrcSpanDP1
, noAnnSrcSpanDPn
, d0, d1, dn
- , m0, m1, mn
, addComma
-- ** Managing lists, Transform monad
@@ -771,15 +770,6 @@ d1 = EpaDelta (SameLine 1) []
dn :: Int -> EpaLocation
dn n = EpaDelta (SameLine n) []
-m0 :: AnchorOperation
-m0 = MovedAnchor (SameLine 0) []
-
-m1 :: AnchorOperation
-m1 = MovedAnchor (SameLine 1) []
-
-mn :: Int -> AnchorOperation
-mn n = MovedAnchor (SameLine n) []
-
addComma :: SrcSpanAnnA -> SrcSpanAnnA
addComma (SrcSpanAnn EpAnnNotUsed l)
= (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) emptyComments) l)
diff --git a/utils/haddock b/utils/haddock
index be2d1628c23d..a70ba4918b8a 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit be2d1628c23dc2eca39b82a8b4909cca1a3925d9
+Subproject commit a70ba4918b8a65abd18b16f414b6e2c3c4e38c46
--
GitLab