From c7623b225efd38cb2d014cf3ff9d0e8043a87723 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 12 Aug 2023 14:54:10 +0100
Subject: [PATCH] EPA: EpaDelta for comment has no comments
EpaLocation is used to position things. It has two constructors,
EpaSpan holding a SrcSpan, and EpaDelta with a delta position and a
possible list of comments. The comment list is needed because the
location in EpaDelta has no absolute information to decide which
comments should be emitted before them when printing.
But it is also used for specifying the position of a comment. To
prevent the absurdity of a comment position having a list of comments
in it, we make EpaLocation parameterisable, using comments for the
normal case and a constant for within comments.
Updates haddock submodule.
aarch64-darwin
Metric Decrease:
MultiLayerModulesTH_OneShot
---
compiler/GHC/Parser/Annotation.hs | 47 +++++++++++++++++-------
testsuite/tests/printer/Test20297.stdout | 15 +++++---
utils/check-exact/ExactPrint.hs | 20 +++++-----
utils/check-exact/Main.hs | 1 +
utils/check-exact/Transform.hs | 5 ++-
utils/check-exact/Types.hs | 2 +-
utils/check-exact/Utils.hs | 22 +++++------
utils/haddock | 2 +-
8 files changed, 71 insertions(+), 43 deletions(-)
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 60f3eef0806f..aa6b4e3c8e63 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -13,7 +13,7 @@ module GHC.Parser.Annotation (
-- * In-tree Exact Print Annotations
AddEpAnn(..),
- EpaLocation(..), epaLocationRealSrcSpan,
+ EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan,
TokenLocation(..),
getTokenSrcSpan,
DeltaPos(..), deltaPos, getDeltaLine,
@@ -26,7 +26,8 @@ module GHC.Parser.Annotation (
-- ** Comments in Annotations
- EpAnnComments(..), LEpaComment, emptyComments,
+ EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments,
+ epaToNoCommentsLocation, noCommentsToEpaLocation,
getFollowingComments, setFollowingComments, setPriorComments,
EpAnnCO,
@@ -402,9 +403,26 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !SrcSpan
- | EpaDelta !DeltaPos ![LEpaComment]
- deriving (Data,Eq,Show)
+
+data EpaLocation' a = EpaSpan !SrcSpan
+ | EpaDelta !DeltaPos !a
+ deriving (Data,Eq,Show)
+
+type EpaLocation = EpaLocation' [LEpaComment]
+
+type NoCommentsLocation = EpaLocation' NoComments
+
+data NoComments = NoComments
+ deriving (Data,Eq,Ord,Show)
+
+epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation
+epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss
+epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments
+epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation"
+
+noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation
+noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss
+noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp []
-- | Tokens embedded in the AST have an EpaLocation, unless they come from
-- generated code (e.g. by TH).
@@ -454,7 +472,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
-instance Outputable EpaLocation where
+instance Outputable NoComments where
+ ppr NoComments = text "NoComments"
+
+instance (Outputable a) => Outputable (EpaLocation' a) where
ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
@@ -517,18 +538,18 @@ data EpAnn ann
-- that relationship is tracked in the 'anchor_op' instead.
type Anchor = EpaLocation -- Transitional
-anchor :: Anchor -> RealSrcSpan
+anchor :: (EpaLocation' a) -> RealSrcSpan
anchor (EpaSpan (RealSrcSpan r _)) = r
anchor _ = panic "anchor"
-spanAsAnchor :: SrcSpan -> Anchor
+spanAsAnchor :: SrcSpan -> (EpaLocation' a)
spanAsAnchor ss = EpaSpan ss
-realSpanAsAnchor :: RealSrcSpan -> Anchor
+realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a)
realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing)
-noSpanAnchor :: Anchor
-noSpanAnchor = EpaDelta (SameLine 0) []
+noSpanAnchor :: (NoAnn a) => (EpaLocation' a)
+noSpanAnchor = EpaDelta (SameLine 0) noAnn
-- ---------------------------------------------------------------------
@@ -546,7 +567,7 @@ data EpAnnComments = EpaComments
, followingComments :: ![LEpaComment] }
deriving (Data, Eq)
-type LEpaComment = GenLocated Anchor EpaComment
+type LEpaComment = GenLocated NoCommentsLocation EpaComment
emptyComments :: EpAnnComments
emptyComments = EpaComments []
@@ -1333,7 +1354,7 @@ instance Outputable DeltaPos where
ppr (SameLine c) = text "SameLine" <+> ppr c
ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
-instance Outputable (GenLocated Anchor EpaComment) where
+instance Outputable (GenLocated NoCommentsLocation EpaComment) where
ppr (L l c) = text "L" <+> ppr l <+> ppr c
instance Outputable EpAnnComments where
diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout
index 564ed735d369..234e36b3f9de 100644
--- a/testsuite/tests/printer/Test20297.stdout
+++ b/testsuite/tests/printer/Test20297.stdout
@@ -17,7 +17,8 @@
{ Test20297.hs:11:22-26 })))
(EpaCommentsBalanced
[(L
- (EpaSpan { Test20297.hs:1:1-33 })
+ (EpaSpan
+ { Test20297.hs:1:1-33 })
(EpaComment
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
@@ -114,7 +115,8 @@
(AddEpAnn AnnEqual (EpaSpan { Test20297.hs:5:5 })))
(EpaComments
[(L
- (EpaSpan { Test20297.hs:6:3-13 })
+ (EpaSpan
+ { Test20297.hs:6:3-13 })
(EpaComment
(EpaLineComment
"-- comment0")
@@ -162,7 +164,8 @@
[])
(EpaComments
[(L
- (EpaSpan { Test20297.hs:7:9-19 })
+ (EpaSpan
+ { Test20297.hs:7:9-19 })
(EpaComment
(EpaLineComment
"-- comment1")
@@ -267,7 +270,8 @@
[])
(EpaComments
[(L
- (EpaSpan { Test20297.hs:10:9-19 })
+ (EpaSpan
+ { Test20297.hs:10:9-19 })
(EpaComment
(EpaLineComment
"-- comment2")
@@ -436,7 +440,8 @@
{ Test20297.ppr.hs:9:20-24 })))
(EpaCommentsBalanced
[(L
- (EpaSpan { Test20297.ppr.hs:1:1-33 })
+ (EpaSpan
+ { Test20297.ppr.hs:1:1-33 })
(EpaComment
(EpaBlockComment
"{-# OPTIONS -ddump-parsed-ast #-}")
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index a647f2c5266e..ffb48ee27bc2 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -619,7 +619,7 @@ annotationsToComments (EpAnn anc a cs) l kws = do
go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn])
go acc [] = acc
go (cs',ans) ((AddEpAnn k ss) : ls)
- | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls
+ | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls
| otherwise = go (cs', (AddEpAnn k ss):ans) ls
-- ---------------------------------------------------------------------
@@ -677,7 +677,7 @@ printStringAtRsC capture pa str = do
NoCaptureComments -> return []
debugM $ "printStringAtRsC:cs'=" ++ show cs'
debugM $ "printStringAtRsC:p'=" ++ showAst p'
- debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' [])
+ debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments)
debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs'))
return (EpaDelta p' (map comment2LEpaComment cs'))
@@ -1365,14 +1365,14 @@ printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
printCommentsBefore ss = do
cs <- commentAllocationBefore ss
debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss)
- -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)
mapM_ printOneComment cs
printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()
printCommentsIn ss = do
cs <- commentAllocationIn ss
debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss)
- -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs)
mapM_ printOneComment cs
debugM $ "printCommentsIn:done"
@@ -1423,12 +1423,12 @@ updateAndApplyComment (Comment str anc pp mo) dp = do
_ -> dp''
op' = case dp' of
SameLine n -> if n >= 0
- then EpaDelta dp' []
- else EpaDelta dp []
- _ -> EpaDelta dp' []
- anc' = if str == "" && op' == EpaDelta (SameLine 0) [] -- EOF comment
- then EpaDelta dp []
- else EpaDelta dp []
+ then EpaDelta dp' NoComments
+ else EpaDelta dp NoComments
+ _ -> EpaDelta dp' NoComments
+ anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment
+ then EpaDelta dp NoComments
+ else EpaDelta dp NoComments
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 899582c4a77c..36e486d272f1 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -68,6 +68,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6)
+ -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3)
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index ffe0f7c0b882..4d70d06933bc 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -283,8 +283,9 @@ setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp
(dp0,c') = go h
in
(dp0, c':t, EpaCommentsBalanced [] ts)
+ go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e)
go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c)
- go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c)
+ go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c)
setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp
= case sortEpaComments (priorComments cs) of
[] ->
@@ -293,7 +294,7 @@ setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp
L (EpAnn (EpaDelta edp csd) an cs'') a
where
cs'' = setPriorComments cs []
- csd = L (EpaDelta dp []) c:cs'
+ csd = L (EpaDelta dp NoComments) c:cs'
lc = last $ (L ca c:cs')
delta = case getLoc lc of
EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs
index 381d157e8b44..6b529a3cc27a 100644
--- a/utils/check-exact/Types.hs
+++ b/utils/check-exact/Types.hs
@@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
data Comment = Comment
{
commentContents :: !String -- ^ The contents of the comment including separators
- , commentAnchor :: !Anchor
+ , commentLoc :: !NoCommentsLocation
, commentPriorTok :: !RealSrcSpan
, commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index ba5e8b20d78d..89f8aecbc093 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0
-- does not already have one.
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp))
- = (L (EpaDelta dp []) (GHC.EpaComment t pp))
+ = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp))
`debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
where
(r,c) = ss2posEnd pp
@@ -253,7 +253,7 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
tokComment :: LEpaComment -> [Comment]
tokComment t@(L lt c) =
case c of
- (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc
+ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc
_ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
@@ -268,9 +268,9 @@ hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
in
(Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
- = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+ = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]
hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
- = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+ = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ]
hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code
@@ -301,11 +301,11 @@ mkEpaComments priorCs postCs
comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
-mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
-mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
+mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment
+mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r))
-mkComment :: String -> Anchor -> RealSrcSpan -> Comment
-mkComment c anc r = Comment c anc r Nothing
+mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment
+mkComment c loc r = Comment c loc r Nothing
-- Windows comments include \r in them from the lexer.
normaliseCommentText :: String -> String
@@ -328,11 +328,11 @@ sortEpaComments cs = sortBy cmp cs
cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
-- | Makes a comment which originates from a specific keyword.
-mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
+mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment
mkKWComment kw (EpaSpan (RealSrcSpan ss mb))
= Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw)
mkKWComment kw (EpaSpan (UnhelpfulSpan _))
- = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw)
+ = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw)
mkKWComment kw (EpaDelta dp cs)
= Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw)
@@ -481,7 +481,7 @@ hsDeclsClassDecl dec = case dec of
tcdATs = ats, tcdATDefs = at_defs
} -> map snd decls
where
- srs :: (HasLoc a) => a -> RealSrcSpan
+ srs :: EpAnn a -> RealSrcSpan
srs a = realSrcSpan $ locA a
decls
= orderedDecls sortKey $ Map.fromList
diff --git a/utils/haddock b/utils/haddock
index f9f25507bf48..a7eae7da6868 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a
+Subproject commit a7eae7da6868b22dc7109142475b228c60509812
--
GitLab