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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
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
module JSON.Parser (parseJSON) where

import JSON.Data
import Char
import Float
import DetParse
import Test.EasyCheck

--- 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)

test_pObject_empty :: Test.EasyCheck.Prop
test_pObject_empty = parse pObject "{}" -=- Just (JObject [])

test_pObject_onlyStringKeys :: Test.EasyCheck.Prop
test_pObject_onlyStringKeys = parse pObject "{1: 2}" -=- Nothing

test_pObject_simple :: Test.EasyCheck.Prop
test_pObject_simple = parse pObject "{\"test\": 1, \"test2\": false}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)])

test_pObject_whitespace :: Test.EasyCheck.Prop
test_pObject_whitespace = parse pObject "{\n \"test\": 1,\n \"test2\": false\n}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)])

test_pObject_nested :: Test.EasyCheck.Prop
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 [])

test_pArray_empty :: Test.EasyCheck.Prop
test_pArray_empty = parse pArray "[]" -=- Just (JArray [])

test_pArray_single :: Test.EasyCheck.Prop
test_pArray_single = parse pArray "[1]" -=- Just (JArray [JNumber 1.0])

test_pArray_multi :: Test.EasyCheck.Prop
test_pArray_multi = parse pArray "[true, false, null]" -=- Just (JArray [JTrue, JFalse, JNull])

test_pArray_nested :: Test.EasyCheck.Prop
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)

test_pCharSequence_simple :: Test.EasyCheck.Prop
test_pCharSequence_simple = parse pCharSequence "test" -=- Just "test"

test_pCharSequence_noDoubleQuote :: Test.EasyCheck.Prop
test_pCharSequence_noDoubleQuote = parse pCharSequence "te\"st" -=- Nothing

test_pCharSequence_noStandaloneBackslash :: Test.EasyCheck.Prop
test_pCharSequence_noStandaloneBackslash = parse pCharSequence "He\\world" -=- Nothing

test_pCharSequence_escapedDoubleQuote :: Test.EasyCheck.Prop
test_pCharSequence_escapedDoubleQuote = parse pCharSequence "Hello \\\"World\\\"" -=- Just "Hello \"World\""

test_pCharSequence_escapedBackslash :: Test.EasyCheck.Prop
test_pCharSequence_escapedBackslash = parse pCharSequence "He\\\\world" -=- Just "He\\world"

test_pCharSequence_escapedSlash :: Test.EasyCheck.Prop
test_pCharSequence_escapedSlash = parse pCharSequence "He\\/world" -=- Just "He/world"

test_pCharSequence_escapedBackspace :: Test.EasyCheck.Prop
test_pCharSequence_escapedBackspace = parse pCharSequence "He\\bworld" -=- Just "He\bworld"

test_pCharSequence_escapedFormFeed :: Test.EasyCheck.Prop
test_pCharSequence_escapedFormFeed = parse pCharSequence "He\\fworld" -=- Just "He\fworld"

test_pCharSequence_escapedNewline :: Test.EasyCheck.Prop
test_pCharSequence_escapedNewline = parse pCharSequence "He\\nworld" -=- Just "He\nworld"

test_pCharSequence_escapedCarriageReturn :: Test.EasyCheck.Prop
test_pCharSequence_escapedCarriageReturn = parse pCharSequence "He\\rworld" -=- Just "He\rworld"

test_pCharSequence_escapedTab :: Test.EasyCheck.Prop
test_pCharSequence_escapedTab = parse pCharSequence "He\\tworld" -=- Just "He\tworld"

test_pCharSequence_twoEscapes :: Test.EasyCheck.Prop
test_pCharSequence_twoEscapes = parse pCharSequence "He\\r\\nWorld" -=- Just "He\r\nWorld"

test_pCharSequence_escapedUnicodeChar :: Test.EasyCheck.Prop
test_pCharSequence_escapedUnicodeChar = parse pCharSequence "Hello \\u2603 World" -=- Just "Hello \9731 World"

test_pCharSequence_escapedUnicodeRequiresFourDigits :: Test.EasyCheck.Prop
test_pCharSequence_escapedUnicodeRequiresFourDigits = parse pCharSequence "Hello \\u26 World" -=- Nothing

test_pString_simple :: Test.EasyCheck.Prop
test_pString_simple = parse pString "\"Hello, World\"" -=- Just "Hello, World"

test_pString_complex :: Test.EasyCheck.Prop
test_pString_complex = parse pString "\"Hello \\r\\n \\u2603 World\"" -=- Just "Hello \r\n \9731 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