Commit | Line | Data |
---|---|---|
09a1f92f JL |
1 | ;;;; json.scm --- JSON reader/writer |
2 | ;;;; Copyright (C) 2015 Free Software Foundation, Inc. | |
3 | ;;;; | |
4 | ;;;; This library is free software; you can redistribute it and/or | |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
7 | ;;;; version 3 of the License, or (at your option) any later version. | |
8 | ;;;; | |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
17 | ;;;; | |
18 | ||
19 | (define-module (guix build json) ;; originally (ice-9 json) | |
20 | #:use-module (ice-9 match) | |
21 | #:export (read-json write-json)) | |
22 | ||
23 | ;; Snarfed from | |
24 | ;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm | |
25 | ;; | |
26 | ||
27 | ;;; | |
28 | ;;; Reader | |
29 | ;;; | |
30 | ||
31 | (define (json-error port) | |
32 | (throw 'json-error port)) | |
33 | ||
34 | (define (assert-char port char) | |
35 | "Read a character from PORT and throw an invalid JSON error if the | |
36 | character is not CHAR." | |
37 | (unless (eqv? (read-char port) char) | |
38 | (json-error port))) | |
39 | ||
40 | (define (whitespace? char) | |
41 | "Return #t if CHAR is a whitespace character." | |
42 | (char-set-contains? char-set:whitespace char)) | |
43 | ||
44 | (define (consume-whitespace port) | |
45 | "Discard characters from PORT until a non-whitespace character is | |
46 | encountered.." | |
47 | (match (peek-char port) | |
48 | ((? eof-object?) *unspecified*) | |
49 | ((? whitespace?) | |
50 | (read-char port) | |
51 | (consume-whitespace port)) | |
52 | (_ *unspecified*))) | |
53 | ||
54 | (define (make-keyword-reader keyword value) | |
55 | "Parse the keyword symbol KEYWORD as VALUE." | |
56 | (let ((str (symbol->string keyword))) | |
57 | (lambda (port) | |
58 | (let loop ((i 0)) | |
59 | (cond | |
60 | ((= i (string-length str)) value) | |
61 | ((eqv? (string-ref str i) (read-char port)) | |
62 | (loop (1+ i))) | |
63 | (else (json-error port))))))) | |
64 | ||
65 | (define read-true (make-keyword-reader 'true #t)) | |
66 | (define read-false (make-keyword-reader 'false #f)) | |
67 | (define read-null (make-keyword-reader 'null #nil)) | |
68 | ||
69 | (define (read-hex-digit port) | |
70 | "Read a hexadecimal digit from PORT." | |
71 | (match (read-char port) | |
72 | (#\0 0) | |
73 | (#\1 1) | |
74 | (#\2 2) | |
75 | (#\3 3) | |
76 | (#\4 4) | |
77 | (#\5 5) | |
78 | (#\6 6) | |
79 | (#\7 7) | |
80 | (#\8 8) | |
81 | (#\9 9) | |
82 | ((or #\A #\a) 10) | |
83 | ((or #\B #\b) 11) | |
84 | ((or #\C #\c) 12) | |
85 | ((or #\D #\d) 13) | |
86 | ((or #\E #\e) 14) | |
87 | ((or #\F #\f) 15) | |
88 | (_ (json-error port)))) | |
89 | ||
90 | (define (read-utf16-character port) | |
91 | "Read a hexadecimal encoded UTF-16 character from PORT." | |
92 | (integer->char | |
93 | (+ (* (read-hex-digit port) (expt 16 3)) | |
94 | (* (read-hex-digit port) (expt 16 2)) | |
95 | (* (read-hex-digit port) 16) | |
96 | (read-hex-digit port)))) | |
97 | ||
98 | (define (read-escape-character port) | |
99 | "Read escape character from PORT." | |
100 | (match (read-char port) | |
101 | (#\" #\") | |
102 | (#\\ #\\) | |
103 | (#\/ #\/) | |
104 | (#\b #\backspace) | |
105 | (#\f #\page) | |
106 | (#\n #\newline) | |
107 | (#\r #\return) | |
108 | (#\t #\tab) | |
109 | (#\u (read-utf16-character port)) | |
110 | (_ (json-error port)))) | |
111 | ||
112 | (define (read-string port) | |
113 | "Read a JSON encoded string from PORT." | |
114 | (assert-char port #\") | |
115 | (let loop ((result '())) | |
116 | (match (read-char port) | |
117 | ((? eof-object?) (json-error port)) | |
118 | (#\" (list->string (reverse result))) | |
119 | (#\\ (loop (cons (read-escape-character port) result))) | |
120 | (char (loop (cons char result)))))) | |
121 | ||
122 | (define char-set:json-digit | |
123 | (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) | |
124 | ||
125 | (define (digit? char) | |
126 | (char-set-contains? char-set:json-digit char)) | |
127 | ||
128 | (define (read-digit port) | |
129 | "Read a digit 0-9 from PORT." | |
130 | (match (read-char port) | |
131 | (#\0 0) | |
132 | (#\1 1) | |
133 | (#\2 2) | |
134 | (#\3 3) | |
135 | (#\4 4) | |
136 | (#\5 5) | |
137 | (#\6 6) | |
138 | (#\7 7) | |
139 | (#\8 8) | |
140 | (#\9 9) | |
141 | (else (json-error port)))) | |
142 | ||
143 | (define (read-digits port) | |
144 | "Read a sequence of digits from PORT." | |
145 | (let loop ((result '())) | |
146 | (match (peek-char port) | |
147 | ((? eof-object?) | |
148 | (reverse result)) | |
149 | ((? digit?) | |
150 | (loop (cons (read-digit port) result))) | |
151 | (else (reverse result))))) | |
152 | ||
153 | (define (list->integer digits) | |
154 | "Convert the list DIGITS to an integer." | |
155 | (let loop ((i (1- (length digits))) | |
156 | (result 0) | |
157 | (digits digits)) | |
158 | (match digits | |
159 | (() result) | |
160 | ((n . tail) | |
161 | (loop (1- i) | |
162 | (+ result (* n (expt 10 i))) | |
163 | tail))))) | |
164 | ||
165 | (define (read-positive-integer port) | |
166 | "Read a positive integer with no leading zeroes from PORT." | |
167 | (match (read-digits port) | |
168 | ((0 . _) | |
169 | (json-error port)) ; no leading zeroes allowed | |
170 | ((digits ...) | |
171 | (list->integer digits)))) | |
172 | ||
173 | (define (read-exponent port) | |
174 | "Read exponent from PORT." | |
175 | (define (read-expt) | |
176 | (list->integer (read-digits port))) | |
177 | ||
178 | (unless (memv (read-char port) '(#\e #\E)) | |
179 | (json-error port)) | |
180 | ||
181 | (match (peek-char port) | |
182 | ((? eof-object?) | |
183 | (json-error port)) | |
184 | (#\- | |
185 | (read-char port) | |
186 | (- (read-expt))) | |
187 | (#\+ | |
188 | (read-char port) | |
189 | (read-expt)) | |
190 | ((? digit?) | |
191 | (read-expt)) | |
192 | (_ (json-error port)))) | |
193 | ||
194 | (define (read-fraction port) | |
195 | "Read fractional number part from PORT as an inexact number." | |
196 | (let* ((digits (read-digits port)) | |
197 | (numerator (list->integer digits)) | |
198 | (denomenator (expt 10 (length digits)))) | |
199 | (/ numerator denomenator))) | |
200 | ||
201 | (define (read-positive-number port) | |
202 | "Read a positive number from PORT." | |
203 | (let* ((integer (match (peek-char port) | |
204 | ((? eof-object?) | |
205 | (json-error port)) | |
206 | (#\0 | |
207 | (read-char port) | |
208 | 0) | |
209 | ((? digit?) | |
210 | (read-positive-integer port)) | |
211 | (_ (json-error port)))) | |
212 | (fraction (match (peek-char port) | |
213 | (#\. | |
214 | (read-char port) | |
215 | (read-fraction port)) | |
216 | (_ 0))) | |
217 | (exponent (match (peek-char port) | |
218 | ((or #\e #\E) | |
219 | (read-exponent port)) | |
220 | (_ 0))) | |
221 | (n (* (+ integer fraction) (expt 10 exponent)))) | |
222 | ||
223 | ;; Keep integers as exact numbers, but convert numbers encoded as | |
224 | ;; floating point numbers to an inexact representation. | |
225 | (if (zero? fraction) | |
226 | n | |
227 | (exact->inexact n)))) | |
228 | ||
229 | (define (read-number port) | |
230 | "Read a number from PORT" | |
231 | (match (peek-char port) | |
232 | ((? eof-object?) | |
233 | (json-error port)) | |
234 | (#\- | |
235 | (read-char port) | |
236 | (- (read-positive-number port))) | |
237 | ((? digit?) | |
238 | (read-positive-number port)) | |
239 | (_ (json-error port)))) | |
240 | ||
241 | (define (read-object port) | |
242 | "Read key/value map from PORT." | |
243 | (define (read-key+value-pair) | |
244 | (let ((key (read-string port))) | |
245 | (consume-whitespace port) | |
246 | (assert-char port #\:) | |
247 | (consume-whitespace port) | |
248 | (let ((value (read-value port))) | |
249 | (cons key value)))) | |
250 | ||
251 | (assert-char port #\{) | |
252 | (consume-whitespace port) | |
253 | ||
254 | (if (eqv? #\} (peek-char port)) | |
255 | (begin | |
256 | (read-char port) | |
257 | '(@)) ; empty object | |
258 | (let loop ((result (list (read-key+value-pair)))) | |
259 | (consume-whitespace port) | |
260 | (match (peek-char port) | |
261 | (#\, ; read another value | |
262 | (read-char port) | |
263 | (consume-whitespace port) | |
264 | (loop (cons (read-key+value-pair) result))) | |
265 | (#\} ; end of object | |
266 | (read-char port) | |
267 | (cons '@ (reverse result))) | |
268 | (_ (json-error port)))))) | |
269 | ||
270 | (define (read-array port) | |
271 | "Read array from PORT." | |
272 | (assert-char port #\[) | |
273 | (consume-whitespace port) | |
274 | ||
275 | (if (eqv? #\] (peek-char port)) | |
276 | (begin | |
277 | (read-char port) | |
278 | '()) ; empty array | |
279 | (let loop ((result (list (read-value port)))) | |
280 | (consume-whitespace port) | |
281 | (match (peek-char port) | |
282 | (#\, ; read another value | |
283 | (read-char port) | |
284 | (consume-whitespace port) | |
285 | (loop (cons (read-value port) result))) | |
286 | (#\] ; end of array | |
287 | (read-char port) | |
288 | (reverse result)) | |
289 | (_ (json-error port)))))) | |
290 | ||
291 | (define (read-value port) | |
292 | "Read a JSON value from PORT." | |
293 | (consume-whitespace port) | |
294 | (match (peek-char port) | |
295 | ((? eof-object?) (json-error port)) | |
296 | (#\" (read-string port)) | |
297 | (#\{ (read-object port)) | |
298 | (#\[ (read-array port)) | |
299 | (#\t (read-true port)) | |
300 | (#\f (read-false port)) | |
301 | (#\n (read-null port)) | |
302 | ((or #\- (? digit?)) | |
303 | (read-number port)) | |
304 | (_ (json-error port)))) | |
305 | ||
306 | (define (read-json port) | |
307 | "Read JSON text from port and return an s-expression representation." | |
308 | (let ((result (read-value port))) | |
309 | (consume-whitespace port) | |
310 | (unless (eof-object? (peek-char port)) | |
311 | (json-error port)) | |
312 | result)) | |
313 | ||
314 | \f | |
315 | ;;; | |
316 | ;;; Writer | |
317 | ;;; | |
318 | ||
319 | (define (write-string str port) | |
320 | "Write STR to PORT in JSON string format." | |
321 | (define (escape-char char) | |
322 | (display (match char | |
323 | (#\" "\\\"") | |
324 | (#\\ "\\\\") | |
325 | (#\/ "\\/") | |
326 | (#\backspace "\\b") | |
327 | (#\page "\\f") | |
328 | (#\newline "\\n") | |
329 | (#\return "\\r") | |
330 | (#\tab "\\t") | |
331 | (_ char)) | |
332 | port)) | |
333 | ||
334 | (display "\"" port) | |
335 | (string-for-each escape-char str) | |
336 | (display "\"" port)) | |
337 | ||
338 | (define (write-object alist port) | |
339 | "Write ALIST to PORT in JSON object format." | |
340 | ;; Keys may be strings or symbols. | |
341 | (define key->string | |
342 | (match-lambda | |
343 | ((? string? key) key) | |
344 | ((? symbol? key) (symbol->string key)))) | |
345 | ||
346 | (define (write-pair pair) | |
347 | (match pair | |
348 | ((key . value) | |
349 | (write-string (key->string key) port) | |
350 | (display ":" port) | |
351 | (write-json value port)))) | |
352 | ||
353 | (display "{" port) | |
354 | (match alist | |
355 | (() #f) | |
356 | ((front ... end) | |
357 | (for-each (lambda (pair) | |
358 | (write-pair pair) | |
359 | (display "," port)) | |
360 | front) | |
361 | (write-pair end))) | |
362 | (display "}" port)) | |
363 | ||
364 | (define (write-array lst port) | |
365 | "Write LST to PORT in JSON array format." | |
366 | (display "[" port) | |
367 | (match lst | |
368 | (() #f) | |
369 | ((front ... end) | |
370 | (for-each (lambda (val) | |
371 | (write-json val port) | |
372 | (display "," port)) | |
373 | front) | |
374 | (write-json end port))) | |
375 | (display "]" port)) | |
376 | ||
377 | (define (write-json exp port) | |
378 | "Write EXP to PORT in JSON format." | |
379 | (match exp | |
380 | (#t (display "true" port)) | |
381 | (#f (display "false" port)) | |
382 | ;; Differentiate #nil from '(). | |
383 | ((and (? boolean? ) #nil) (display "null" port)) | |
384 | ((? string? s) (write-string s port)) | |
385 | ((? real? n) (display n port)) | |
386 | (('@ . alist) (write-object alist port)) | |
387 | ((vals ...) (write-array vals port)))) |