From bf07847e45356024e10d1a325f015ac53544ea85 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 31 Jan 2019 12:43:39 -0800 Subject: Fix some Hyperlinker test suite fallout * Amend `ParserSpec` to match new Hyperlinker API - pass in compiler info - strip out null tokens * Make `hypsrc-test` pass reliably - strip out `local-*` ids - strip out `line-*` ids from the `ClangCppBug` test - re-accept output --- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 65 ++++++++++------ haddock-test/src/Test/Haddock/Xhtml.hs | 10 ++- hypsrc-test/Main.hs | 13 +++- hypsrc-test/ref/src/ClangCppBug.html | 38 +++++----- hypsrc-test/ref/src/Classes.html | 50 ++++++------- hypsrc-test/ref/src/Constructors.html | 24 +++--- hypsrc-test/ref/src/Identifiers.html | 26 +++---- hypsrc-test/ref/src/LinkingIdentifiers.html | 8 +- hypsrc-test/ref/src/Literals.html | 6 +- hypsrc-test/ref/src/Operators.html | 42 +++++------ hypsrc-test/ref/src/Polymorphism.html | 86 +++++++++++----------- hypsrc-test/ref/src/Records.html | 36 ++++----- hypsrc-test/ref/src/Types.html | 8 +- 13 files changed, 226 insertions(+), 186 deletions(-) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 4639253c..ff18cb40 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck -import qualified GHC +import GHC ( runGhc, getSessionDynFlags ) +import DynFlags ( CompilerInfo, DynFlags ) +import SysTools.Info ( getCompilerInfo' ) import Control.Monad.IO.Class +import Data.String ( fromString ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types -withDynFlags :: (GHC.DynFlags -> IO ()) -> IO () +withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) - GHC.runGhc (Just libDir) $ do - dflags <- GHC.getSessionDynFlags - liftIO $ cont dflags + runGhc (Just libDir) $ do + dflags <- getSessionDynFlags + cinfo <- liftIO $ getCompilerInfo' dflags + liftIO $ cont (dflags, cinfo) main :: IO () @@ -53,51 +60,60 @@ instance Arbitrary NoGhcRewrite where parseSpec :: Spec parseSpec = around withDynFlags $ do - it "is total" $ \dflags -> - property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0) + it "is total" $ \(dflags, cinfo) -> + property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ \dflags -> - property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src + it "retains file layout" $ \(dflags, cinfo) -> + property $ \(NoGhcRewrite src) -> + let orig = fromString src + lexed = BS.concat (map tkValue (parse cinfo dflags "" orig)) + in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ \dflags -> + it "should ignore content until the end of line" $ \(dflags, cinfo) -> shouldParseTo "-- some very simple comment\nidentifier" [TkComment, TkSpace, TkIdentifier] + cinfo dflags - it "should allow endline escaping" $ \dflags -> + it "should allow endline escaping" $ \(dflags, cinfo) -> 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 -> + it "should support nested comments" $ \(dflags, cinfo) -> shouldParseTo "{- comment {- nested -} still comment -} {- next comment -}" [TkComment, TkSpace, TkComment] + cinfo dflags - it "should distinguish compiler pragma" $ \dflags -> + it "should distinguish compiler pragma" $ \(dflags, cinfo) -> shouldParseTo "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" [TkComment, TkPragma, TkComment] + cinfo dflags - it "should recognize preprocessor directives" $ \dflags -> do + it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do shouldParseTo "\n#define foo bar" - [TkSpace, TkCpp] + [TkCpp] + cinfo dflags shouldParseTo "x # y" [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + cinfo dflags - it "should distinguish basic language constructs" $ \dflags -> do + it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do shouldParseTo "(* 2) <$> (\"abc\", foo)" @@ -105,6 +121,7 @@ parseSpec = around withDynFlags $ do , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] + cinfo dflags shouldParseTo @@ -114,6 +131,7 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] + cinfo dflags shouldParseTo @@ -124,9 +142,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + cinfo dflags - it "should parse do-notation syntax" $ \dflags -> do + it "should parse do-notation syntax" $ \(dflags, cinfo) -> do shouldParseTo "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace @@ -134,10 +153,11 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] + cinfo dflags shouldParseTo - (unlines + (fromString $ unlines [ "do" , " foo <- getLine" , " putStrLn foo" @@ -146,7 +166,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] + cinfo dflags where - shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation - shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens + 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 diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index d4520100..6c19dbca 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -8,7 +8,7 @@ module Test.Haddock.Xhtml ( Xml(..) , parseXml, dumpXml - , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripIdsWhen, stripFooter ) where import Data.Data ( Data(..), Typeable, eqT, (:~:)(..) ) @@ -62,6 +62,14 @@ stripAnchorsWhen p = | qName key == "name" && p val = attr { attrVal = "" } | otherwise = attr +stripIdsWhen :: (String -> Bool) -> Xml -> Xml +stripIdsWhen p = + processAnchors unname + where + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "id" && p val = attr { attrVal = "" } + | otherwise = attr + processAnchors :: (Attr -> Attr) -> Xml -> Xml processAnchors f = Xml . gmapEverywhere f . xmlElement diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index d3ab79a8..1963753d 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -15,14 +15,23 @@ import Test.Haddock.Xhtml checkConfig :: CheckConfig Xml checkConfig = CheckConfig { ccfgRead = parseXml - , ccfgClean = \_ -> strip + , ccfgClean = strip , ccfgDump = dumpXml , ccfgEqual = (==) `on` dumpXml } where - strip = stripAnchors' . stripLinks' . stripFooter + -- 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 + 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 index 42d0cfc0..d03c92e1 100644 --- a/hypsrc-test/ref/src/ClangCppBug.html +++ b/hypsrc-test/ref/src/ClangCppBug.html @@ -11,7 +11,7 @@ > module -- Clang doesn't mind these: -- But it doesn't like this: {-# RULES bar :: Int -> Int @@ -214,7 +214,7 @@ forall a. a -> a > baz :: Int -> (Int, Int) @@ -227,7 +227,7 @@ forall a. a -> a > x :: Int @@ -280,7 +280,7 @@ forall a. a -> a instance bar :: [a] -> Int @@ -346,7 +346,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int > baz :: Int -> ([a], [a]) @@ -433,7 +433,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int > (x :: a @@ -531,7 +531,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int >, y :: a @@ -644,7 +644,7 @@ forall a. Foo' a => [a] -> a > instance norf :: [Int] -> Int @@ -816,12 +816,12 @@ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a instance quux :: ([a], [a]) -> [a] @@ -917,7 +917,7 @@ forall a. [a] -> [a] -> [a] > plugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) @@ -1122,7 +1122,7 @@ forall a. [a] -> [a] -> [a] > a :: a @@ -1208,7 +1208,7 @@ forall a b. a -> b -> a > a :: a @@ -1298,7 +1298,7 @@ forall a b. a -> b -> a > b :: b @@ -1384,7 +1384,7 @@ forall a b. a -> b -> a > b :: b diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 6cdf07db..970ec741 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -478,7 +478,7 @@ > foo :: Foo @@ -491,7 +491,7 @@ > n :: Int @@ -656,7 +656,7 @@ forall a. Num a => a -> a -> a >, xs :: [Foo] @@ -731,7 +731,7 @@ forall a. Num a => a -> a -> a >, xs :: [Foo] @@ -871,7 +871,7 @@ forall a. HasCallStack => a > x :: Norf @@ -896,7 +896,7 @@ forall a. HasCallStack => a > (f1 :: Foo @@ -923,7 +923,7 @@ forall a. HasCallStack => a >_ n :: Int @@ -946,7 +946,7 @@ forall a. HasCallStack => a >, f2 :: Foo @@ -969,7 +969,7 @@ forall a. HasCallStack => a > f3 :: Foo @@ -1111,7 +1111,7 @@ forall a. Num a => a -> a -> a > aux :: Foo -> Int @@ -1124,7 +1124,7 @@ forall a. Num a => a -> a -> a > fx :: Foo @@ -1232,7 +1232,7 @@ forall a. Num a => a -> a -> a > x' :: Int diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html index 301761c1..5268031d 100644 --- a/hypsrc-test/ref/src/Identifiers.html +++ b/hypsrc-test/ref/src/Identifiers.html @@ -105,7 +105,7 @@ > x :: Int @@ -118,7 +118,7 @@ > y :: Int @@ -268,7 +268,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -281,7 +281,7 @@ forall a. Num a => a -> a -> a > y :: Int @@ -431,7 +431,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -444,7 +444,7 @@ forall a. Num a => a -> a -> a > y :: Int @@ -608,7 +608,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -782,7 +782,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -795,7 +795,7 @@ forall a. Num a => a -> a -> a > y :: Int @@ -808,7 +808,7 @@ forall a. Num a => a -> a -> a > z :: Int @@ -1397,7 +1397,7 @@ forall a b. (a -> b) -> a -> b > x :: Int @@ -1425,7 +1425,7 @@ forall a b. (a -> b) -> a -> b > y :: Int @@ -1453,7 +1453,7 @@ forall a b. (a -> b) -> a -> b > z :: Int diff --git a/hypsrc-test/ref/src/LinkingIdentifiers.html b/hypsrc-test/ref/src/LinkingIdentifiers.html index 2ef590bd..52b20200 100644 --- a/hypsrc-test/ref/src/LinkingIdentifiers.html +++ b/hypsrc-test/ref/src/LinkingIdentifiers.html @@ -102,7 +102,7 @@ x :: Int @@ -221,7 +221,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -357,7 +357,7 @@ forall a. Num a => a -> a -> a x :: Int @@ -476,7 +476,7 @@ forall a. Num a => a -> a -> a > x :: Int diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html index 62ea32dd..f0d05fbc 100644 --- a/hypsrc-test/ref/src/Literals.html +++ b/hypsrc-test/ref/src/Literals.html @@ -83,7 +83,7 @@ a :: [a] @@ -118,7 +118,7 @@ > b :: [a] @@ -196,7 +196,7 @@ forall a. [a] -> [a] -> [a] a :: [a] @@ -283,7 +283,7 @@ forall a. [a] -> [a] -> [a] > b :: [a] @@ -342,7 +342,7 @@ forall a. [a] -> [a] -> [a] a :: [a] @@ -461,7 +461,7 @@ forall a. [a] -> [a] -> [a] > a :: [a] @@ -482,7 +482,7 @@ forall a. [a] -> [a] -> [a] >:b :: [a] @@ -570,7 +570,7 @@ forall a. [a] -> [a] -> [a] a :: [[a]] @@ -661,7 +661,7 @@ forall a. [a] -> [a] -> [a] > b :: [a] @@ -734,7 +734,7 @@ forall a. [a] -> [a] -> [a] a :: [[a]] @@ -833,7 +833,7 @@ forall a. [a] -> [a] -> [a] > b :: [[a]] @@ -961,9 +961,9 @@ forall a. [a] -> [a] -> [a] a :: a @@ -1070,7 +1070,7 @@ forall a. [a] -> [a] -> [a] > b :: b diff --git a/hypsrc-test/ref/src/Polymorphism.html b/hypsrc-test/ref/src/Polymorphism.html index 91f8bd33..ec9c49e8 100644 --- a/hypsrc-test/ref/src/Polymorphism.html +++ b/hypsrc-test/ref/src/Polymorphism.html @@ -55,7 +55,7 @@ forall forall forall forall x :: a @@ -848,7 +848,7 @@ forall a. HasCallStack => a > f :: forall a. a -> a @@ -912,7 +912,7 @@ forall a. a -> a >forall forall x :: a @@ -1017,7 +1017,7 @@ forall a. a -> a > f :: forall a. a -> a @@ -1070,7 +1070,7 @@ forall a. a -> a forall forall forall forall x :: a @@ -2002,7 +2002,7 @@ forall a. HasCallStack => a > f :: forall a. Ord a => a -> a @@ -2054,7 +2054,7 @@ forall a. HasCallStack => a >forall forall x :: a @@ -2177,7 +2177,7 @@ forall a. HasCallStack => a > f :: forall a. Ord a => a -> a @@ -2234,7 +2234,7 @@ forall a. HasCallStack => a >forall x :: a @@ -2346,7 +2346,7 @@ forall a. HasCallStack => a >forall f :: a -> b @@ -2459,7 +2459,7 @@ forall a. HasCallStack => a > x :: a @@ -2561,7 +2561,7 @@ forall a. HasCallStack => a > y :: b diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index bc99cc56..5057b8a4 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -229,7 +229,7 @@ > x :: Int @@ -242,7 +242,7 @@ > y :: Int @@ -420,7 +420,7 @@ >= Int @@ -450,7 +450,7 @@ >= Int @@ -615,7 +615,7 @@ forall a. Num a => a -> a -> a >{ Int @@ -632,7 +632,7 @@ x :: Point -> Int >, Int @@ -812,7 +812,7 @@ forall a. Num a => a -> a -> a > p :: Point @@ -825,7 +825,7 @@ forall a. Num a => a -> a -> a > d :: Int @@ -935,7 +935,7 @@ forall a. Num a => a -> a -> a > p :: Point @@ -948,7 +948,7 @@ forall a. Num a => a -> a -> a > d :: Int @@ -1118,7 +1118,7 @@ forall a. Num a => a -> a -> a > x :: Int @@ -1131,7 +1131,7 @@ forall a. Num a => a -> a -> a > y :: Int @@ -1144,7 +1144,7 @@ forall a. Num a => a -> a -> a > p :: Point @@ -1204,7 +1204,7 @@ forall a. Num a => a -> a -> a > (dx :: Int @@ -1219,7 +1219,7 @@ forall a. Num a => a -> a -> a >, dy :: Int @@ -1271,7 +1271,7 @@ forall a. Num a => a -> a -> a > aux :: Point -> Point @@ -1284,8 +1284,8 @@ forall a. Num a => a -> a -> a >