scmdoc

  1{-# LANGUAGE OverloadedStrings #-}
  2
  3module Parser where
  4
  5import Test.Tasty
  6import Test.Tasty.HUnit
  7
  8import Data.Text ()
  9import SchemeDoc.Parser.R7RS
 10import SchemeDoc.Types
 11import Util
 12
 13schemeParser :: TestTree
 14schemeParser =
 15    testGroup
 16        "Tests for the Scheme parser"
 17        [idParser, strParser, chrParser, boolParser, exprParser, vectorParser]
 18
 19idParser :: TestTree
 20idParser =
 21    testGroup
 22        "Identifier parser"
 23        [ testCase "Simple identifier" $ do
 24            assertEqual "" (Right $ [Id "foo"]) $ parse "foo"
 25        , testCase "Identifier with extented identifier character" $ do
 26            assertEqual "" (Right $ [Id "f%o!!"]) $ parse "f%o!!"
 27        , testCase "Identifier enclosed by vertical lines" $ do
 28            assertEqual "" (Right $ [Id "Hello"]) $ parse "|Hello|"
 29        , testCase "Parse the empty identifier" $ do
 30            assertEqual "" (Right $ [Id ""]) $ parse "||"
 31        , testCase "Identifier with inline hex escape" $ do
 32            assertEqual "" (Right $ [Id "Hello"]) $ parse "|H\\x65;llo|"
 33        , testCase "Identifier with invalid initial" $ do
 34            assertEqual "" "expecting digit, delimiter or end of input" (parseErrors scheme "(define 23foo x)")
 35        , testCase "Identifier with mnemonic escape" $ do
 36            assertEqual "" (Right $ [Id "b\ar"]) $ parse "|b\\ar|"
 37        , testCase "Peculiar Identifiers" $ do
 38            assertEqual "" (Right $ [Id "+"]) $ parse "+"
 39            assertEqual "" (Right $ [Id "-"]) $ parse "-"
 40            assertEqual "" (Right $ [Id "+@2"]) $ parse "+@2"
 41            assertEqual "" (Right $ [Id "+..22342"]) $ parse "+..22342"
 42            assertEqual "" (Right $ [Id "..."]) $ parse "..."
 43        ]
 44
 45strParser :: TestTree
 46strParser =
 47    testGroup
 48        "String parser"
 49        [ testCase "Simple string" $ do
 50            assertEqual "" (Right $ [Str "foobar"]) $ parse "\"foobar\""
 51        , testCase "Escaped quote" $ do
 52            assertEqual "" (Right $ [Str "foo\"bar"]) $ parse "\"foo\\\"bar\""
 53        , testCase "Escaped newline" $ do
 54            assertEqual "" (Right $ [Str "foobar"]) $ parse "\"foo\\    \n   bar\""
 55        , testCase "String with inline hex escape" $ do
 56            assertEqual "" (Right $ [Str "Hello"]) $ parse "\"H\\x65;llo\""
 57        , testCase "String with mnemonic escape" $ do
 58            assertEqual "" (Right $ [Str "\n"]) $ parse "\"\\n\""
 59        ]
 60
 61chrParser :: TestTree
 62chrParser =
 63    testGroup
 64        "Character parser"
 65        [ testCase "Simple character" $ do
 66            assertEqual "" (Right $ [Char 'f']) $ parse "#\\f"
 67        , testCase "Character with character name" $ do
 68            assertEqual "" (Right $ [Char '\DEL']) $ parse "#\\delete"
 69        , testCase "Character with hex escape" $ do
 70            assertEqual "" (Right $ [Char 'a']) $ parse "#\\x61"
 71        ]
 72
 73boolParser :: TestTree
 74boolParser =
 75    testGroup
 76        "Boolean parser"
 77        [ testCase "True" $ do
 78            assertEqual "Long form" (Right $ [Boolean True]) $ parse "#true"
 79            assertEqual "Short form" (Right $ [Boolean True]) $ parse "#t"
 80        , testCase "False" $ do
 81            assertEqual "Long form" (Right $ [Boolean False]) $ parse "#false"
 82            assertEqual "Short form" (Right $ [Boolean False]) $ parse "#f"
 83        ]
 84
 85vectorParser :: TestTree
 86vectorParser =
 87    testGroup
 88        "Vector and bytevector parser"
 89        [ testCase "Vector" $ do
 90            assertEqual "" (Right $ [List [Id "vector", Number 1, Number 2]]) $ parse "#(1 2)"
 91            assertEqual "" (Right $ [List [Id "vector", Number 1, Number 2]]) $ parse "#(   1     2  )"
 92            assertEqual "" (Right $ [List [Id "vector", Number 1, Number 2]]) $ parse "(vector 1 2)"
 93        , testCase "Bytevector" $ do
 94            assertEqual "" (Right $ [List [Id "bytevector", Number 1, Number 2]]) $ parse "#u8(1 2)"
 95            assertEqual "" (Right $ [List [Id "bytevector", Number 1, Number 2]]) $ parse "#u8(   1    2  ) "
 96            assertEqual "" (Right $ [List [Id "bytevector", Number 1, Number 2]]) $ parse "(bytevector 1 2)"
 97        ]
 98
 99------------------------------------------------------------------------
100
101exprParser :: TestTree
102exprParser =
103    testGroup
104        "Expression parser"
105        [ testCase "Delimited expressions" $ do
106            assertEqual
107                "With whitespaces"
108                ( Right $
109                    [ List [Id "define", Id "x", Number 1]
110                    , List [Id "define", Id "y", Number 2]
111                    ]
112                )
113                $ parse "(define x 1) (define y 2)"
114
115            assertEqual
116                "With comment"
117                ( Right $
118                    [ List [Id "define", Id "x", Number 1]
119                    , List [Id "define", Id "y", Number 2]
120                    ]
121                )
122                $ parse "(define x 1)#|foo|#(define y 2)"
123        , testCase "Quotations" $ do
124            assertEqual
125                "Quote identifier"
126                (Right $ [List [Id "quote", Id "foobar"]])
127                $ parse "'foobar"
128
129            assertEqual
130                "Quote empty list"
131                (Right $ [List [Id "quote", List []]])
132                $ parse "'()"
133
134            assertEqual
135                "Quote empty list with whitespaces"
136                (Right $ [List [Id "quote", List []]])
137                $ parse "'  ()"
138
139            assertEqual
140                "Quasiquotation"
141                (Right $ [List [Id "quasiquote", List [Id "foo"]]])
142                $ parse "`   (foo)"
143
144            assertEqual
145                "Unquote"
146                (Right $ [List [Id "unquote", List [Id "foo"]]])
147                $ parse ", (foo)"
148
149            assertEqual
150                "Unquote splicing"
151                (Right $ [List [Id "unquote-splicing", List [Id "foo"]]])
152                $ parse ",@  (foo)"
153
154            assertEqual
155                "Quote within list"
156                (Right $ [List [Id "foo", List [Id "quote", Number 5], Number 2]])
157                $ parse "(foo '5 2)"
158        , testCase "Miscellaneous" $ do
159            assertEqual
160                "Comment with leading spaces"
161                (Right $ [])
162                $ parse "  ;; foo\n"
163
164            assertEqual
165                "Multiple comments with leading spaces"
166                ( Right $
167                    [ List [Id "define", Id "x", Number 42]
168                    , List [Id "define", Id "y", Number 23]
169                    ]
170                )
171                $ parse "  ;; x definition\n  ;; bla bla\n(define x 42)\n\n\t;; y definition\n\n\t;; blaa\n(define y 23)"
172
173            assertEqual
174                "Commant with trailing spaces"
175                (Right $ [List [Id "define", Id "x", Number 42]])
176                $ parse "(define x\n\t;; foo\n\t42)"
177
178            assertEqual
179                "Documentation comment"
180                (Right $ [DocComment " my comment\n", List [Id "define", Id "x", Number 2]])
181                $ parse ";;> my comment\n(define x 2)"
182
183            assertEqual
184                "Documentation comment with intra-spaces"
185                (Right $ [DocComment " my\n doc\n comment\n"])
186                $ parse "\t;;> my\n\t;;> doc\n\t;;> comment\n"
187
188            assertEqual
189                "Multi-line documentation comment"
190                (Right $ [DocComment " foo\n bar\n baz\n", List [Id "define", Id "x", Number 2]])
191                $ parse ";;> foo\n;;> bar\n;;> baz\n(define x 2)"
192
193            assertEqual
194                "Interleaved documentation comment"
195                (Right $ [DocComment " foo\n", DocComment " bar\n"])
196                $ parse ";;> foo\n;;\n;;> bar\n"
197
198            assertEqual
199                "Whitespaces at start"
200                (Right $ [Number 42])
201                $ parse "  42"
202
203            assertEqual
204                "Whitespaces at end"
205                (Right $ [Number 42])
206                $ parse "42 "
207
208            assertEqual
209                "Trailing space in list"
210                (Right $ [List [Id "define", Id "x", Number 0]])
211                $ parse "(define x 0 )"
212        ]