WIP: Register LHsToken in Parser.PostProcess.Haddockwip/int-index/hdk-register-tok

4 files changed, 20 insertions, 17 deletions

diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 7b7fccc862..830f66b4fe 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -15,6 +15,7 @@ module GHC.Parser.Annotation (
   AddEpAnn(..),
   EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,
   TokenLocation(..),
+  getTokenBufSpan,
   DeltaPos(..), deltaPos, getDeltaLine,
 
   EpAnn(..), Anchor(..), AnchorOperation(..),
@@ -412,6 +413,11 @@ data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
 data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
                deriving (Data,Eq)
 
+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
 
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index cf1f233140..9df3d20d61 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -502,8 +502,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 +1159,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)
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
index 4acf2af68d..8f90c6bccd 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# OPTIONS -haddock -ddump-parsed-ast #-}
 
--- Haddock comments in this test case should all be rejected, but they are not.
+-- Haddock comments in this test case should all be rejected, but some of them are not.
 --
 -- This is a known issue. Users should avoid writing comments in such
 -- positions, as a future fix will disallow them.
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
index c4eee108ce..047cd3bb01 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
@@ -356,20 +356,9 @@
        []}
       []
       []
-      [(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:22:5: warning: [GHC-94458] [-Winvalid-haddock]
+    A Haddock comment cannot appear in this position and will be ignored.