Commit 6350eb11 authored by thomie's avatar thomie Committed by Ben Gamari

Handle multiline named haddock comments properly

Fixes #10398 in a different way, thereby also fixing #11579.

I inverted the logic of the Bool argument to "worker", to hopefully make
it more self-explanatory.

Reviewers: austin, hvr, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D1935
parent 67393977
......@@ -970,24 +970,35 @@ ifExtension pred bits _ _ _ = pred bits
multiline_doc_comment :: Action
multiline_doc_comment span buf _len = withLexedDocType (worker "")
where
worker commentAcc input docType oneLine = case alexGetChar' input of
worker commentAcc input docType checkNextLine = case alexGetChar' input of
Just ('\n', input')
| oneLine -> docCommentEnd input commentAcc docType buf span
| otherwise -> case checkIfCommentLine input' of
Just input -> worker ('\n':commentAcc) input docType False
| checkNextLine -> case checkIfCommentLine input' of
Just input -> worker ('\n':commentAcc) input docType checkNextLine
Nothing -> docCommentEnd input commentAcc docType buf span
Just (c, input) -> worker (c:commentAcc) input docType oneLine
| otherwise -> docCommentEnd input commentAcc docType buf span
Just (c, input) -> worker (c:commentAcc) input docType checkNextLine
Nothing -> docCommentEnd input commentAcc docType buf span
-- Check if the next line of input belongs to this doc comment as well.
-- A doc comment continues onto the next line when the following
-- conditions are met:
-- * The line starts with "--"
-- * The line doesn't start with "---".
-- * The line doesn't start with "-- $", because that would be the
-- start of a /new/ named haddock chunk (#10398).
checkIfCommentLine :: AlexInput -> Maybe AlexInput
checkIfCommentLine input = check (dropNonNewlineSpace input)
where
check input = case alexGetChar' input of
Just ('-', input) -> case alexGetChar' input of
Just ('-', input) -> case alexGetChar' input of
Just (c, _) | c /= '-' -> Just input
_ -> Nothing
_ -> Nothing
_ -> Nothing
check input = do
('-', input) <- alexGetChar' input
('-', input) <- alexGetChar' input
(c, after_c) <- alexGetChar' input
case c of
'-' -> Nothing
' ' -> case alexGetChar' after_c of
Just ('$', _) -> Nothing
_ -> Just input
_ -> Just input
dropNonNewlineSpace input = case alexGetChar' input of
Just (c, input')
......@@ -1051,15 +1062,17 @@ withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated To
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
'|' -> lexDocComment input ITdocCommentNext False
'^' -> lexDocComment input ITdocCommentPrev False
-- 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
'*' -> 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) True
Just (_, _) -> lexDocComment input (ITdocSection n) False
Nothing -> do setInput input; lexToken -- eof reached, lex it normally
-- RULES pragmas turn on the forall and '.' keywords, and we turn them
......
......@@ -22,7 +22,7 @@
-- Your GHC must have been built with @libdw@ support for this to work.
--
-- @
-- $ ghc --info | grep libdw
-- user@host:~$ ghc --info | grep libdw
-- ,("RTS expects libdw","YES")
-- @
--
......
import System.Environment
import DynFlags
import FastString
import GHC
import StringBuffer
import Lexer
import SrcLoc
main :: IO ()
main = do
[libdir] <- getArgs
let stringBuffer = stringToStringBuffer "-- $bar some\n-- named chunk"
loc = mkRealSrcLoc (mkFastString "Foo.hs") 1 1
token <- runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc
case unP (lexer False return) pstate of
POk _ token -> return (unLoc token)
_ -> error "No token"
-- #11579
-- Expected: "ITdocCommentNamed "bar some\n named chunk"
-- Actual (with ghc-8.0.1-rc2): "ITdocCommentNamed "bar some"
print token
ITdocCommentNamed "bar some\n named chunk"
......@@ -21,3 +21,5 @@ test('T10942', extra_run_opts('"' + config.libdir + '"'),
test('T9015', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
test('T11579', extra_run_opts('"' + config.libdir + '"'), compile_and_run,
['-package ghc'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment