diff options
Diffstat (limited to 'haddock-api/test/Haddock/Backends/Hyperlinker')
| -rw-r--r-- | haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 135 |
1 files changed, 89 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..dcb30e41 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -4,95 +4,138 @@ 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' +newtype NoTabs = NoTabs String deriving (Show, Eq) - it "is total" $ - property $ \src -> length (parse src) `shouldSatisfy` (>= 0) +noTabs :: String -> Bool +noTabs = all (\c -> c `notElem` "\r\t\f\v") - it "retains file layout" $ - property $ \src -> concatMap tkValue (parse src) == src +-- | Does not generate content with space characters other than ' ' and '\n' +instance Arbitrary NoTabs where + arbitrary = fmap NoTabs (arbitrary `suchThat` noTabs) + shrink (NoTabs src) = [ NoTabs shrunk | shrunk <- shrink src, noTabs 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 $ \(NoTabs 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 |