[commit: ghc] master: Handle multiline named haddock comments properly (6350eb1)

git at git.haskell.org git at git.haskell.org
Thu Feb 25 16:16:53 UTC 2016


Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6350eb1126e29b93829de688623c91b772f6d9eb/ghc

>---------------------------------------------------------------

commit 6350eb1126e29b93829de688623c91b772f6d9eb
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


>---------------------------------------------------------------

6350eb1126e29b93829de688623c91b772f6d9eb
 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 3f959f2..7147802 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -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
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 8aa2ede..3859d53 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -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'])



More information about the ghc-commits mailing list