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.hs49
1 files changed, 18 insertions, 31 deletions
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