aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs')
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs146
1 files changed, 100 insertions, 46 deletions
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index 8cd2690e..4639253c 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -4,95 +4,149 @@ module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where
import Test.Hspec
import Test.QuickCheck
+import qualified GHC
+import Control.Monad.IO.Class
+
+import Haddock (getGhcDirs)
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types
+withDynFlags :: (GHC.DynFlags -> IO ()) -> IO ()
+withDynFlags cont = do
+ libDir <- fmap snd (getGhcDirs [])
+ GHC.runGhc (Just libDir) $ do
+ dflags <- GHC.getSessionDynFlags
+ liftIO $ cont dflags
+
main :: IO ()
main = hspec spec
spec :: Spec
-spec = do
- describe "parse" parseSpec
+spec = describe "parse" parseSpec
-parseSpec :: Spec
-parseSpec = do
+-- | Defined for its instance of 'Arbitrary'. Represents strings that, when
+-- considered as GHC source, won't be rewritten.
+newtype NoGhcRewrite = NoGhcRewrite String deriving (Show, Eq)
- it "is total" $
- property $ \src -> length (parse src) `shouldSatisfy` (>= 0)
+-- | Filter out strings where GHC would replace/remove some characters during
+-- lexing.
+noGhcRewrite :: String -> Bool
+noGhcRewrite ('\t':_) = False -- GHC replaces tabs with 8 spaces
+noGhcRewrite ('\r':_) = False
+noGhcRewrite ('\f':_) = False
+noGhcRewrite ('\v':_) = False
+noGhcRewrite (' ':'\n':_) = False -- GHC strips whitespace on empty lines
+noGhcRewrite (_:s) = noGhcRewrite s
+noGhcRewrite "" = True
- it "retains file layout" $
- property $ \src -> concatMap tkValue (parse src) == src
+instance Arbitrary NoGhcRewrite where
+ arbitrary = fmap NoGhcRewrite (arbitrary `suchThat` noGhcRewrite)
+ shrink (NoGhcRewrite src) = [ NoGhcRewrite shrunk
+ | shrunk <- shrink src
+ , noGhcRewrite shrunk
+ ]
- context "when parsing single-line comments" $ do
- it "should ignore content until the end of line" $
- "-- some very simple comment\nidentifier"
- `shouldParseTo`
- [TkComment, TkSpace, TkIdentifier]
+parseSpec :: Spec
+parseSpec = around withDynFlags $ do
- it "should allow endline escaping" $
- "-- first line\\\nsecond line\\\nand another one"
- `shouldParseTo`
- [TkComment]
+ it "is total" $ \dflags ->
+ property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0)
- context "when parsing multi-line comments" $ do
+ it "retains file layout" $ \dflags ->
+ property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src
- it "should support nested comments" $
- "{- comment {- nested -} still comment -} {- next comment -}"
- `shouldParseTo`
- [TkComment, TkSpace, TkComment]
+ context "when parsing single-line comments" $ do
+
+ it "should ignore content until the end of line" $ \dflags ->
+ shouldParseTo
+ "-- some very simple comment\nidentifier"
+ [TkComment, TkSpace, TkIdentifier]
+ dflags
- it "should distinguish compiler pragma" $
- "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
- `shouldParseTo`
- [TkComment, TkPragma, TkComment]
+ it "should allow endline escaping" $ \dflags ->
+ shouldParseTo
+ "#define first line\\\nsecond line\\\nand another one"
+ [TkCpp]
+ dflags
- it "should recognize preprocessor directives" $ do
- "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]
- "x # y" `shouldParseTo`
- [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
+ context "when parsing multi-line comments" $ do
- it "should distinguish basic language constructs" $ do
- "(* 2) <$> (\"abc\", foo)" `shouldParseTo`
+ it "should support nested comments" $ \dflags ->
+ shouldParseTo
+ "{- comment {- nested -} still comment -} {- next comment -}"
+ [TkComment, TkSpace, TkComment]
+ dflags
+
+ it "should distinguish compiler pragma" $ \dflags ->
+ shouldParseTo
+ "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
+ [TkComment, TkPragma, TkComment]
+ dflags
+
+ it "should recognize preprocessor directives" $ \dflags -> do
+ shouldParseTo
+ "\n#define foo bar"
+ [TkSpace, TkCpp]
+ dflags
+ shouldParseTo
+ "x # y"
+ [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
+ dflags
+
+ it "should distinguish basic language constructs" $ \dflags -> do
+
+ shouldParseTo
+ "(* 2) <$> (\"abc\", foo)"
[ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial
, TkSpace, TkOperator, TkSpace
, TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
]
- "let foo' = foo in foo' + foo'" `shouldParseTo`
+ dflags
+
+ shouldParseTo
+ "let foo' = foo in foo' + foo'"
[ TkKeyword, TkSpace, TkIdentifier
, TkSpace, TkGlyph, TkSpace
, TkIdentifier, TkSpace, TkKeyword, TkSpace
, TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
]
- "square x = y^2 where y = x" `shouldParseTo`
+ dflags
+
+ shouldParseTo
+ "square x = y^2 where y = x"
[ TkIdentifier, TkSpace, TkIdentifier
, TkSpace, TkGlyph, TkSpace
, TkIdentifier, TkOperator, TkNumber
, TkSpace, TkKeyword, TkSpace
, TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
]
+ dflags
- it "should parse do-notation syntax" $ do
- "do { foo <- getLine; putStrLn foo }" `shouldParseTo`
+ it "should parse do-notation syntax" $ \dflags -> do
+ shouldParseTo
+ "do { foo <- getLine; putStrLn foo }"
[ TkKeyword, TkSpace, TkSpecial, TkSpace
, TkIdentifier, TkSpace, TkGlyph, TkSpace
, TkIdentifier, TkSpecial, TkSpace
, TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
]
-
- unlines
- [ "do"
- , " foo <- getLine"
- , " putStrLn foo"
- ] `shouldParseTo`
+ dflags
+
+ shouldParseTo
+ (unlines
+ [ "do"
+ , " foo <- getLine"
+ , " putStrLn foo"
+ ])
[ TkKeyword, TkSpace, TkIdentifier
, TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace
, TkIdentifier, TkSpace, TkIdentifier, TkSpace
]
-
-
-shouldParseTo :: String -> [TokenType] -> Expectation
-str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens
+ dflags
+ where
+ shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation
+ shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens