Ignore comments in getOptions
authorMatthew Pickering <matthewtpickering@gmail.com>
Thu, 12 Nov 2015 19:33:39 +0000 (20:33 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 12 Nov 2015 19:33:39 +0000 (20:33 +0100)
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

compiler/main/HeaderInfo.hs
testsuite/tests/ghc-api/T10942.hs [new file with mode: 0644]
testsuite/tests/ghc-api/T10942.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/T10942_A.hs [new file with mode: 0644]
testsuite/tests/ghc-api/all.T

index 08c7619..35107c8 100644 (file)
@@ -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 (file)
index 0000000..6fbf1d5
--- /dev/null
@@ -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 (file)
index 0000000..40ead27
--- /dev/null
@@ -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 (file)
index 0000000..359961c
--- /dev/null
@@ -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 ()
index c4783ea..dee74b7 100644 (file)
@@ -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'])