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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
type t =
| Null
| Bool of bool
| Float of float
| String of string
| Array of t list
| Object of (string * t) list
let field name = function
| Object fields -> List.assoc_opt name fields
| _ -> None
let as_string = function String value -> Some value | _ -> None
let as_bool = function Bool value -> Some value | _ -> None
let as_float = function Float value -> Some value | _ -> None
let as_int = function
| Float value when Float.is_integer value -> Some (Int.of_float value)
| _ -> None
let as_list = function Array values -> Some values | _ -> None
let as_object = function Object fields -> Some fields | _ -> None
let escape_string value =
let buffer = Buffer.create (String.length value + 2) in
String.iter
(function
| '"' -> Buffer.add_string buffer "\\\""
| '\\' -> Buffer.add_string buffer "\\\\"
| '\b' -> Buffer.add_string buffer "\\b"
| '\012' -> Buffer.add_string buffer "\\f"
| '\n' -> Buffer.add_string buffer "\\n"
| '\r' -> Buffer.add_string buffer "\\r"
| '\t' -> Buffer.add_string buffer "\\t"
| ch when Char.code ch < 0x20 ->
Buffer.add_string buffer (Printf.sprintf "\\u%04x" (Char.code ch))
| ch -> Buffer.add_char buffer ch)
value;
Buffer.contents buffer
let rec to_string = function
| Null -> "null"
| Bool true -> "true"
| Bool false -> "false"
| Float value ->
if Float.is_integer value then Printf.sprintf "%.0f" value
else string_of_float value
| String value -> "\"" ^ escape_string value ^ "\""
| Array values -> "[" ^ String.concat "," (List.map to_string values) ^ "]"
| Object fields ->
let encode_field (key, value) =
"\"" ^ escape_string key ^ "\":" ^ to_string value
in
"{" ^ String.concat "," (List.map encode_field fields) ^ "}"
type parser = { source : string; mutable index : int }
let parse_error parser message =
Error (Printf.sprintf "JSON parse error at byte %d: %s" parser.index message)
let peek parser =
if parser.index >= String.length parser.source then None
else Some parser.source.[parser.index]
let bump parser =
match peek parser with
| None -> None
| Some ch ->
parser.index <- parser.index + 1;
Some ch
let rec skip_ws parser =
match peek parser with
| Some (' ' | '\n' | '\r' | '\t') ->
parser.index <- parser.index + 1;
skip_ws parser
| _ -> ()
let expect parser expected =
match bump parser with
| Some ch when ch = expected -> Ok ()
| Some _ -> parse_error parser (Printf.sprintf "expected %C" expected)
| None ->
parse_error parser
(Printf.sprintf "expected %C, got end of input" expected)
let hex_value = function
| '0' .. '9' as ch -> Some (Char.code ch - Char.code '0')
| 'a' .. 'f' as ch -> Some (10 + Char.code ch - Char.code 'a')
| 'A' .. 'F' as ch -> Some (10 + Char.code ch - Char.code 'A')
| _ -> None
let parse_unicode_escape parser =
let value = ref 0 in
let rec loop count =
if count = 4 then Ok !value
else
match bump parser with
| Some ch -> (
match hex_value ch with
| Some v ->
value := (!value * 16) + v;
loop (count + 1)
| None -> parse_error parser "invalid unicode escape")
| None -> parse_error parser "unterminated unicode escape"
in
loop 0
let add_utf8 buffer code =
if code <= 0x7F then Buffer.add_char buffer (Char.chr code)
else if code <= 0x7FF then (
Buffer.add_char buffer (Char.chr (0xC0 lor (code lsr 6)));
Buffer.add_char buffer (Char.chr (0x80 lor (code land 0x3F))))
else (
Buffer.add_char buffer (Char.chr (0xE0 lor (code lsr 12)));
Buffer.add_char buffer (Char.chr (0x80 lor ((code lsr 6) land 0x3F)));
Buffer.add_char buffer (Char.chr (0x80 lor (code land 0x3F))))
let parse_string parser =
match expect parser '"' with
| Error _ as err -> err
| Ok () ->
let buffer = Buffer.create 32 in
let rec loop () =
match bump parser with
| None -> parse_error parser "unterminated string"
| Some '"' -> Ok (String (Buffer.contents buffer))
| Some '\\' -> (
match bump parser with
| Some '"' ->
Buffer.add_char buffer '"';
loop ()
| Some '\\' ->
Buffer.add_char buffer '\\';
loop ()
| Some '/' ->
Buffer.add_char buffer '/';
loop ()
| Some 'b' ->
Buffer.add_char buffer '\b';
loop ()
| Some 'f' ->
Buffer.add_char buffer '\012';
loop ()
| Some 'n' ->
Buffer.add_char buffer '\n';
loop ()
| Some 'r' ->
Buffer.add_char buffer '\r';
loop ()
| Some 't' ->
Buffer.add_char buffer '\t';
loop ()
| Some 'u' -> (
match parse_unicode_escape parser with
| Error _ as err -> err
| Ok code ->
add_utf8 buffer code;
loop ())
| Some _ -> parse_error parser "invalid escape"
| None -> parse_error parser "unterminated escape")
| Some ch ->
Buffer.add_char buffer ch;
loop ()
in
loop ()
let starts_with parser literal =
let len = String.length literal in
parser.index + len <= String.length parser.source
&& String.sub parser.source parser.index len = literal
let parse_literal parser literal value =
if starts_with parser literal then (
parser.index <- parser.index + String.length literal;
Ok value)
else parse_error parser ("expected " ^ literal)
let parse_number parser =
let start = parser.index in
let consume_while pred =
while
match peek parser with
| Some ch when pred ch ->
parser.index <- parser.index + 1;
true
| _ -> false
do
()
done
in
(match peek parser with
| Some '-' -> parser.index <- parser.index + 1
| _ -> ());
consume_while (function '0' .. '9' -> true | _ -> false);
(match peek parser with
| Some '.' ->
parser.index <- parser.index + 1;
consume_while (function '0' .. '9' -> true | _ -> false)
| _ -> ());
(match peek parser with
| Some ('e' | 'E') ->
parser.index <- parser.index + 1;
(match peek parser with
| Some ('+' | '-') -> parser.index <- parser.index + 1
| _ -> ());
consume_while (function '0' .. '9' -> true | _ -> false)
| _ -> ());
let raw = String.sub parser.source start (parser.index - start) in
match float_of_string_opt raw with
| Some value -> Ok (Float value)
| None -> parse_error parser "invalid number"
let rec parse_value parser =
skip_ws parser;
match peek parser with
| None -> parse_error parser "unexpected end of input"
| Some '"' -> parse_string parser
| Some '{' -> parse_object parser
| Some '[' -> parse_array parser
| Some 't' -> parse_literal parser "true" (Bool true)
| Some 'f' -> parse_literal parser "false" (Bool false)
| Some 'n' -> parse_literal parser "null" Null
| Some ('-' | '0' .. '9') -> parse_number parser
| Some _ -> parse_error parser "unexpected character"
and parse_array parser =
match expect parser '[' with
| Error _ as err -> err
| Ok () ->
skip_ws parser;
let rec loop acc =
skip_ws parser;
match peek parser with
| Some ']' ->
parser.index <- parser.index + 1;
Ok (Array (List.rev acc))
| _ -> (
match parse_value parser with
| Error _ as err -> err
| Ok value -> (
skip_ws parser;
match peek parser with
| Some ',' ->
parser.index <- parser.index + 1;
loop (value :: acc)
| Some ']' ->
parser.index <- parser.index + 1;
Ok (Array (List.rev (value :: acc)))
| _ -> parse_error parser "expected ',' or ']'"))
in
loop []
and parse_object parser =
match expect parser '{' with
| Error _ as err -> err
| Ok () ->
skip_ws parser;
let rec loop acc =
skip_ws parser;
match peek parser with
| Some '}' ->
parser.index <- parser.index + 1;
Ok (Object (List.rev acc))
| _ -> (
match parse_string parser with
| Error _ as err -> err
| Ok (String key) -> (
skip_ws parser;
match expect parser ':' with
| Error _ as err -> err
| Ok () -> (
match parse_value parser with
| Error _ as err -> err
| Ok value -> (
skip_ws parser;
match peek parser with
| Some ',' ->
parser.index <- parser.index + 1;
loop ((key, value) :: acc)
| Some '}' ->
parser.index <- parser.index + 1;
Ok (Object (List.rev ((key, value) :: acc)))
| _ -> parse_error parser "expected ',' or '}'")))
| Ok _ -> parse_error parser "object keys must be strings")
in
loop []
let parse source =
let parser = { source; index = 0 } in
match parse_value parser with
| Error _ as err -> err
| Ok value ->
skip_ws parser;
if parser.index = String.length source then Ok value
else parse_error parser "trailing input"