From de78b32a611b764a077ea70b02068f7d9cfa535a Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Tue, 3 Oct 2023 17:59:49 +0100
Subject: [PATCH] EPA Some tweaks to annotations
- Fix span for GRHS
- Move TrailingAnns from last match to FunBind
- Fix GADT 'where' clause span
- Capture full range for a CaseAlt Match
---
compiler/GHC/Parser.y | 25 ++++++++++++-------
compiler/GHC/Parser/Annotation.hs | 5 +++-
compiler/GHC/Parser/PostProcess.hs | 9 ++++++-
.../parser/should_compile/DumpSemis.stderr | 18 +++++++------
.../tests/parser/should_compile/T15323.stderr | 9 ++++++-
testsuite/tests/printer/Test20297.stdout | 17 ++++++-------
6 files changed, 54 insertions(+), 29 deletions(-)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index b1e4a9cef421..d73dd07923b1 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2269,7 +2269,7 @@ atype :: { LHsType GhcPs }
| PREFIX_TILDE atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }
| PREFIX_BANG atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }
- | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
+ | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
; checkRecordSyntax decls }}
-- Constructor sigs only
| '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)
@@ -2407,7 +2407,7 @@ gadt_constrlist :: { Located ([AddEpAnn]
,[LConDecl GhcPs]) } -- Returned in order
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
- L (comb2 $1 $3)
+ L (comb2 $1 $4)
([mj AnnWhere $1
,moc $2
,mcc $4]
@@ -2588,8 +2588,9 @@ rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }
: '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 ->
do { let L l (bs, csw) = adaptWhereBinds $3
; let loc = (comb3 $1 $2 (L l bs))
+ ; let locg = (comb2 $1 $2)
; acs (\cs ->
- sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)
+ sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs locg) (GrhsAnn Nothing (mj AnnEqual $1)) cs) locg $2)
bs)) } }
| gdrhs wherebinds {% do { let {L l (bs, csw) = adaptWhereBinds $2}
; acs (\cs -> sL (comb2 $1 (L l bs))
@@ -3324,7 +3325,7 @@ alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs
alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
: PATS alt_rhs { $2 >>= \ $2 ->
acsA (\cs -> sLLAsl $1 $>
- (Match { m_ext = EpAnn (listAsAnchor $1) [] cs
+ (Match { m_ext = EpAnn (listAsAnchor $1 $>) [] cs
, m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing
, m_pats = $1
, m_grhss = unLoc $2 }))}
@@ -3336,7 +3337,7 @@ alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
- acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) }
+ acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 (reLoc $2)) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }
| gdpats { $1 >>= \gdpats ->
return $ sL1 gdpats (reverse (unLoc gdpats)) }
@@ -4465,9 +4466,16 @@ hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
hsDoAnn (L l _) (L ll _) kw
= AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
-listAsAnchor :: [LocatedAn t a] -> Anchor
-listAsAnchor [] = spanAsAnchor noSrcSpan
-listAsAnchor (L l _:_) = spanAsAnchor (locA l)
+listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor
+listAsAnchor [] (L l _) = spanAsAnchor l
+listAsAnchor (h:_) s = spanAsAnchor (comb2 (reLoc h) s)
+
+listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor
+listAsAnchorM [] = Nothing
+listAsAnchorM (L l _:_) =
+ case locA l of
+ RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll
+ _ -> Nothing
hsTok :: Located Token -> LHsToken tok GhcPs
hsTok (L l _) = L (mkTokenLocation l) HsTok
@@ -4528,7 +4536,6 @@ addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation
addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)
addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
- -- cs <- getCommentsFor l
let cs = emptyComments
-- AZ:TODO: generalise updating comments into an annotation
let anns' = if isZeroWidthSpan span
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 40b5b31a3de2..f15bbec30c48 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -19,8 +19,8 @@ module GHC.Parser.Annotation (
DeltaPos(..), deltaPos, getDeltaLine,
EpAnn(..), Anchor(..), AnchorOperation(..),
- spanAsAnchor, realSpanAsAnchor,
NoAnn(..),
+ spanAsAnchor, realSpanAsAnchor, spanFromAnchor,
-- ** Comments in Annotations
@@ -549,6 +549,9 @@ spanAsAnchor s = Anchor (realSrcSpan s) UnchangedAnchor
realSpanAsAnchor :: RealSrcSpan -> Anchor
realSpanAsAnchor s = Anchor s UnchangedAnchor
+spanFromAnchor :: Anchor -> SrcSpan
+spanFromAnchor a = RealSrcSpan (anchor a) Strict.Nothing
+
-- ---------------------------------------------------------------------
-- | When we are parsing we add comments that belong a particular AST
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ae8cd9acbf88..468214adb8c3 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -831,11 +831,18 @@ mkGadtDecl loc names dcol ty = do
let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa)
+ let bndrs_loc = case outer_bndrs of
+ HsOuterImplicit{} -> getLoc ty
+ HsOuterExplicit an _ ->
+ case an of
+ EpAnnNotUsed -> getLoc ty
+ an' -> SrcSpanAnn (EpAnn (entry an') noAnn emptyComments) (spanFromAnchor (entry an'))
+
pure $ L l ConDeclGADT
{ con_g_ext = an
, con_names = names
, con_dcolon = dcol
- , con_bndrs = L (getLoc ty) outer_bndrs
+ , con_bndrs = L bndrs_loc outer_bndrs
, con_mb_cxt = mcxt
, con_g_args = args
, con_res_ty = res_ty
diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr
index 4fc5e330ef97..6ead4e3dceae 100644
--- a/testsuite/tests/parser/should_compile/DumpSemis.stderr
+++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr
@@ -1829,7 +1829,7 @@
(Match
(EpAnn
(Anchor
- { DumpSemis.hs:39:6 }
+ { DumpSemis.hs:39:6-13 }
(UnchangedAnchor))
[]
(EpaComments
@@ -1862,7 +1862,7 @@
(GRHS
(EpAnn
(Anchor
- { DumpSemis.hs:39:8-9 }
+ { DumpSemis.hs:39:8-13 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -1898,7 +1898,7 @@
(Match
(EpAnn
(Anchor
- { DumpSemis.hs:40:6 }
+ { DumpSemis.hs:40:6-13 }
(UnchangedAnchor))
[]
(EpaComments
@@ -1931,7 +1931,7 @@
(GRHS
(EpAnn
(Anchor
- { DumpSemis.hs:40:8-9 }
+ { DumpSemis.hs:40:8-13 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -1969,7 +1969,7 @@
(Match
(EpAnn
(Anchor
- { DumpSemis.hs:41:6 }
+ { DumpSemis.hs:41:6-13 }
(UnchangedAnchor))
[]
(EpaComments
@@ -2002,7 +2002,7 @@
(GRHS
(EpAnn
(Anchor
- { DumpSemis.hs:41:8-9 }
+ { DumpSemis.hs:41:8-13 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -2042,7 +2042,7 @@
(Match
(EpAnn
(Anchor
- { DumpSemis.hs:42:6 }
+ { DumpSemis.hs:42:6-13 }
(UnchangedAnchor))
[]
(EpaComments
@@ -2075,7 +2075,7 @@
(GRHS
(EpAnn
(Anchor
- { DumpSemis.hs:42:8-9 }
+ { DumpSemis.hs:42:8-13 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -2100,3 +2100,5 @@
(NoExtField)))))]))))))]
(EmptyLocalBinds
(NoExtField)))))])))))]))
+
+
diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr
index 166788ac9e46..9ec7d7748d94 100644
--- a/testsuite/tests/parser/should_compile/T15323.stderr
+++ b/testsuite/tests/parser/should_compile/T15323.stderr
@@ -100,7 +100,14 @@
(EpaSpan { T15323.hs:6:17-18 }))
(HsNormalTok))
(L
- (SrcSpanAnn (EpAnnNotUsed) { T15323.hs:6:20-54 })
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { T15323.hs:6:20-25 }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { T15323.hs:6:20-25 })
(HsOuterExplicit
(EpAnn
(Anchor
diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout
index 586d9fae20f2..bf46d7751f48 100644
--- a/testsuite/tests/printer/Test20297.stdout
+++ b/testsuite/tests/printer/Test20297.stdout
@@ -82,11 +82,11 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { Test20297.hs:(5,5)-(7,7) })
+ { Test20297.hs:5:5-7 })
(GRHS
(EpAnn
(Anchor
- { Test20297.hs:(5,5)-(7,7) }
+ { Test20297.hs:5:5-7 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -182,11 +182,11 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { Test20297.hs:(9,5)-(11,26) })
+ { Test20297.hs:9:5-7 })
(GRHS
(EpAnn
(Anchor
- { Test20297.hs:(9,5)-(11,26) }
+ { Test20297.hs:9:5-7 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -422,11 +422,11 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { Test20297.ppr.hs:(4,3)-(5,7) })
+ { Test20297.ppr.hs:4:3-5 })
(GRHS
(EpAnn
(Anchor
- { Test20297.ppr.hs:(4,3)-(5,7) }
+ { Test20297.ppr.hs:4:3-5 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -508,11 +508,11 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { Test20297.ppr.hs:(7,3)-(9,24) })
+ { Test20297.ppr.hs:7:3-5 })
(GRHS
(EpAnn
(Anchor
- { Test20297.ppr.hs:(7,3)-(9,24) }
+ { Test20297.ppr.hs:7:3-5 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
@@ -655,4 +655,3 @@
(EmptyLocalBinds
(NoExtField)))))]))))]}
[])))))])))))]))
-
--
GitLab