Parser.curry 6.78 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
2
3
4
5
6
module JSON.Parser (parseJSON) where

import JSON.Data
import Char
import Float
import DetParse
Michael Hanus's avatar
Michael Hanus committed
7
import Test.Prop
Michael Hanus's avatar
Michael Hanus committed
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

--- Parses a JSON string into a JValue. Returns Nothing if the string could not
--- be parsed.
parseJSON :: String -> Maybe JValue
parseJSON = parse pJValue

--- Parser for a JValue
pJValue :: Parser JValue
pJValue =   pTrue
        <|> pFalse
        <|> pNull
        <|> pJString
        <|> pJNumber
        <|> pArray
        <|> pObject

pObject :: Parser JValue
pObject =   JObject <$> (char '{' *> pWhitespace *> pObject' <* pWhitespace <* char '}' <* pWhitespace)
        <|> JObject <$> (char '{' *> pWhitespace *> char '}' *> yield [])

pObject' :: Parser [(String, JValue)]
pObject' = (:) <$> (pWhitespace *> pKeyValuePair) <*> (pWhitespace *> char ',' *> pObject' <|> yield [])

pKeyValuePair :: Parser (String, JValue)
pKeyValuePair = (,) <$> pString <*> (pWhitespace *> char ':' *> pWhitespace *> pJValue)

Michael Hanus's avatar
Michael Hanus committed
34
test_pObject_empty :: Prop
Michael Hanus's avatar
Michael Hanus committed
35
36
test_pObject_empty = parse pObject "{}" -=- Just (JObject [])

Michael Hanus's avatar
Michael Hanus committed
37
test_pObject_onlyStringKeys :: Prop
Michael Hanus's avatar
Michael Hanus committed
38
39
test_pObject_onlyStringKeys = parse pObject "{1: 2}" -=- Nothing

Michael Hanus's avatar
Michael Hanus committed
40
test_pObject_simple :: Prop
Michael Hanus's avatar
Michael Hanus committed
41
42
test_pObject_simple = parse pObject "{\"test\": 1, \"test2\": false}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)])

Michael Hanus's avatar
Michael Hanus committed
43
test_pObject_whitespace :: Prop
Michael Hanus's avatar
Michael Hanus committed
44
45
test_pObject_whitespace = parse pObject "{\n \"test\": 1,\n \"test2\": false\n}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)])

Michael Hanus's avatar
Michael Hanus committed
46
test_pObject_nested :: Prop
Michael Hanus's avatar
Michael Hanus committed
47
48
49
50
51
52
53
54
55
test_pObject_nested = parse pObject "{\"test\": {\"hello\": \"world\"}}" -=- Just (JObject [("test", JObject [("hello", JString "world")])])

pArray :: Parser JValue
pArray =   JArray <$> (char '[' *> pWhitespace *> pArray' <* pWhitespace <* char ']')
       <|> JArray <$> (char '[' *> pWhitespace *> char ']' *> yield [])

pArray' :: Parser [JValue]
pArray' = (:) <$> (pWhitespace *> pJValue) <*> ((pWhitespace *> char ',' *> pArray') <|> yield [])

Michael Hanus's avatar
Michael Hanus committed
56
test_pArray_empty :: Prop
Michael Hanus's avatar
Michael Hanus committed
57
58
test_pArray_empty = parse pArray "[]" -=- Just (JArray [])

Michael Hanus's avatar
Michael Hanus committed
59
test_pArray_single :: Prop
Michael Hanus's avatar
Michael Hanus committed
60
61
test_pArray_single = parse pArray "[1]" -=- Just (JArray [JNumber 1.0])

Michael Hanus's avatar
Michael Hanus committed
62
test_pArray_multi :: Prop
Michael Hanus's avatar
Michael Hanus committed
63
64
test_pArray_multi = parse pArray "[true, false, null]" -=- Just (JArray [JTrue, JFalse, JNull])

Michael Hanus's avatar
Michael Hanus committed
65
test_pArray_nested :: Prop
Michael Hanus's avatar
Michael Hanus committed
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
test_pArray_nested = parse pArray "[true, [false], [[null]]]" -=- Just (JArray [JTrue, JArray [JFalse], JArray [JArray [JNull]]])

pWhitespace :: Parser ()
pWhitespace =   char ' ' *> pWhitespace
            <|> char '\n' *> pWhitespace
            <|> char '\r' *> pWhitespace
            <|> char '\t' *> pWhitespace
            <|> empty

pTrue :: Parser JValue
pTrue = word "true" *> yield JTrue

pFalse :: Parser JValue
pFalse = word "false" *> yield JFalse

pNull :: Parser JValue
pNull = word "null" *> yield JNull

pJString :: Parser JValue
pJString = JString <$> pString

pString :: Parser String
pString = char '"' *> pCharSequence <* char '"'

pCharSequence :: Parser String
pCharSequence =   (++) <$> (char '\\' *> pEscaped) <*> pCharSequence
              <|> (:) <$> check (\c -> c /= '"' && c /= '\\') anyChar <*> pCharSequence
              <|> yield ""

pEscaped :: Parser String
pEscaped =   char '"' *> yield "\""
         <|> char '\\' *> yield "\\"
         <|> char '/' *> yield "/"
         <|> char 'b' *> yield "\b"
         <|> char 'f' *> yield "\f"
         <|> char 'n' *> yield "\n"
         <|> char 'r' *> yield "\r"
         <|> char 't' *> yield "\t"
         <|> ((:[]) . chr) <$> (char 'u' *> pTwoByteHex)

pTwoByteHex :: Parser Int
pTwoByteHex = hexToInt <$> ((:) <$> pHexDigit <*> ((:) <$> pHexDigit <*> ((:) <$> pHexDigit <*> ((:[]) <$> pHexDigit))))
  where pHexDigit = check isHexDigit anyChar

hexToInt :: String -> Int
hexToInt s = foldl1 ((+).(16*)) (map digitToInt s)

Michael Hanus's avatar
Michael Hanus committed
113
test_pCharSequence_simple :: Prop
Michael Hanus's avatar
Michael Hanus committed
114
115
test_pCharSequence_simple = parse pCharSequence "test" -=- Just "test"

Michael Hanus's avatar
Michael Hanus committed
116
test_pCharSequence_noDoubleQuote :: Prop
Michael Hanus's avatar
Michael Hanus committed
117
118
test_pCharSequence_noDoubleQuote = parse pCharSequence "te\"st" -=- Nothing

Michael Hanus's avatar
Michael Hanus committed
119
test_pCharSequence_noStandaloneBackslash :: Prop
Michael Hanus's avatar
Michael Hanus committed
120
121
test_pCharSequence_noStandaloneBackslash = parse pCharSequence "He\\world" -=- Nothing

Michael Hanus's avatar
Michael Hanus committed
122
test_pCharSequence_escapedDoubleQuote :: Prop
Michael Hanus's avatar
Michael Hanus committed
123
124
test_pCharSequence_escapedDoubleQuote = parse pCharSequence "Hello \\\"World\\\"" -=- Just "Hello \"World\""

Michael Hanus's avatar
Michael Hanus committed
125
test_pCharSequence_escapedBackslash :: Prop
Michael Hanus's avatar
Michael Hanus committed
126
127
test_pCharSequence_escapedBackslash = parse pCharSequence "He\\\\world" -=- Just "He\\world"

Michael Hanus's avatar
Michael Hanus committed
128
test_pCharSequence_escapedSlash :: Prop
Michael Hanus's avatar
Michael Hanus committed
129
130
test_pCharSequence_escapedSlash = parse pCharSequence "He\\/world" -=- Just "He/world"

Michael Hanus's avatar
Michael Hanus committed
131
test_pCharSequence_escapedBackspace :: Prop
Michael Hanus's avatar
Michael Hanus committed
132
133
test_pCharSequence_escapedBackspace = parse pCharSequence "He\\bworld" -=- Just "He\bworld"

Michael Hanus's avatar
Michael Hanus committed
134
test_pCharSequence_escapedFormFeed :: Prop
Michael Hanus's avatar
Michael Hanus committed
135
136
test_pCharSequence_escapedFormFeed = parse pCharSequence "He\\fworld" -=- Just "He\fworld"

Michael Hanus's avatar
Michael Hanus committed
137
test_pCharSequence_escapedNewline :: Prop
Michael Hanus's avatar
Michael Hanus committed
138
139
test_pCharSequence_escapedNewline = parse pCharSequence "He\\nworld" -=- Just "He\nworld"

Michael Hanus's avatar
Michael Hanus committed
140
test_pCharSequence_escapedCarriageReturn :: Prop
Michael Hanus's avatar
Michael Hanus committed
141
142
test_pCharSequence_escapedCarriageReturn = parse pCharSequence "He\\rworld" -=- Just "He\rworld"

Michael Hanus's avatar
Michael Hanus committed
143
test_pCharSequence_escapedTab :: Prop
Michael Hanus's avatar
Michael Hanus committed
144
145
test_pCharSequence_escapedTab = parse pCharSequence "He\\tworld" -=- Just "He\tworld"

Michael Hanus's avatar
Michael Hanus committed
146
test_pCharSequence_twoEscapes :: Prop
Michael Hanus's avatar
Michael Hanus committed
147
148
test_pCharSequence_twoEscapes = parse pCharSequence "He\\r\\nWorld" -=- Just "He\r\nWorld"

Michael Hanus's avatar
Michael Hanus committed
149
test_pCharSequence_escapedUnicodeChar :: Prop
Michael Hanus's avatar
Michael Hanus committed
150
151
test_pCharSequence_escapedUnicodeChar = parse pCharSequence "Hello \\u2603 World" -=- Just "Hello ☃ World"

Michael Hanus's avatar
Michael Hanus committed
152
test_pCharSequence_escapedUnicodeRequiresFourDigits :: Prop
Michael Hanus's avatar
Michael Hanus committed
153
154
test_pCharSequence_escapedUnicodeRequiresFourDigits = parse pCharSequence "Hello \\u26 World" -=- Nothing

Michael Hanus's avatar
Michael Hanus committed
155
test_pString_simple :: Prop
Michael Hanus's avatar
Michael Hanus committed
156
157
test_pString_simple = parse pString "\"Hello, World\"" -=- Just "Hello, World"

Michael Hanus's avatar
Michael Hanus committed
158
test_pString_complex :: Prop
Michael Hanus's avatar
Michael Hanus committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
test_pString_complex = parse pString "\"Hello \\r\\n \\u2603 World\"" -=- Just "Hello \r\n ☃ World"

pJNumber :: Parser JValue
pJNumber = JNumber <$> pNumber

pNumber :: Parser Float
pNumber =   negateFloat <$> (char '-' *> pPositiveFloat)
        <|> pPositiveFloat

-- number without decimal point, decimal digits, base 10 exponent
toFloat :: Int -> Int -> Int -> Float
toFloat n d e = (i2f n) *. (10.0 ^. (d + e))

pPositiveFloat :: Parser Float
pPositiveFloat = (uncurry toFloat) <$> pWithDecimalPoint <*> pExponent

pExponent :: Parser Int
pExponent =   (char 'e' <|> char 'E') *> (char '-' *> yield negate <|> char '+' *> yield id <|> yield id) <*> pInt
          <!> yield 0

pWithDecimalPoint :: Parser (Int, Int)
pWithDecimalPoint = combine <$> some pDigit <*> (char '.' *> some pDigit <|> yield "")
  where 
    s2i cs = foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs)
    combine n d = (s2i (n ++ d), negate $ length d)

pInt :: Parser Int
pInt = (\cs -> foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs)) <$> some pDigit

pDigit :: Parser Char
pDigit = check isDigit anyChar