[Git][ghc/ghc][wip/int-index/hdk-register-tok] Register LHsToken in Parser.PostProcess.Haddock

Andrei Borzenkov (@sand-witch) gitlab at gitlab.haskell.org
Fri Jun 9 09:57:02 UTC 2023



Andrei Borzenkov pushed to branch wip/int-index/hdk-register-tok at Glasgow Haskell Compiler / GHC


Commits:
e95b4eb4 by Vladislav Zavialov at 2023-06-09T13:56:50+04:00
Register LHsToken in Parser.PostProcess.Haddock

- - - - -


4 changed files:

- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr


Changes:

=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Parser.Annotation (
   AddEpAnn(..),
   EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,
   TokenLocation(..),
-  getTokenSrcSpan,
+  getTokenSrcSpan, getTokenBufSpan,
   DeltaPos(..), deltaPos, getDeltaLine,
 
   EpAnn(..), Anchor(..), AnchorOperation(..),
@@ -418,6 +418,11 @@ getTokenSrcSpan NoTokenLoc = noSrcSpan
 getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan
 getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos
 
+getTokenBufSpan :: TokenLocation -> Strict.Maybe BufSpan
+getTokenBufSpan (TokenLoc (EpaSpan _ mbspan)) = mbspan
+getTokenBufSpan (TokenLoc EpaDelta{}) = Strict.Nothing
+getTokenBufSpan NoTokenLoc = Strict.Nothing
+
 instance Outputable a => Outputable (GenLocated TokenLocation a) where
   ppr (L _ x) = ppr x
 


=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -62,7 +62,6 @@ import Data.Traversable
 import Data.Maybe
 import Data.List.NonEmpty (nonEmpty)
 import qualified Data.List.NonEmpty as NE
-import Control.Monad
 import Control.Monad.Trans.State.Strict
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Writer
@@ -249,15 +248,17 @@ instance HasHaddock (Located (HsModule GhcPs)) where
     --    module M where
     --
     -- Only do this when the module header exists.
-    headerDocs <-
-      for @Maybe (hsmodName mod) $ \(L l_name _) ->
-      extendHdkA (locA l_name) $ liftHdkA $ do
-        -- todo: register keyword location of 'module', see Note [Register keyword location]
-        docs <-
-          inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $
-          takeHdkComments mkDocNext
-        dc <- selectDocString docs
-        pure $ lexLHsDocString <$> dc
+    headerDocs <- case modToks of
+      HsNoModTk -> pure Nothing
+      _ ->
+        liftHdkA $ do
+          docs <-
+            inLocRange (locRangeTo (getBufPos (srcSpanStart modSigTokenLocation))) $
+            takeHdkComments mkDocNext
+          dc <- selectDocString docs
+          pure $ lexLHsDocString <$> dc
+
+    traverse_ @Maybe registerHdkA (hsmodName mod)
 
     -- Step 2, process documentation comments in the export list:
     --
@@ -272,6 +273,7 @@ instance HasHaddock (Located (HsModule GhcPs)) where
     --
     -- Only do this when the export list exists.
     hsmodExports' <- traverse @Maybe addHaddock (hsmodExports mod)
+    traverse_ @Strict.Maybe registerTokenHdkA whereTk
 
     -- Step 3, register the import section to reject invalid comments:
     --
@@ -295,7 +297,19 @@ instance HasHaddock (Located (HsModule GhcPs)) where
     pure $ L l_mod $
       mod { hsmodExports = hsmodExports'
           , hsmodDecls = hsmodDecls'
-          , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } }
+          , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } }
+    where
+      modToks = hsmodHeaderTokens mod
+
+      modSigTokenLocation = case modToks of
+        HsNoModTk        -> noSrcSpan
+        HsSigTk sigTok _ -> getTokenSrcSpan $ getLoc sigTok
+        HsModTk modTok _ -> getTokenSrcSpan $ getLoc modTok
+
+      whereTk = case modToks of
+        HsNoModTk -> Strict.Nothing
+        HsSigTk _ tok -> Strict.Just tok
+        HsModTk _ tok -> Strict.Just tok
 
 lexHsDocString :: HsDocString -> HsDoc GhcPs
 lexHsDocString = lexHsDoc parseIdentifier
@@ -313,7 +327,6 @@ instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where
   addHaddock (L l_exports exports) =
     extendHdkA (locA l_exports) $ do
       exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports
-      registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis
       pure $ L l_exports exports'
 
 -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
@@ -481,13 +494,18 @@ instance HasHaddock (HsDecl GhcPs) where
   addHaddock (TyClD x decl)
     | DataDecl { tcdDExt, tcdTkNewOrData, tcdLName, tcdTyVars, tcdTkWhere, tcdFixity, tcdDataDefn = defn } <- decl
     = do
+        registerNewOrDataTokHdkA tcdTkNewOrData
         registerHdkA tcdLName
+        traverse_ @Strict.Maybe registerTokenHdkA tcdTkWhere
         defn' <- addHaddock defn
         pure $
           TyClD x (DataDecl {
             tcdDExt, tcdTkNewOrData,
             tcdLName, tcdTyVars, tcdTkWhere, tcdFixity,
             tcdDataDefn = defn' })
+    where
+      registerNewOrDataTokHdkA (NewTypeToken tok) = registerTokenHdkA tok
+      registerNewOrDataTokHdkA (DataTypeToken tok) = registerTokenHdkA tok
 
   -- Class declarations:
   --
@@ -502,8 +520,9 @@ instance HasHaddock (HsDecl GhcPs) where
                   tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,
                   tcdTkWhere, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl
     = do
+        registerTokenHdkA tcdTkClass
         registerHdkA tcdLName
-        -- todo: register keyword location of 'where', see Note [Register keyword location]
+        traverse_ @Strict.Maybe registerTokenHdkA tcdTkWhere
         where_cls' <-
           addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $
           flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])
@@ -1158,6 +1177,13 @@ registerLocHdkA l = HdkA (getBufSpan l) (pure ())
 registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()
 registerHdkA a = registerLocHdkA (getLocA a)
 
+-- Let the neighbours know about a token at this location.
+-- Similar to registerLocHdkA and registerHdkA.
+--
+-- See Note [Adding Haddock comments to the syntax tree].
+registerTokenHdkA :: LHsToken tok GhcPs -> HdkA ()
+registerTokenHdkA (L l _) = HdkA (getTokenBufSpan l) (pure ())
+
 -- Modify the action of a HdkA computation.
 hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
 hoistHdkA f (HdkA l m) = HdkA l (f m)


=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
=====================================
@@ -1,16 +1,16 @@
 {-# LANGUAGE GADTs #-}
 {-# OPTIONS -haddock -ddump-parsed-ast #-}
 
--- Haddock comments in this test case should all be rejected, but they are not.
---
--- This is a known issue. Users should avoid writing comments in such
--- positions, as a future fix will disallow them.
+-- Haddock comments in this test case all are rejected.
 --
 -- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock
 
 module
   -- | Bad comment for the module
-  T17544_kw where
+  T17544_kw (
+  Foo(..),
+  Bar(..),
+  Cls(..)) where
 
 data Foo -- | Bad comment for MkFoo
   where MkFoo :: Foo


=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -10,8 +10,8 @@
      { T17544_kw.hs:1:1 }
      (UnchangedAnchor))
     (AnnsModule
-     [(AddEpAnn AnnModule (EpaSpan { T17544_kw.hs:11:1-6 }))
-     ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:13:13-17 }))]
+     [(AddEpAnn AnnModule (EpaSpan { T17544_kw.hs:8:1-6 }))
+     ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:13:12-16 }))]
      []
      (Just
       ((,)
@@ -23,33 +23,115 @@
    (VirtualBraces
     (1))
    (Nothing)
-   (Just
-    (L
-     { T17544_kw.hs:12:3-33 }
-     (WithHsDocIdentifiers
-      (MultiLineDocString
-       (HsDocStringNext)
-       (:|
-        (L
-         { T17544_kw.hs:12:7-33 }
-         (HsDocStringChunk
-          " Bad comment for the module"))
-        []))
-      []))))
+   (Nothing))
   (HsModTk
    (L
     (TokenLoc
-     (EpaSpan { T17544_kw.hs:11:1-6 }))
+     (EpaSpan { T17544_kw.hs:8:1-6 }))
     (HsTok))
    (L
     (TokenLoc
-     (EpaSpan { T17544_kw.hs:13:13-17 }))
+     (EpaSpan { T17544_kw.hs:13:12-16 }))
     (HsTok)))
   (Just
    (L
-    (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:13:3-11 })
+    (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:10:3-11 })
     {ModuleName: T17544_kw}))
-  (Nothing)
+  (Just
+   (L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { T17544_kw.hs:(10,13)-(13,10) }
+                  (UnchangedAnchor))
+                 (AnnList
+                  (Nothing)
+                  (Just
+                   (AddEpAnn AnnOpenP (EpaSpan { T17544_kw.hs:10:13 })))
+                  (Just
+                   (AddEpAnn AnnCloseP (EpaSpan { T17544_kw.hs:13:10 })))
+                  []
+                  [])
+                 (EpaComments
+                  [])) { T17544_kw.hs:(10,13)-(13,10) })
+    [(L
+      (SrcSpanAnn (EpAnn
+                   (Anchor
+                    { T17544_kw.hs:11:3-9 }
+                    (UnchangedAnchor))
+                   (AnnListItem
+                    [(AddCommaAnn
+                      (EpaSpan { T17544_kw.hs:11:10 }))])
+                   (EpaComments
+                    [])) { T17544_kw.hs:11:3-9 })
+      (IEThingAll
+       (EpAnn
+        (Anchor
+         { T17544_kw.hs:11:3-5 }
+         (UnchangedAnchor))
+        [(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:11:7-8 }))
+        ,(AddEpAnn AnnOpenP (EpaSpan { T17544_kw.hs:11:6 }))
+        ,(AddEpAnn AnnCloseP (EpaSpan { T17544_kw.hs:11:9 }))
+        ,(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:11:7-8 }))]
+        (EpaComments
+         []))
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:11:3-5 })
+        (IEName
+         (NoExtField)
+         (L
+          (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:11:3-5 })
+          (Unqual
+           {OccName: Foo}))))))
+    ,(L
+      (SrcSpanAnn (EpAnn
+                   (Anchor
+                    { T17544_kw.hs:12:3-9 }
+                    (UnchangedAnchor))
+                   (AnnListItem
+                    [(AddCommaAnn
+                      (EpaSpan { T17544_kw.hs:12:10 }))])
+                   (EpaComments
+                    [])) { T17544_kw.hs:12:3-9 })
+      (IEThingAll
+       (EpAnn
+        (Anchor
+         { T17544_kw.hs:12:3-5 }
+         (UnchangedAnchor))
+        [(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:12:7-8 }))
+        ,(AddEpAnn AnnOpenP (EpaSpan { T17544_kw.hs:12:6 }))
+        ,(AddEpAnn AnnCloseP (EpaSpan { T17544_kw.hs:12:9 }))
+        ,(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:12:7-8 }))]
+        (EpaComments
+         []))
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:12:3-5 })
+        (IEName
+         (NoExtField)
+         (L
+          (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:12:3-5 })
+          (Unqual
+           {OccName: Bar}))))))
+    ,(L
+      (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:13:3-9 })
+      (IEThingAll
+       (EpAnn
+        (Anchor
+         { T17544_kw.hs:13:3-5 }
+         (UnchangedAnchor))
+        [(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:13:7-8 }))
+        ,(AddEpAnn AnnOpenP (EpaSpan { T17544_kw.hs:13:6 }))
+        ,(AddEpAnn AnnCloseP (EpaSpan { T17544_kw.hs:13:9 }))
+        ,(AddEpAnn AnnDotdot (EpaSpan { T17544_kw.hs:13:7-8 }))]
+        (EpaComments
+         []))
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:13:3-5 })
+        (IEName
+         (NoExtField)
+         (L
+          (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:13:3-5 })
+          (Unqual
+           {OccName: Cls}))))))]))
   []
   [(L
     (SrcSpanAnn (EpAnn
@@ -138,19 +220,7 @@
               (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:16:18-20 })
               (Unqual
                {OccName: Foo}))))
-           (Just
-            (L
-             { T17544_kw.hs:15:10-35 }
-             (WithHsDocIdentifiers
-              (MultiLineDocString
-               (HsDocStringNext)
-               (:|
-                (L
-                 { T17544_kw.hs:15:14-35 }
-                 (HsDocStringChunk
-                  " Bad comment for MkFoo"))
-                []))
-              [])))))])
+           (Nothing)))])
        []))))
   ,(L
     (SrcSpanAnn (EpAnn
@@ -265,19 +335,7 @@
              (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:19:24-26 })
              (Unqual
               {OccName: Bar}))))
-          (Just
-           (L
-            { T17544_kw.hs:18:13-38 }
-            (WithHsDocIdentifiers
-             (MultiLineDocString
-              (HsDocStringNext)
-              (:|
-               (L
-                { T17544_kw.hs:18:17-38 }
-                (HsDocStringChunk
-                 " Bad comment for MkBar"))
-               []))
-             []))))))
+          (Nothing))))
        []))))
   ,(L
     (SrcSpanAnn (EpAnn
@@ -378,20 +436,18 @@
        []}
       []
       []
-      [(L
-        (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:22:5-34 })
-        (DocCommentNext
-         (L
-          { T17544_kw.hs:22:5-34 }
-          (WithHsDocIdentifiers
-           (MultiLineDocString
-            (HsDocStringNext)
-            (:|
-             (L
-              { T17544_kw.hs:22:9-34 }
-              (HsDocStringChunk
-               " Bad comment for clsmethod"))
-             []))
-           []))))])))]))
+      [])))]))
+
+
+
+T17544_kw.hs:9:3: warning: [GHC-94458] [-Winvalid-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
+
+T17544_kw.hs:15:10: warning: [GHC-94458] [-Winvalid-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
 
+T17544_kw.hs:18:13: warning: [GHC-94458] [-Winvalid-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.
 
+T17544_kw.hs:22:5: warning: [GHC-94458] [-Winvalid-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e95b4eb406ccc24ce1d30cea104b7ac04bdac3e6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e95b4eb406ccc24ce1d30cea104b7ac04bdac3e6
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/20230609/2b1be95d/attachment-0001.html>


More information about the ghc-commits mailing list