[commit: ghc] master: ApiAnnotations : lexer discards comment close in nested comment (5fded20)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/5fded20c51ae61770f909351c851aaca3d3e331c/ghc

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

commit 5fded20c51ae61770f909351c851aaca3d3e331c
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date:   Tue Apr 14 07:32:52 2015 -0500

    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


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

5fded20c51ae61770f909351c851aaca3d3e331c
 compiler/parser/Lexer.x                            |  6 +++---
 .../ghc-api/annotations-literals/literals.stdout   |  2 +-
 .../tests/ghc-api/annotations/CommentsTest.hs      |  2 ++
 .../tests/ghc-api/annotations/comments.stdout      | 22 +++++++++++-----------
 4 files changed, 17 insertions(+), 15 deletions(-)

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e451b5f..1be7245 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 ded26da..ff4f63f 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 ce0f336..c6cf79c 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 25cf555..06273ba 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 #-}")])
 ]