summaryrefslogtreecommitdiff
path: root/compiler/parser/Lexer.x
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser/Lexer.x')
-rw-r--r--compiler/parser/Lexer.x93
1 files changed, 64 insertions, 29 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index fc6779a..8598bdf 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -66,7 +66,8 @@ module Lexer (
lexTokenStream,
AddAnn(..),mkParensApiAnn,
addAnnsAt,
- commentToAnnotation
+ commentToAnnotation,
+ HdkComment(..),
) where
import GhcPrelude
@@ -99,6 +100,7 @@ import Outputable
import StringBuffer
import FastString
import UniqFM
+import Maybes
import Util ( readRational, readHexRational )
-- compiler/main
@@ -111,6 +113,7 @@ import Module
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..),
IntegralLit(..), FractionalLit(..),
SourceText(..) )
+import GHC.Hs.Doc
-- compiler/parser
import Ctype
@@ -1193,11 +1196,8 @@ nested_comment cont span buf len = do
go (reverse $ lexemeToString buf len) (1::Int) input
where
go commentAcc 0 input = do
- setInput input
- b <- getBit RawTokenStreamBit
- if b
- then docCommentEnd input commentAcc ITblockComment buf span
- else cont
+ let finalizeComment str = (Nothing, ITblockComment str)
+ commentEnd cont input commentAcc finalizeComment buf span
go commentAcc n input = case alexGetChar' input of
Nothing -> errBrace input span
Just ('-',input) -> case alexGetChar' input of
@@ -1287,24 +1287,37 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token.
See #314 for more background on the bug this fixes.
-}
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (RealLocated Token))
-> P (RealLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
-- The `Bool` argument to lexDocComment signals whether or not the next
-- line of input might also belong to this doc comment.
- '|' -> lexDocComment input ITdocCommentNext True
- '^' -> lexDocComment input ITdocCommentPrev True
- '$' -> lexDocComment input ITdocCommentNamed True
+ '|' -> lexDocComment input mkHdkCommentNext True
+ '^' -> lexDocComment input mkHdkCommentPrev True
+ '$' -> lexDocComment input mkHdkCommentNamed True
'*' -> lexDocSection 1 input
_ -> panic "withLexedDocType: Bad doc type"
where
lexDocSection n input = case alexGetChar' input of
Just ('*', input) -> lexDocSection (n+1) input
- Just (_, _) -> lexDocComment input (ITdocSection n) False
+ Just (_, _) -> lexDocComment input (mkHdkCommentSection n) False
Nothing -> do setInput input; lexToken -- eof reached, lex it normally
+mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token)
+mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str)
+mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str)
+
+mkHdkCommentNamed :: String -> (HdkComment, Token)
+mkHdkCommentNamed str =
+ let (name, rest) = break isSpace str
+ in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str)
+
+mkHdkCommentSection :: Int -> String -> (HdkComment, Token)
+mkHdkCommentSection n str =
+ (HdkCommentSection n (mkHsDocString str), ITdocSection n str)
+
-- RULES pragmas turn on the forall and '.' keywords, and we turn them
-- off again at the end of the pragma.
rulePrag :: Action
@@ -1347,9 +1360,14 @@ endPrag span _buf _len = do
-- it writes the wrong token length to the parser state. This function is
-- called afterwards, so it can just update the state.
-docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- RealSrcSpan -> P (RealLocated Token)
-docCommentEnd input commentAcc docType buf span = do
+commentEnd :: P (RealLocated Token)
+ -> AlexInput
+ -> String
+ -> (String -> (Maybe HdkComment, Token))
+ -> StringBuffer
+ -> RealSrcSpan
+ -> P (RealLocated Token)
+commentEnd cont input commentAcc finalizeComment buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
@@ -1357,7 +1375,20 @@ docCommentEnd input commentAcc docType buf span = do
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
- return (L span' (docType comment))
+ let (m_hdk_comment, hdk_token) = finalizeComment comment
+ whenIsJust m_hdk_comment $ \hdk_comment ->
+ P $ \s -> POk (s {hdk_comments = L span' hdk_comment : hdk_comments s}) ()
+ b <- getBit RawTokenStreamBit
+ if b then return (L span' hdk_token)
+ else cont
+
+docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer ->
+ RealSrcSpan -> P (RealLocated Token)
+docCommentEnd input commentAcc docType buf span = do
+ let finalizeComment str =
+ let (hdk_comment, token) = docType str
+ in (Just hdk_comment, token)
+ commentEnd lexToken input commentAcc finalizeComment buf span
errBrace :: AlexInput -> RealSrcSpan -> P a
errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
@@ -2085,6 +2116,13 @@ data ParserFlags = ParserFlags {
, pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions
}
+data HdkComment
+ = HdkCommentNext HsDocString
+ | HdkCommentPrev HsDocString
+ | HdkCommentNamed String HsDocString
+ | HdkCommentSection Int HsDocString
+ deriving Show
+
data PState = PState {
buffer :: StringBuffer,
options :: ParserFlags,
@@ -2125,7 +2163,10 @@ data PState = PState {
-- See note [Api annotations] in ApiAnnotation.hs
annotations :: [(ApiAnnKey,[SrcSpan])],
comment_q :: [Located AnnotationComment],
- annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+ annotations_comments :: [(SrcSpan,[Located AnnotationComment])],
+
+ -- Haddock comments
+ hdk_comments :: [RealLocated HdkComment]
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
@@ -2599,7 +2640,8 @@ mkPStatePure options buf loc =
alr_justClosedExplicitLetBlock = False,
annotations = [],
comment_q = [],
- annotations_comments = []
+ annotations_comments = [],
+ hdk_comments = []
}
-- | An mtl-style class for monads that support parsing-related operations.
@@ -2819,10 +2861,6 @@ lexer queueComments cont = do
ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
_ -> return ()
- if (queueComments && isDocComment tok)
- then queueComment (L (RealSrcSpan span) tok)
- else return ()
-
if (queueComments && isComment tok)
then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
else cont (L (RealSrcSpan span) tok)
@@ -3269,13 +3307,10 @@ commentToAnnotation _ = panic "commentToAnnotation"
isComment :: Token -> Bool
isComment (ITlineComment _) = True
isComment (ITblockComment _) = True
+isComment (ITdocCommentNext _) = True
+isComment (ITdocCommentPrev _) = True
+isComment (ITdocCommentNamed _) = True
+isComment (ITdocSection _ _) = True
+isComment (ITdocOptions _) = True
isComment _ = False
-
-isDocComment :: Token -> Bool
-isDocComment (ITdocCommentNext _) = True
-isDocComment (ITdocCommentPrev _) = True
-isDocComment (ITdocCommentNamed _) = True
-isDocComment (ITdocSection _ _) = True
-isDocComment (ITdocOptions _) = True
-isDocComment _ = False
}
generated by cgit v0.10.2-6-g49f6 at 2024-06-03 16:18:36 (GMT)