Remove workaround for now-fixed Clang CPP bug (#1028)

Before LLVM 6.0.1 (or 10.0 on Apple LLVM), there was a bug where
lines that started with an octothorpe but turned out not
to lex like pragmas would have an extra line added after them.

Since this bug has been fixed upstream and that it doesn't have dire
consequences anyways, the workaround is not really worth it
anymore - we can just tell people to update their clang version (or re-structure
their pragma code).

7 files changed, 22 insertions, 416 deletions

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index f3cd93a3..04084fe1 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -59,7 +59,6 @@ library
                , directory
                , filepath
                , ghc-boot
-               , ghc-boot-th
                , transformers
 
   hs-source-dirs: src
@@ -186,7 +185,6 @@ test-suite spec
                , directory
                , filepath
                , ghc-boot
-               , ghc-boot-th
                , transformers
 
   build-tool-depends:
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 5ef7d9bb..251c886b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -25,7 +25,6 @@ import FastString     ( mkFastString )
 import Module         ( Module, moduleName )
 import NameCache      ( initNameCache )
 import UniqSupply     ( mkSplitUniqSupply )
-import SysTools.Info  ( getCompilerInfo' )
 
 
 -- | Generate hyperlinked source for given interfaces.
@@ -62,12 +61,11 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
                 , hie_types = types
                 , hie_hs_src = rawSrc
                 } <- fmap fst (readHieFile (initNameCache u []) hfp)
-        comp <- getCompilerInfo' df
 
         -- Get the AST and tokens corresponding to the source file we want
         let mast | M.size asts == 1 = snd <$> M.lookupMin asts
                  | otherwise        = M.lookup (mkFastString file) asts
-            tokens = parse comp df file rawSrc
+            tokens = parse df file rawSrc
 
         -- Produce and write out the hyperlinked sources
         case mast of
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 1d5576cc..0bd467e1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -6,13 +6,9 @@ import Control.Applicative ( Alternative(..) )
 import Data.List           ( isPrefixOf, isSuffixOf )
 
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BSC
-
-import GHC.LanguageExtensions.Type
 
 import BasicTypes          ( IntegralLit(..) )
 import DynFlags
-import qualified EnumSet as E
 import ErrUtils            ( emptyMessages )
 import FastString          ( mkFastString )
 import Lexer               ( P(..), ParseResult(..), PState(..), Token(..)
@@ -29,12 +25,11 @@ import Haddock.GhcUtils
 -- Result should retain original file layout (including comments,
 -- whitespace, and CPP).
 parse
-  :: CompilerInfo  -- ^ Underlying CC compiler (whatever expanded CPP)
-  -> DynFlags      -- ^ Flags for this module
+  :: DynFlags      -- ^ Flags for this module
   -> FilePath      -- ^ Path to the source of this module
   -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module
   -> [T.Token]
-parse comp dflags fpath bs = case unP (go False []) initState of
+parse dflags fpath bs = case unP (go False []) initState of
     POk _ toks -> reverse toks
     PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++
                                    ": " ++ showSDoc dflags errMsg
@@ -43,7 +38,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of
     initState = mkPStatePure pflags buf start
     buf = stringBufferFromByteString bs
     start = mkRealSrcLoc (mkFastString fpath) 1 1
-    needPragHack' = needPragHack comp dflags
     pflags = mkParserFlags' (warningFlags dflags)
                             (extensionFlags dflags)
                             (thisPackage dflags)
@@ -125,12 +119,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of
 
               pure (bEnd'', False)
 
-            -- See 'needPragHack'
-            ITclose_prag{}
-              | needPragHack'
-              , '\n' `BSC.elem` spaceBStr
-              -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False)
-
             _ -> pure (bEnd, inPragDef)
 
           let tokBStr = splitStringBuffer bStart bEnd'
@@ -155,37 +143,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of
       pure ([unkTok], False)
 
 
--- | This is really, really, /really/ gross. Problem: consider a Haskell
--- file that looks like:
---
--- @
--- {-# LANGUAGE CPP #-}
--- module SomeMod where
---
--- #define SIX 6
---
--- {-# INLINE foo
---   #-}
--- foo = 1
--- @
---
--- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it
--- should), but get confused about @#-}@. I'm guessing it /starts/ by
--- parsing that as a pre-processor directive and, when it fails to, it just
--- leaves the line alone. HOWEVER, it still adds an extra newline. =.=
---
--- This function makes sure that the Hyperlinker backend also adds that
--- extra newline (or else our spans won't line up with GHC's anymore).
-needPragHack :: CompilerInfo -> DynFlags -> Bool
-needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags)
-  where
-    isCcClang = case comp of
-      GCC -> False
-      Clang -> True
-      AppleClang -> True
-      AppleClang51 -> True
-      UnknownCC -> False
-
 -- | Get the input
 getInput :: P (StringBuffer, RealSrcLoc)
 getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index ff18cb40..1273a45a 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -5,8 +5,7 @@ import Test.Hspec
 import Test.QuickCheck
 
 import GHC           ( runGhc, getSessionDynFlags )
-import DynFlags      ( CompilerInfo, DynFlags )
-import SysTools.Info ( getCompilerInfo' )
+import DynFlags      ( DynFlags )
 import Control.Monad.IO.Class
 
 import Data.String     ( fromString )
@@ -17,13 +16,12 @@ import Haddock (getGhcDirs)
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Types
 
-withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO ()
+withDynFlags :: (DynFlags -> IO ()) -> IO ()
 withDynFlags cont = do
   libDir <- fmap snd (getGhcDirs [])
   runGhc (Just libDir) $ do
     dflags <- getSessionDynFlags
-    cinfo <- liftIO $ getCompilerInfo' dflags
-    liftIO $ cont (dflags, cinfo)
+    liftIO $ cont dflags
 
 
 main :: IO ()
@@ -60,60 +58,54 @@ instance Arbitrary NoGhcRewrite where
 parseSpec :: Spec
 parseSpec = around withDynFlags $ do
 
-    it "is total" $ \(dflags, cinfo) ->
-        property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0)
+    it "is total" $ \dflags ->
+        property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0)
 
-    it "retains file layout" $ \(dflags, cinfo) ->
+    it "retains file layout" $ \dflags ->
         property $ \(NoGhcRewrite src) ->
           let orig = fromString src
-              lexed = BS.concat (map tkValue (parse cinfo dflags "" orig))
+              lexed = BS.concat (map tkValue (parse dflags "" orig))
           in lexed == orig 
 
     context "when parsing single-line comments" $ do
 
-        it "should ignore content until the end of line" $ \(dflags, cinfo) ->
+        it "should ignore content until the end of line" $ \dflags ->
             shouldParseTo
                 "-- some very simple comment\nidentifier"
                 [TkComment, TkSpace, TkIdentifier]
-                cinfo
                 dflags
 
-        it "should allow endline escaping" $ \(dflags, cinfo) ->
+        it "should allow endline escaping" $ \dflags ->
             shouldParseTo
                 "#define first line\\\nsecond line\\\nand another one"
                 [TkCpp]
-                cinfo
                 dflags
 
     context "when parsing multi-line comments" $ do
 
-        it "should support nested comments" $ \(dflags, cinfo) ->
+        it "should support nested comments" $ \dflags ->
             shouldParseTo
                 "{- comment {- nested -} still comment -} {- next comment -}"
                 [TkComment, TkSpace, TkComment]
-                cinfo
                 dflags
 
-        it "should distinguish compiler pragma" $ \(dflags, cinfo) ->
+        it "should distinguish compiler pragma" $ \dflags ->
             shouldParseTo
                 "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
                 [TkComment, TkPragma, TkComment]
-                cinfo
                 dflags
 
-    it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do
+    it "should recognize preprocessor directives" $ \dflags -> do
             shouldParseTo
                 "\n#define foo bar"
                 [TkCpp]
-                cinfo
                 dflags
             shouldParseTo
                 "x # y"
                 [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
-                cinfo
                 dflags
 
-    it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do
+    it "should distinguish basic language constructs" $ \dflags -> do
         
         shouldParseTo
             "(* 2) <$> (\"abc\", foo)"
@@ -121,7 +113,6 @@ parseSpec = around withDynFlags $ do
             , TkSpace, TkOperator, TkSpace
             , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
             ]
-            cinfo
             dflags
             
         shouldParseTo
@@ -131,7 +122,6 @@ parseSpec = around withDynFlags $ do
             , TkIdentifier, TkSpace, TkKeyword, TkSpace
             , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
             ]
-            cinfo
             dflags
         
         shouldParseTo
@@ -142,10 +132,9 @@ parseSpec = around withDynFlags $ do
             , TkSpace, TkKeyword, TkSpace
             , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
             ]
-            cinfo
             dflags
 
-    it "should parse do-notation syntax" $ \(dflags, cinfo) -> do
+    it "should parse do-notation syntax" $ \dflags -> do
         shouldParseTo
             "do { foo <- getLine; putStrLn foo }"
             [ TkKeyword, TkSpace, TkSpecial, TkSpace
@@ -153,7 +142,6 @@ parseSpec = around withDynFlags $ do
             , TkIdentifier, TkSpecial, TkSpace
             , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
             ]
-            cinfo
             dflags
 
         shouldParseTo
@@ -166,10 +154,9 @@ parseSpec = around withDynFlags $ do
             , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace
             , TkIdentifier, TkSpace, TkIdentifier, TkSpace
             ]
-            cinfo
             dflags
   where
-    shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation
-    shouldParseTo str tokens cinfo dflags = [ tkType tok
-                                            | tok <- parse cinfo dflags "" str
-                                            , not (BS.null (tkValue tok)) ] `shouldBe` tokens
+    shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation
+    shouldParseTo str tokens dflags = [ tkType tok
+                                      | tok <- parse dflags "" str
+                                      , not (BS.null (tkValue tok)) ] `shouldBe` tokens
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 1963753d..f7614927 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -20,18 +20,11 @@ checkConfig = CheckConfig
     , ccfgEqual = (==) `on` dumpXml
     }
   where
-    -- The whole point of the ClangCppBug is to demonstrate a situation where
-    -- line numbers may vary (and test that links still work). Consequently, we
-    -- strip out line numbers for this test case.
-    strip f | takeBaseName f == "ClangCppBug"
-            = stripAnchors' . stripLinks' . stripIds' . stripIds'' . stripFooter
-            | otherwise
-            = stripAnchors' . stripLinks' . stripIds' . stripFooter
+    strip _ = stripAnchors' . stripLinks' . stripIds' . stripFooter
     
     stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href
     stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name
     stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name
-    stripIds'' = stripIdsWhen $ \name -> "line-" `isPrefixOf` name
 
 
 dirConfig :: DirConfig
diff --git a/hypsrc-test/ref/src/ClangCppBug.html b/hypsrc-test/ref/src/ClangCppBug.html
deleted file mode 100644
index b76b53a7..00000000
--- a/hypsrc-test/ref/src/ClangCppBug.html
+++ /dev/null
@@ -1,306 +0,0 @@
-<html xmlns="http://www.w3.org/1999/xhtml"
-><head
-  ><link rel="stylesheet" type="text/css" href="style.css"
-     /><script type="text/javascript" src="highlight.js"
-    ></script
-    ></head
-  ><body
-  ><pre
-    ><span class="hs-pragma"
-      >{-# LANGUAGE CPP #-}</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="hs-keyword"
-      >module</span
-      ><span
-      > </span
-      ><span class="hs-identifier"
-      >ClangCppBug</span
-      ><span
-      > </span
-      ><span class="hs-keyword"
-      >where</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#foo"
-	><span class="hs-identifier hs-type"
-	  >foo</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >::</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-identifier hs-type"
-	>Int</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span id="foo"
-      ><span class="annot"
-	><span class="annottext"
-	  >foo :: Int
-</span
-	  ><a href="ClangCppBug.html#foo"
-	  ><span class="hs-identifier hs-var hs-var"
-	    >foo</span
-	    ></a
-	  ></span
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >=</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-number"
-	>1</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="hs-comment"
-      >-- Clang doesn't mind these:</span
-      ><span class="hs-cpp"
-      >
-#define BAX 2
-</span
-      ><span class="hs-pragma"
-      >{-# INLINE</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#bar"
-	><span class="hs-pragma hs-type"
-	  >bar</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-pragma"
-      >#-}</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#bar"
-	><span class="hs-identifier hs-type"
-	  >bar</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >::</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-identifier hs-type"
-	>Int</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span id="bar"
-      ><span class="annot"
-	><span class="annottext"
-	  >bar :: Int
-</span
-	  ><a href="ClangCppBug.html#bar"
-	  ><span class="hs-identifier hs-var hs-var"
-	    >bar</span
-	    ></a
-	  ></span
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >=</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-number"
-	>3</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="hs-comment"
-      >-- But it doesn't like this:</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="hs-pragma"
-      >{-# RULES</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="annot"
-      ><span class="hs-pragma"
-	>&quot;bar/qux&quot;</span
-	></span
-      ><span
-      > </span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#bar"
-	><span class="hs-pragma hs-type"
-	  >bar</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-pragma"
-      >=</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#qux"
-	><span class="hs-pragma hs-type"
-	  >qux</span
-	  ></a
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="annot"
-      ><span class="hs-pragma"
-	>&quot;qux/foo&quot;</span
-	></span
-      ><span
-      > </span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#qux"
-	><span class="hs-pragma hs-type"
-	  >qux</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-pragma"
-      >=</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#foo"
-	><span class="hs-pragma hs-type"
-	  >foo</span
-	  ></a
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >  </span
-      ><span class="hs-pragma"
-      >#-}</span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span class="annot"
-      ><a href="ClangCppBug.html#qux"
-	><span class="hs-identifier hs-type"
-	  >qux</span
-	  ></a
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >::</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-identifier hs-type"
-	>Int</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ><span id="qux"
-      ><span class="annot"
-	><span class="annottext"
-	  >qux :: Int
-</span
-	  ><a href="ClangCppBug.html#qux"
-	  ><span class="hs-identifier hs-var hs-var"
-	    >qux</span
-	    ></a
-	  ></span
-	></span
-      ><span
-      > </span
-      ><span class="hs-glyph"
-      >=</span
-      ><span
-      > </span
-      ><span class="annot"
-      ><span class="hs-number"
-	>88</span
-	></span
-      ><span
-      >
-</span
-      ><span id=""
-      ></span
-      ></pre
-    ></body
-  ></html
->
diff --git a/hypsrc-test/src/ClangCppBug.hs b/hypsrc-test/src/ClangCppBug.hs
deleted file mode 100644
index 4b0bc35f..00000000
--- a/hypsrc-test/src/ClangCppBug.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE CPP #-}
-module ClangCppBug where
-
-foo :: Int
-foo = 1
-
--- Clang doesn't mind these:
-#define BAX 2
-{-# INLINE bar #-}
-
-bar :: Int
-bar = 3
-
--- But it doesn't like this:
-{-# RULES
-"bar/qux" bar = qux
-"qux/foo" qux = foo
-  #-}
-
-qux :: Int
-qux = 88