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
|
-- | Parse JSON values using the Parsec combinators.
module Text.JSON.Parsec
( p_value
, p_null
, p_boolean
, p_array
, p_string
, p_object
, p_number
, p_js_string
, p_js_object
, p_jvalue
, module Text.ParserCombinators.Parsec
) where
import Text.JSON.Types
import Text.ParserCombinators.Parsec
import Control.Monad
import Data.Char
import Numeric
p_value :: CharParser () JSValue
p_value = spaces **> p_jvalue
tok :: CharParser () a -> CharParser () a
tok p = p <** spaces
p_jvalue :: CharParser () JSValue
p_jvalue = (JSNull <$$ p_null)
<|> (JSBool <$$> p_boolean)
<|> (JSArray <$$> p_array)
<|> (JSString <$$> p_js_string)
<|> (JSObject <$$> p_js_object)
<|> (JSRational False <$$> p_number)
<?> "JSON value"
p_null :: CharParser () ()
p_null = tok (string "null") >> return ()
p_boolean :: CharParser () Bool
p_boolean = tok
( (True <$$ string "true")
<|> (False <$$ string "false")
)
p_array :: CharParser () [JSValue]
p_array = between (tok (char '[')) (tok (char ']'))
$ p_jvalue `sepBy` tok (char ',')
p_string :: CharParser () String
p_string = between (tok (char '"')) (tok (char '"')) (many p_char)
where p_char = (char '\\' >> p_esc)
<|> (satisfy (\x -> x /= '"' && x /= '\\'))
p_esc = ('"' <$$ char '"')
<|> ('\\' <$$ char '\\')
<|> ('/' <$$ char '/')
<|> ('\b' <$$ char 'b')
<|> ('\f' <$$ char 'f')
<|> ('\n' <$$ char 'n')
<|> ('\r' <$$ char 'r')
<|> ('\t' <$$ char 't')
<|> (char 'u' **> p_uni)
<?> "escape character"
p_uni = check =<< count 4 (satisfy isHexDigit)
where check x | code <= max_char = return (toEnum code)
| otherwise = mzero
where code = fst $ head $ readHex x
max_char = fromEnum (maxBound :: Char)
p_object :: CharParser () [(String,JSValue)]
p_object = between (tok (char '{')) (tok (char '}'))
$ p_field `sepBy` tok (char ',')
where p_field = (,) <$$> (p_string <** tok (char ':')) <**> p_jvalue
p_number :: CharParser () Rational
p_number = tok
$ do s <- getInput
case (reads s, readSigned readFloat s) of
([(x,_)], _)
| isInfinite (x :: Double) -> fail "number out of range"
(_, [(y,s')]) -> y <$$ setInput s'
_ -> mzero <?> "number"
p_js_string :: CharParser () JSString
p_js_string = toJSString <$$> p_string
p_js_object :: CharParser () (JSObject JSValue)
p_js_object = toJSObject <$$> p_object
--------------------------------------------------------------------------------
-- XXX: Because Parsec is not Applicative yet...
(<**>) :: CharParser () (a -> b) -> CharParser () a -> CharParser () b
(<**>) = ap
(**>) :: CharParser () a -> CharParser () b -> CharParser () b
(**>) = (>>)
(<**) :: CharParser () a -> CharParser () b -> CharParser () a
m <** n = do x <- m; _ <- n; return x
(<$$>) :: (a -> b) -> CharParser () a -> CharParser () b
(<$$>) = fmap
(<$$) :: a -> CharParser () b -> CharParser () a
x <$$ m = m >> return x
|
