diff options
| -rw-r--r-- | haddock-api/haddock-api.cabal | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 47 | ||||
| -rw-r--r-- | haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 49 | ||||
| -rw-r--r-- | hypsrc-test/Main.hs | 9 | ||||
| -rw-r--r-- | hypsrc-test/ref/src/ClangCppBug.html | 306 | ||||
| -rw-r--r-- | hypsrc-test/src/ClangCppBug.hs | 21 |
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" - >"bar/qux"</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" - >"qux/foo"</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 |