aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
blob: 8cd2690e560f171627536494f6671f0a64261a60 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where


import Test.Hspec
import Test.QuickCheck

import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types


main :: IO ()
main = hspec spec


spec :: Spec
spec = do
    describe "parse" parseSpec


parseSpec :: Spec
parseSpec = do

    it "is total" $
        property $ \src -> length (parse src) `shouldSatisfy` (>= 0)

    it "retains file layout" $
        property $ \src -> concatMap tkValue (parse src) == src

    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]

        it "should allow endline escaping" $
            "-- first line\\\nsecond line\\\nand another one"
            `shouldParseTo`
            [TkComment]

    context "when parsing multi-line comments" $ do

        it "should support nested comments" $
            "{- comment {- nested -} still comment -} {- next comment -}"
            `shouldParseTo`
            [TkComment, TkSpace, TkComment]

        it "should distinguish compiler pragma" $
            "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
            `shouldParseTo`
            [TkComment, TkPragma, TkComment]

    it "should recognize preprocessor directives" $ do
        "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]
        "x # y" `shouldParseTo`
            [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]

    it "should distinguish basic language constructs" $ do
        "(* 2) <$> (\"abc\", foo)" `shouldParseTo`
            [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial
            , TkSpace, TkOperator, TkSpace
            , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
            ]
        "let foo' = foo in foo' + foo'" `shouldParseTo`
            [ TkKeyword, TkSpace, TkIdentifier
            , TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkSpace, TkKeyword, TkSpace
            , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
            ]
        "square x = y^2 where y = x" `shouldParseTo`
            [ TkIdentifier, TkSpace, TkIdentifier
            , TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkOperator, TkNumber
            , TkSpace, TkKeyword, TkSpace
            , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
            ]

    it "should parse do-notation syntax" $ do
        "do { foo <- getLine; putStrLn foo }" `shouldParseTo`
            [ TkKeyword, TkSpace, TkSpecial, TkSpace
            , TkIdentifier, TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkSpecial, TkSpace
            , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
            ]

        unlines
            [ "do"
            , "    foo <- getLine"
            , "    putStrLn foo"
            ] `shouldParseTo`
            [ 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