[Git][ghc/ghc][master] EPA: EpaDelta for comment has no comments
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Nov 30 17:38:29 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c7623b22 by Alan Zimmerman at 2023-11-30T12:37:56-05:00
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
- - - - -
8 changed files:
- compiler/GHC/Parser/Annotation.hs
- testsuite/tests/printer/Test20297.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Types.hs
- utils/check-exact/Utils.hs
- utils/haddock
Changes:
=====================================
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
=====================================
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 #-}")
=====================================
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
-- ---------------------------------------------------------------------
=====================================
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)
=====================================
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
=====================================
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.
}
=====================================
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
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a
+Subproject commit a7eae7da6868b22dc7109142475b228c60509812
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7623b225efd38cb2d014cf3ff9d0e8043a87723
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7623b225efd38cb2d014cf3ff9d0e8043a87723
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231130/44929617/attachment-0001.html>
More information about the ghc-commits
mailing list