[commit: ghc] master: Ignore comments in getOptions (5d6133b)

[git at git.haskell.org]

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

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

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

commit 5d6133bec0f682e86ee31bbdb6d82e6fb2ede8f7
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Thu Nov 12 20:33:39 2015 +0100

    Ignore comments in getOptions
    
    When Opt_KeepRawTokenStream is turned on then getOptions fails to find
    the language pragmas which can cause unexpected parse errors when using
    the GHC API. A simple solution is to make it skip over any comments in
    the token
    stream.
    
    Test Plan: ./validate
    
    Reviewers: austin, bgamari
    
    Subscribers: alanz, thomie
    
    Differential Revision: https://phabricator.haskell.org/D1444
    
    GHC Trac Issues: #10942


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

5d6133bec0f682e86ee31bbdb6d82e6fb2ede8f7
 compiler/main/HeaderInfo.hs           | 14 ++++++++++++++
 testsuite/tests/ghc-api/T10942.hs     | 22 ++++++++++++++++++++++
 testsuite/tests/ghc-api/T10942.stdout |  1 +
 testsuite/tests/ghc-api/T10942_A.hs   | 16 ++++++++++++++++
 testsuite/tests/ghc-api/all.T         |  3 +++
 5 files changed, 56 insertions(+)

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 08c7619..35107c8 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -256,6 +256,9 @@ getOptions' dflags toks
           parseToks (open:xs)
               | ITlanguage_prag <- getToken open
               = parseLanguage xs
+          parseToks (comment:xs) -- Skip over comments
+              | isComment (getToken comment)
+              = parseToks xs
           parseToks _ = []
           parseLanguage (L loc (ITconid fs):rest)
               = checkExtension dflags (L loc fs) :
@@ -269,6 +272,17 @@ getOptions' dflags toks
           parseLanguage []
               = panic "getOptions'.parseLanguage(2) went past eof token"
 
+          isComment :: Token -> Bool
+          isComment c =
+            case c of
+              (ITlineComment {})     -> True
+              (ITblockComment {})    -> True
+              (ITdocCommentNext {})  -> True
+              (ITdocCommentPrev {})  -> True
+              (ITdocCommentNamed {}) -> True
+              (ITdocSection {})      -> True
+              _                      -> False
+
 -----------------------------------------------------------------------------
 
 -- | Complain about non-dynamic flags in OPTIONS pragmas.
diff --git a/testsuite/tests/ghc-api/T10942.hs b/testsuite/tests/ghc-api/T10942.hs
new file mode 100644
index 0000000..6fbf1d5
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10942.hs
@@ -0,0 +1,22 @@
+module Main where
+
+import DynFlags
+import GHC
+
+import Control.Monad.IO.Class (liftIO)
+import System.Environment
+import HeaderInfo
+import Outputable
+import StringBuffer
+
+main :: IO ()
+main = do
+  [libdir] <- getArgs
+  runGhc (Just libdir) $ do
+    dflags <- getSessionDynFlags
+    let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream
+                         `gopt_set` Opt_Haddock
+        filename = "T10942_A.hs"
+    setSessionDynFlags dflags'
+    stringBuffer <- liftIO $ hGetStringBuffer filename
+    liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename))
diff --git a/testsuite/tests/ghc-api/T10942.stdout b/testsuite/tests/ghc-api/T10942.stdout
new file mode 100644
index 0000000..40ead27
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10942.stdout
@@ -0,0 +1 @@
+["-XFlexibleInstances","-XCPP"]
diff --git a/testsuite/tests/ghc-api/T10942_A.hs b/testsuite/tests/ghc-api/T10942_A.hs
new file mode 100644
index 0000000..359961c
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10942_A.hs
@@ -0,0 +1,16 @@
+{-
+
+A normal comment, to check if we can still pick up the CPP directive after it.
+
+-}
+-- Check that we can parse a file with leading comments
+
+-- ^ haddock
+-- * haddock
+-- | haddock
+-- $ haddock
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+module T10942 where
+
+main = return ()
diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T
index c4783ea..dee74b7 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -14,3 +14,6 @@ test('T9595', extra_run_opts('"' + config.libdir + '"'),
 test('T10508_api', extra_run_opts('"' + config.libdir + '"'),
                    compile_and_run,
                    ['-package ghc'])
+test('T10942', extra_run_opts('"' + config.libdir + '"'),
+                   compile_and_run,
+                   ['-package ghc'])