diff options
Diffstat (limited to 'ebus-racket/util/json.rkt')
| -rw-r--r-- | ebus-racket/util/json.rkt | 198 |
1 files changed, 198 insertions, 0 deletions
diff --git a/ebus-racket/util/json.rkt b/ebus-racket/util/json.rkt new file mode 100644 index 0000000..39bef38 --- /dev/null +++ b/ebus-racket/util/json.rkt @@ -0,0 +1,198 @@ +#lang racket/base + +#| Roughly based on the PLaneT package by Dave Herman, + Originally released under MIT license. +|# + +;; ---------------------------------------------------------------------------- +;; Customization + +;; The default translation for a JSON `null' value +(provide json-null) +(define json-null (make-parameter 'null)) + +;; ---------------------------------------------------------------------------- +;; Predicate + +(provide jsexpr?) +(define (jsexpr? x #:null [jsnull (json-null)]) + (let loop ([x x]) + (or (exact-integer? x) + (inexact-real? x) + (boolean? x) + (string? x) + (eq? x jsnull) + (and (list? x) (andmap loop x)) + (and (hash? x) (for/and ([(k v) (in-hash x)]) + (and (symbol? k) (loop v))))))) + +;; ---------------------------------------------------------------------------- +;; Generation: Racket -> JSON + +(provide write-json) +(define (write-json x [o (current-output-port)] + #:null [jsnull (json-null)] #:encode [enc 'control]) + (define (escape m) + (define ch (string-ref m 0)) + (define r + (assoc ch '([#\backspace . "\\b"] [#\newline . "\\n"] [#\return . "\\r"] + [#\page . "\\f"] [#\tab . "\\t"] + [#\\ . "\\\\"] [#\" . "\\\""]))) + (define (u-esc n) + (define str (number->string n 16)) + (define pad (case (string-length str) + [(1) "000"] [(2) "00"] [(3) "0"] [else ""])) + (string-append "\\u" pad str)) + (if r + (cdr r) + (let ([n (char->integer ch)]) + (if (n . < . #x10000) + (u-esc n) + ;; use the (utf-16 surrogate pair) double \u-encoding + (let ([n (- n #x10000)]) + (string-append (u-esc (+ #xD800 (arithmetic-shift n -10))) + (u-esc (+ #xDC00 (bitwise-and n #x3FF))))))))) + (define rx-to-encode + (case enc + [(control) #rx"[\0-\37\\\"\177]"] + [(all) #rx"[\0-\37\\\"\177-\U10FFFF]"] + [else (raise-type-error 'write-json "encoding symbol" enc)])) + (define (write-json-string str) + (write-bytes #"\"" o) + (write-string (regexp-replace* rx-to-encode str escape) o) + (write-bytes #"\"" o)) + (let loop ([x x]) + (cond [(or (exact-integer? x) (inexact-real? x)) (write x o)] + [(eq? x #f) (write-bytes #"false" o)] + [(eq? x #t) (write-bytes #"true" o)] + [(eq? x jsnull) (write-bytes #"null" o)] + [(string? x) (write-json-string x)] + [(list? x) + (write-bytes #"[" o) + (when (pair? x) + (loop (car x)) + (for ([x (in-list (cdr x))]) (write-bytes #"," o) (loop x))) + (write-bytes #"]" o)] + [(hash? x) + (write-bytes #"{" o) + (define first? #t) + (for ([(k v) (in-hash x)]) + (unless (symbol? k) + (raise-type-error 'write-json "bad JSON key value" k)) + (if first? (set! first? #f) (write-bytes #"," o)) + (write (symbol->string k) o) ; no `printf' => proper escapes + (write-bytes #":" o) + (loop v)) + (write-bytes #"}" o)] + [else (raise-type-error 'write-json "bad JSON value" x)])) + (void)) + +;; ---------------------------------------------------------------------------- +;; Parsing: JSON -> Racket + +(require syntax/readerr) + +(provide read-json) +(define (read-json [i (current-input-port)] #:null [jsnull (json-null)]) + ;; Follows the specification (eg, at json.org) -- no extensions. + ;; + (define (err fmt . args) + (define-values [l c p] (port-next-location i)) + (raise-read-error (format "read-json: ~a" (apply format fmt args)) + (object-name i) l c p #f)) + (define (skip-whitespace) (regexp-match? #px#"^\\s*" i)) + ;; + ;; Reading a string *could* have been nearly trivial using the racket + ;; reader, except that it won't handle a "\/"... + (define (read-string) + (let loop ([l* '()]) + ;; note: use a string regexp to extract utf-8-able text + (define m (cdr (or (regexp-try-match #rx"^([^\"\\]*)(\"|\\\\(.))" i) + (err "unterminated string")))) + (define l (if ((bytes-length (car m)) . > . 0) (cons (car m) l*) l*)) + (define esc (caddr m)) + (cond + [(not esc) (bytes->string/utf-8 (apply bytes-append (reverse l)))] + [(assoc esc '([#"b" . #"\b"] [#"n" . #"\n"] [#"r" . #"\r"] + [#"f" . #"\f"] [#"t" . #"\t"] + [#"\\" . #"\\"] [#"\"" . #"\""] [#"/" . #"/"])) + => (λ (m) (loop (cons (cdr m) l)))] + [(equal? esc #"u") + (let* ([e (or (regexp-try-match #px#"^[a-fA-F0-9]{4}" i) + (err "bad string \\u escape"))] + [e (string->number (bytes->string/utf-8 (car e)) 16)]) + (define e* + (if (<= #xD800 e #xDFFF) + ;; it's the first part of a UTF-16 surrogate pair + (let* ([e2 (or (regexp-try-match #px#"^\\\\u([a-fA-F0-9]{4})" i) + (err "bad string \\u escape, ~a" + "missing second half of a UTF16 pair"))] + [e2 (string->number (bytes->string/utf-8 (cadr e2)) 16)]) + (if (<= #xDC00 e2 #xDFFF) + (+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000) + (err "bad string \\u escape, ~a" + "bad second half of a UTF16 pair"))) + e)) ; single \u escape + (loop (cons (string->bytes/utf-8 (string (integer->char e*))) l)))] + [else (err "bad string escape: \"~a\"" esc)]))) + ;; + (define (read-list what end-rx read-one) + (skip-whitespace) + (if (regexp-try-match end-rx i) + '() + (let loop ([l (list (read-one))]) + (skip-whitespace) + (cond [(regexp-try-match end-rx i) (reverse l)] + [(regexp-try-match #rx#"^," i) (loop (cons (read-one) l))] + [else (err "error while parsing a json ~a" what)])))) + ;; + (define (read-hash) + (define (read-pair) + (define k (read-json)) + (unless (string? k) (err "non-string value used for json object key")) + (skip-whitespace) + (unless (regexp-try-match #rx#"^:" i) + (err "error while parsing a json object pair")) + (list (string->symbol k) (read-json))) + (apply hasheq (apply append (read-list 'object #rx#"^}" read-pair)))) + ;; + (define (read-json [top? #f]) + (skip-whitespace) + (cond + [(and top? (eof-object? (peek-char i))) eof] + [(regexp-try-match #px#"^true\\b" i) #t] + [(regexp-try-match #px#"^false\\b" i) #f] + [(regexp-try-match #px#"^null\\b" i) jsnull] + [(regexp-try-match + #rx#"^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+)?(?:[eE][+-]?[0-9]+)?" i) + => (λ (bs) (string->number (bytes->string/utf-8 (car bs))))] + [(regexp-try-match #rx#"^[\"[{]" i) + => (λ (m) + (let ([m (car m)]) + (cond [(equal? m #"\"") (read-string)] + [(equal? m #"[") (read-list 'array #rx#"^\\]" read-json)] + [(equal? m #"{") (read-hash)])))] + [else (err "bad input")])) + ;; + (read-json #t)) + +;; ---------------------------------------------------------------------------- +;; Convenience functions + +(provide jsexpr->string jsexpr->bytes) +(define (jsexpr->string x #:null [jsnull (json-null)] #:encode [enc 'control]) + (define o (open-output-string)) + (write-json x o #:null jsnull #:encode enc) + (get-output-string o)) +(define (jsexpr->bytes x #:null [jsnull (json-null)] #:encode [enc 'control]) + (define o (open-output-bytes)) + (write-json x o #:null jsnull #:encode enc) + (get-output-bytes o)) + +(provide string->jsexpr bytes->jsexpr) +(define (string->jsexpr str #:null [jsnull (json-null)]) + (unless (string? str) (raise-type-error 'string->jsexpr "string" str)) + (read-json (open-input-string str) #:null jsnull)) +(define (bytes->jsexpr str #:null [jsnull (json-null)]) + (unless (bytes? str) (raise-type-error 'bytes->jsexpr "bytes" str)) + (read-json (open-input-bytes str) #:null jsnull)) |