[Git][ghc/ghc][wip/az/epa-epadelta-comments] EPA: EpaDelta for comment has no comments

Alan Zimmerman (@alanz) gitlab at gitlab.haskell.org
Wed Nov 29 19:38:08 UTC 2023



Alan Zimmerman pushed to branch wip/az/epa-epadelta-comments at Glasgow Haskell Compiler / GHC


Commits:
6f2713fa by Alan Zimmerman at 2023-11-29T19:37:44+00: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.

- - - - -


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/6f2713faeef9e7afa09706b370a20015eff81f04

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f2713faeef9e7afa09706b370a20015eff81f04
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/20231129/89df1cee/attachment-0001.html>


More information about the ghc-commits mailing list