suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

re-organized in preparation for additions

Browse Source
This commit is contained in:
Matthias Felleisen 2016-05-01 09:47:30 -04:00
parent 76418e9be8
commit fdcbe249f9
1 changed files with 81 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
racket/collects/json/main.rkt
View File

@ -1,20 +1,50 @@
#lang racket/base #lang racket/base
#| Roughly based on the PLaneT package by Dave Herman, ;; Roughly based on the PLaneT package by Dave Herman,
Originally released under MIT license. ;; Originally released under MIT license.
|#
;; ---------------------------------------------------------------------------- ;; edited: Matthias, organization in preparation for pretty-print
;; Customization
;; -----------------------------------------------------------------------------
;; SERVICES
(provide
;; Parameter
json-null ;; Parameter
;; Any -> Boolean
jsexpr?
#;
(->* (Output-Port) ([#:null Any][#:encode (U 'control 'all)]))
;; #:null (json-null)
;; #:encode 'control
write-json
#;
(->* (Input-Port) ([#:null Any]))
;; #null: (json-null)
read-json
jsexpr->string
jsexpr->bytes
string->jsexpr
bytes->jsexpr)
;; -----------------------------------------------------------------------------
;; DEPENDENCIES
(require syntax/readerr)
;; -----------------------------------------------------------------------------
;; CUSTOMIZATION
;; The default translation for a JSON `null' value ;; The default translation for a JSON `null' value
(provide json-null)
(define json-null (make-parameter 'null)) (define json-null (make-parameter 'null))
;; ---------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
;; Predicate ;; PREDICATE
(provide jsexpr?)
(define (jsexpr? x #:null [jsnull (json-null)]) (define (jsexpr? x #:null [jsnull (json-null)])
(let loop ([x x]) (let loop ([x x])
(or (exact-integer? x) (or (exact-integer? x)
@ -29,30 +59,34 @@
(define (real-real? x) ; not nan or inf (define (real-real? x) ; not nan or inf
(and (inexact-real? x) (not (member x '(+nan.0 +inf.0 -inf.0))))) (and (inexact-real? x) (not (member x '(+nan.0 +inf.0 -inf.0)))))
;; ---------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
;; Generation: Racket -> JSON ;; GENERATION (from Racket to JSON)
(define (write-json x [o (current-output-port)]
#:null [jsnull (json-null)] #:encode [enc 'control])
(write-json* 'write-json x o jsnull enc))
(define (write-json* who x o jsnull enc) (define (write-json* who x o jsnull enc)
(define (escape m) (define (escape m)
(define ch (string-ref m 0)) (define ch (string-ref m 0))
(define r (define r
(assoc ch '([#\backspace . "\\b"] [#\newline . "\\n"] [#\return . "\\r"] (assoc ch '([#\backspace . "\\b"] [#\newline . "\\n"] [#\return . "\\r"]
[#\page . "\\f"] [#\tab . "\\t"] [#\page . "\\f"] [#\tab . "\\t"]
[#\\ . "\\\\"] [#\" . "\\\""]))) [#\\ . "\\\\"] [#\" . "\\\""])))
(define (u-esc n) (define (u-esc n)
(define str (number->string n 16)) (define str (number->string n 16))
(define pad (case (string-length str) (define pad (case (string-length str)
[(1) "000"] [(2) "00"] [(3) "0"] [else ""])) [(1) "000"] [(2) "00"] [(3) "0"] [else ""]))
(string-append "\\u" pad str)) (string-append "\\u" pad str))
(if r (if r
(cdr r) (cdr r)
(let ([n (char->integer ch)]) (let ([n (char->integer ch)])
(if (n . < . #x10000) (if (n . < . #x10000)
(u-esc n) (u-esc n)
;; use the (utf-16 surrogate pair) double \u-encoding ;; use the (utf-16 surrogate pair) double \u-encoding
(let ([n (- n #x10000)]) (let ([n (- n #x10000)])
(string-append (u-esc (+ #xD800 (arithmetic-shift n -10))) (string-append (u-esc (+ #xD800 (arithmetic-shift n -10)))
(u-esc (+ #xDC00 (bitwise-and n #x3FF))))))))) (u-esc (+ #xDC00 (bitwise-and n #x3FF)))))))))
(define rx-to-encode (define rx-to-encode
(case enc (case enc
;; FIXME: This should also encode (always) anything that is represented ;; FIXME: This should also encode (always) anything that is represented
@ -94,15 +128,11 @@
[else (raise-type-error who "legal JSON value" x)])) [else (raise-type-error who "legal JSON value" x)]))
(void)) (void))
(provide write-json) ;; -----------------------------------------------------------------------------
(define (write-json x [o (current-output-port)] ;; PARSING (from JSON to Racket)
#:null [jsnull (json-null)] #:encode [enc 'control])
(write-json* 'write-json x o jsnull enc))
;; ---------------------------------------------------------------------------- (define (read-json [i (current-input-port)] #:null [jsnull (json-null)])
;; Parsing: JSON -> Racket (read-json* 'read-json i jsnull))
(require syntax/readerr)
(define (read-json* who i jsnull) (define (read-json* who i jsnull)
;; Follows the specification (eg, at json.org) -- no extensions. ;; Follows the specification (eg, at json.org) -- no extensions.
@ -129,8 +159,8 @@
(cond (cond
[(not esc) (bytes->string/utf-8 (get-output-bytes result))] [(not esc) (bytes->string/utf-8 (get-output-bytes result))]
[(assoc esc '([#"b" . #"\b"] [#"n" . #"\n"] [#"r" . #"\r"] [(assoc esc '([#"b" . #"\b"] [#"n" . #"\n"] [#"r" . #"\r"]
[#"f" . #"\f"] [#"t" . #"\t"] [#"f" . #"\f"] [#"t" . #"\t"]
[#"\\" . #"\\"] [#"\"" . #"\""] [#"/" . #"/"])) [#"\\" . #"\\"] [#"\"" . #"\""] [#"/" . #"/"]))
=> (λ (m) (write-bytes (cdr m) result) (loop))] => (λ (m) (write-bytes (cdr m) result) (loop))]
[(equal? esc #"u") [(equal? esc #"u")
(let* ([e (or (regexp-try-match #px#"^[a-fA-F0-9]{4}" i) (let* ([e (or (regexp-try-match #px#"^[a-fA-F0-9]{4}" i)
@ -138,16 +168,16 @@
[e (string->number (bytes->string/utf-8 (car e)) 16)]) [e (string->number (bytes->string/utf-8 (car e)) 16)])
(define e* (define e*
(if (<= #xD800 e #xDFFF) (if (<= #xD800 e #xDFFF)
;; it's the first part of a UTF-16 surrogate pair ;; 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) (let* ([e2 (or (regexp-try-match #px#"^\\\\u([a-fA-F0-9]{4})" i)
(err "bad string \\u escape, ~a" (err "bad string \\u escape, ~a"
"missing second half of a UTF16 pair"))] "missing second half of a UTF16 pair"))]
[e2 (string->number (bytes->string/utf-8 (cadr e2)) 16)]) [e2 (string->number (bytes->string/utf-8 (cadr e2)) 16)])
(if (<= #xDC00 e2 #xDFFF) (if (<= #xDC00 e2 #xDFFF)
(+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000) (+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000)
(err "bad string \\u escape, ~a" (err "bad string \\u escape, ~a"
"bad second half of a UTF16 pair"))) "bad second half of a UTF16 pair")))
e)) ; single \u escape e)) ; single \u escape
(write-string (string (integer->char e*)) result) (write-string (string (integer->char e*)) result)
(loop))] (loop))]
[else (err "bad string escape: \"~a\"" esc)]))) [else (err "bad string escape: \"~a\"" esc)])))
@ -155,12 +185,12 @@
(define (read-list what end-rx read-one) (define (read-list what end-rx read-one)
(skip-whitespace) (skip-whitespace)
(if (regexp-try-match end-rx i) (if (regexp-try-match end-rx i)
'() '()
(let loop ([l (list (read-one))]) (let loop ([l (list (read-one))])
(skip-whitespace) (skip-whitespace)
(cond [(regexp-try-match end-rx i) (reverse l)] (cond [(regexp-try-match end-rx i) (reverse l)]
[(regexp-try-match #rx#"^," i) (loop (cons (read-one) l))] [(regexp-try-match #rx#"^," i) (loop (cons (read-one) l))]
[else (err "error while parsing a json ~a" what)])))) [else (err "error while parsing a json ~a" what)]))))
;; ;;
(define (read-hash) (define (read-hash)
(define (read-pair) (define (read-pair)
@ -192,27 +222,23 @@
;; ;;
(read-json #t)) (read-json #t))
(provide read-json) ;; -----------------------------------------------------------------------------
(define (read-json [i (current-input-port)] #:null [jsnull (json-null)]) ;; CONVENIENCE FUNCTIONS
(read-json* 'read-json i jsnull))
;; ----------------------------------------------------------------------------
;; Convenience functions
(provide jsexpr->string jsexpr->bytes)
(define (jsexpr->string x #:null [jsnull (json-null)] #:encode [enc 'control]) (define (jsexpr->string x #:null [jsnull (json-null)] #:encode [enc 'control])
(define o (open-output-string)) (define o (open-output-string))
(write-json* 'jsexpr->string x o jsnull enc) (write-json* 'jsexpr->string x o jsnull enc)
(get-output-string o)) (get-output-string o))
(define (jsexpr->bytes x #:null [jsnull (json-null)] #:encode [enc 'control]) (define (jsexpr->bytes x #:null [jsnull (json-null)] #:encode [enc 'control])
(define o (open-output-bytes)) (define o (open-output-bytes))
(write-json* 'jsexpr->bytes x o jsnull enc) (write-json* 'jsexpr->bytes x o jsnull enc)
(get-output-bytes o)) (get-output-bytes o))
(provide string->jsexpr bytes->jsexpr)
(define (string->jsexpr str #:null [jsnull (json-null)]) (define (string->jsexpr str #:null [jsnull (json-null)])
(unless (string? str) (raise-type-error 'string->jsexpr "string" str)) (unless (string? str) (raise-type-error 'string->jsexpr "string" str))
(read-json* 'string->jsexpr (open-input-string str) jsnull)) (read-json* 'string->jsexpr (open-input-string str) jsnull))
(define (bytes->jsexpr str #:null [jsnull (json-null)]) (define (bytes->jsexpr str #:null [jsnull (json-null)])
(unless (bytes? str) (raise-type-error 'bytes->jsexpr "bytes" str)) (unless (bytes? str) (raise-type-error 'bytes->jsexpr "bytes" str))
(read-json* 'bytes->jsexpr (open-input-bytes str) jsnull)) (read-json* 'bytes->jsexpr (open-input-bytes str) jsnull))