Handle multiline named haddock comments properly
authorThomas Miedema <thomasmiedema@gmail.com>
Thu, 25 Feb 2016 14:51:38 +0000 (15:51 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 25 Feb 2016 16:18:27 +0000 (17:18 +0100)
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

compiler/parser/Lexer.x
libraries/base/GHC/ExecutionStack.hs
testsuite/tests/ghc-api/T11579.hs [new file with mode: 0644]
testsuite/tests/ghc-api/T11579.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/all.T

index 3f959f2..7147802 100644 (file)
@@ -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
index 11f8c9e..22be903 100644 (file)
@@ -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")
 -- @
 --
diff --git a/testsuite/tests/ghc-api/T11579.hs b/testsuite/tests/ghc-api/T11579.hs
new file mode 100644 (file)
index 0000000..3294f99
--- /dev/null
@@ -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 (file)
index 0000000..7603e53
--- /dev/null
@@ -0,0 +1 @@
+ITdocCommentNamed "bar some\n named chunk"
index 8aa2ede..3859d53 100644 (file)
@@ -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'])