1 ;;;; json.scm --- JSON reader/writer
2 ;;;; Copyright (C) 2015 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (guix build json) ;; originally (ice-9 json)
20 #:use-module (ice-9 match)
21 #:export (read-json write-json))
24 ;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
31 (define (json-error port)
32 (throw 'json-error port))
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)
40 (define (whitespace? char)
41 "Return #t if CHAR is a whitespace character."
42 (char-set-contains? char-set:whitespace char))
44 (define (consume-whitespace port)
45 "Discard characters from PORT until a non-whitespace character is
47 (match (peek-char port)
48 ((? eof-object?) *unspecified*)
51 (consume-whitespace port))
54 (define (make-keyword-reader keyword value)
55 "Parse the keyword symbol KEYWORD as VALUE."
56 (let ((str (symbol->string keyword)))
60 ((= i (string-length str)) value)
61 ((eqv? (string-ref str i) (read-char port))
63 (else (json-error port)))))))
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))
69 (define (read-hex-digit port)
70 "Read a hexadecimal digit from PORT."
71 (match (read-char port)
88 (_ (json-error port))))
90 (define (read-utf16-character port)
91 "Read a hexadecimal encoded UTF-16 character from PORT."
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))))
98 (define (read-escape-character port)
99 "Read escape character from PORT."
100 (match (read-char port)
109 (#\u (read-utf16-character port))
110 (_ (json-error port))))
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))))))
122 (define char-set:json-digit
123 (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
125 (define (digit? char)
126 (char-set-contains? char-set:json-digit char))
128 (define (read-digit port)
129 "Read a digit 0-9 from PORT."
130 (match (read-char port)
141 (else (json-error port))))
143 (define (read-digits port)
144 "Read a sequence of digits from PORT."
145 (let loop ((result '()))
146 (match (peek-char port)
150 (loop (cons (read-digit port) result)))
151 (else (reverse result)))))
153 (define (list->integer digits)
154 "Convert the list DIGITS to an integer."
155 (let loop ((i (1- (length digits)))
162 (+ result (* n (expt 10 i)))
165 (define (read-positive-integer port)
166 "Read a positive integer with no leading zeroes from PORT."
167 (match (read-digits port)
169 (json-error port)) ; no leading zeroes allowed
171 (list->integer digits))))
173 (define (read-exponent port)
174 "Read exponent from PORT."
176 (list->integer (read-digits port)))
178 (unless (memv (read-char port) '(#\e #\E))
181 (match (peek-char port)
192 (_ (json-error port))))
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)))
201 (define (read-positive-number port)
202 "Read a positive number from PORT."
203 (let* ((integer (match (peek-char port)
210 (read-positive-integer port))
211 (_ (json-error port))))
212 (fraction (match (peek-char port)
215 (read-fraction port))
217 (exponent (match (peek-char port)
219 (read-exponent port))
221 (n (* (+ integer fraction) (expt 10 exponent))))
223 ;; Keep integers as exact numbers, but convert numbers encoded as
224 ;; floating point numbers to an inexact representation.
227 (exact->inexact n))))
229 (define (read-number port)
230 "Read a number from PORT"
231 (match (peek-char port)
236 (- (read-positive-number port)))
238 (read-positive-number port))
239 (_ (json-error port))))
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)))
251 (assert-char port #\{)
252 (consume-whitespace port)
254 (if (eqv? #\} (peek-char port))
258 (let loop ((result (list (read-key+value-pair))))
259 (consume-whitespace port)
260 (match (peek-char port)
261 (#\, ; read another value
263 (consume-whitespace port)
264 (loop (cons (read-key+value-pair) result)))
267 (cons '@ (reverse result)))
268 (_ (json-error port))))))
270 (define (read-array port)
271 "Read array from PORT."
272 (assert-char port #\[)
273 (consume-whitespace port)
275 (if (eqv? #\] (peek-char port))
279 (let loop ((result (list (read-value port))))
280 (consume-whitespace port)
281 (match (peek-char port)
282 (#\, ; read another value
284 (consume-whitespace port)
285 (loop (cons (read-value port) result)))
289 (_ (json-error port))))))
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))
304 (_ (json-error port))))
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))
319 (define (write-string str port)
320 "Write STR to PORT in JSON string format."
321 (define (escape-char char)
335 (string-for-each escape-char str)
338 (define (write-object alist port)
339 "Write ALIST to PORT in JSON object format."
340 ;; Keys may be strings or symbols.
343 ((? string? key) key)
344 ((? symbol? key) (symbol->string key))))
346 (define (write-pair pair)
349 (write-string (key->string key) port)
351 (write-json value port))))
357 (for-each (lambda (pair)
364 (define (write-array lst port)
365 "Write LST to PORT in JSON array format."
370 (for-each (lambda (val)
371 (write-json val port)
374 (write-json end port)))
377 (define (write-json exp port)
378 "Write EXP to PORT in JSON format."
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))))