[Git][ghc/ghc][wip/int-index/hdk-register-tok] Register LHsToken in Parser.PostProcess.Haddock
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Tue May 30 08:21:08 UTC 2023
Andrei Borzenkov pushed to branch wip/int-index/hdk-register-tok at Glasgow Haskell Compiler / GHC
Commits:
b70a5859 by Vladislav Zavialov at 2023-05-30T12:20:52+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 hsmodHeaderTokens mod of
+ HsNoModTk -> pure Nothing
+ modToks ->
+ liftHdkA $ do
+ docs <-
+ inLocRange (locRangeTo (getBufPos (srcSpanStart (modSigTokenLocation modToks)))) $
+ 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)
+ registerWhereTokenHdkA (hsmodHeaderTokens mod)
-- Step 3, register the import section to reject invalid comments:
--
@@ -295,7 +297,15 @@ 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
+ modSigTokenLocation HsNoModTk = noSrcSpan
+ modSigTokenLocation (HsSigTk sigTok _) = getTokenSrcSpan $ getLoc sigTok
+ modSigTokenLocation (HsModTk modTok _) = getTokenSrcSpan $ getLoc modTok
+
+ registerWhereTokenHdkA HsNoModTk = pure ()
+ registerWhereTokenHdkA (HsSigTk _ whereTok) = registerTokenHdkA whereTok
+ registerWhereTokenHdkA (HsModTk _ whereTok) = registerTokenHdkA whereTok
lexHsDocString :: HsDocString -> HsDoc GhcPs
lexHsDocString = lexHsDoc parseIdentifier
@@ -313,7 +323,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 +490,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 +516,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 +1173,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/b70a58593bc0477fd90e0c0836fe9f837f7e169f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b70a58593bc0477fd90e0c0836fe9f837f7e169f
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/20230530/729c9dd7/attachment-0001.html>
More information about the ghc-commits
mailing list