[commit: ghc] ghc-8.0: Handle multiline named haddock comments properly (a69542b)
git at git.haskell.org
git at git.haskell.org
Sat Feb 27 15:21:33 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/a69542ba51f7dd1d77b2e16f2b3259263cc375f6/ghc
>---------------------------------------------------------------
commit a69542ba51f7dd1d77b2e16f2b3259263cc375f6
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date: Thu Feb 25 15:51:38 2016 +0100
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
(cherry picked from commit 6350eb1126e29b93829de688623c91b772f6d9eb)
>---------------------------------------------------------------
a69542ba51f7dd1d77b2e16f2b3259263cc375f6
compiler/parser/Lexer.x | 43 +++++++++++++++++++++++------------
libraries/base/GHC/ExecutionStack.hs | 2 +-
testsuite/tests/ghc-api/T11579.hs | 26 +++++++++++++++++++++
testsuite/tests/ghc-api/T11579.stdout | 1 +
testsuite/tests/ghc-api/all.T | 2 ++
5 files changed, 58 insertions(+), 16 deletions(-)
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index b3b73f6..899849c 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -981,24 +981,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')
@@ -1062,8 +1073,10 @@ 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
'#' -> lexDocComment input ITdocOptionsOld False
@@ -1071,7 +1084,7 @@ withLexedDocType lexDocComment = do
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
diff --git a/libraries/base/GHC/ExecutionStack.hs b/libraries/base/GHC/ExecutionStack.hs
index 11f8c9e..22be903 100644
--- a/libraries/base/GHC/ExecutionStack.hs
+++ b/libraries/base/GHC/ExecutionStack.hs
@@ -22,7 +22,7 @@
-- Your GHC must have been built with @libdw@ support for this to work.
--
-- @
--- $ ghc --info | grep libdw
+-- user at host:~$ ghc --info | grep libdw
-- ,("RTS expects libdw","YES")
-- @
--
diff --git a/testsuite/tests/ghc-api/T11579.hs b/testsuite/tests/ghc-api/T11579.hs
new file mode 100644
index 0000000..3294f99
--- /dev/null
+++ b/testsuite/tests/ghc-api/T11579.hs
@@ -0,0 +1,26 @@
+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
diff --git a/testsuite/tests/ghc-api/T11579.stdout b/testsuite/tests/ghc-api/T11579.stdout
new file mode 100644
index 0000000..7603e53
--- /dev/null
+++ b/testsuite/tests/ghc-api/T11579.stdout
@@ -0,0 +1 @@
+ITdocCommentNamed "bar some\n named chunk"
diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T
index e3e31da..a5267a2 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -20,3 +20,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'])
More information about the ghc-commits
mailing list