aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/haddock-api.cabal2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs47
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs49
-rw-r--r--hypsrc-test/Main.hs9
-rw-r--r--hypsrc-test/src/ClangCppBug.hs21
6 files changed, 22 insertions, 110 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index a58b092a..5e8b37d8 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/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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 09:43:05 +0000