ApiAnnotations : lexer discards comment close in nested comment

When parsing a nested comment, such as

{-
  {-  nested comment  -}
  {-# nested pragma  #-}
-}

The lexer returns the comment annotation as

{-
  {-  nested comment
  {-# nested pragma  #
-}

Restore the missing comment end markers in the annotation.

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D829

GHC Trac Issues: #10277

4 files changed, 17 insertions, 15 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e451b5ffea..1be724526f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -970,7 +970,7 @@ lineCommentToken span buf len = do
 nested_comment :: P (RealLocated Token) -> Action
 nested_comment cont span buf len = do
   input <- getInput
-  go (reverse $ drop 2 $ lexemeToString buf len) (1::Int) input
+  go (reverse $ lexemeToString buf len) (1::Int) input
   where
     go commentAcc 0 input = do
       setInput input
@@ -982,9 +982,9 @@ nested_comment cont span buf len = do
       Nothing -> errBrace input span
       Just ('-',input) -> case alexGetChar' input of
         Nothing  -> errBrace input span
-        Just ('\125',input) -> go commentAcc (n-1) input
+        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
         Just (_,_)          -> go ('-':commentAcc) n input
-      Just ('\123',input) -> case alexGetChar' input of
+      Just ('\123',input) -> case alexGetChar' input of  -- '{' char
         Nothing  -> errBrace input span
         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
         Just (_,_)       -> go ('\123':commentAcc) n input
diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
index ded26dadcd..ff4f63f183 100644
--- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
@@ -1,4 +1,4 @@
-(LiteralsTest.hs:1:1-26,ITblockComment "# LANGUAGE MagicHash #",[{-# LANGUAGE MagicHash #-}]),
+(LiteralsTest.hs:1:1-26,ITblockComment "{-# LANGUAGE MagicHash #-}",[{-# LANGUAGE MagicHash #-}]),
 
 (LiteralsTest.hs:2:1-6,ITmodule,[module]),
 
diff --git a/testsuite/tests/ghc-api/annotations/CommentsTest.hs b/testsuite/tests/ghc-api/annotations/CommentsTest.hs
index ce0f336d39..c6cf79c5da 100644
--- a/testsuite/tests/ghc-api/annotations/CommentsTest.hs
+++ b/testsuite/tests/ghc-api/annotations/CommentsTest.hs
@@ -2,6 +2,8 @@
 module CommentsTest (foo) where
 {-
 An opening comment
+  {- with a nested one -}
+  {-# nested PRAGMA #-}
 -}
 
 import qualified Data.List as DL
diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout
index 25cf55557c..06273ba1e6 100644
--- a/testsuite/tests/ghc-api/annotations/comments.stdout
+++ b/testsuite/tests/ghc-api/annotations/comments.stdout
@@ -1,25 +1,25 @@
 [
-( CommentsTest.hs:9:1-33 =
-[(CommentsTest.hs:9:1-33,AnnDocCommentNext " The function @foo@ does blah")])
+( CommentsTest.hs:11:1-33 =
+[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah")])
 
-( CommentsTest.hs:(10,7)-(13,14) =
-[(CommentsTest.hs:12:15-24,AnnLineComment "-- value 2")])
+( CommentsTest.hs:(12,7)-(15,14) =
+[(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")])
 
 ( <no location info> =
-[(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
+[(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n  {- with a nested one -}\n  {-# nested PRAGMA #-}\n-}"),
 
-(CommentsTest.hs:1:1-31,AnnBlockComment "# LANGUAGE DeriveFoldable #")])
+(CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")])
 ]
 
 [
-( CommentsTest.hs:(10,7)-(13,14) =
-[(CommentsTest.hs:12:15-24,AnnLineComment "-- value 2")])
+( CommentsTest.hs:(12,7)-(15,14) =
+[(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")])
 
 ( <no location info> =
-[(CommentsTest.hs:9:1-33,AnnLineComment "-- | The function @foo@ does blah"),
+[(CommentsTest.hs:11:1-33,AnnLineComment "-- | The function @foo@ does blah"),
 
-(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
+(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n  {- with a nested one -}\n  {-# nested PRAGMA #-}\n-}"),
 
-(CommentsTest.hs:1:1-31,AnnBlockComment "# LANGUAGE DeriveFoldable #")])
+(CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")])
 ]