;; http://www.ietf.org/rfc/rfc4627.txt #lang scheme/base (provide json read-json write-json) (require "parser.ss" scheme/promise) ;;; 2.4 Numbers (define minus (char #\-)) (define plus (char #\+)) #| (define int ( (chars "0") ;to ensure that integers won't have leading zeros (fmap list->string (many1 digit)))) |# (define int (fmap list->string (many1 digit))) (define fraction (doP (char #\.) (n <- int) (return (string-append "." n)))) (define exponent (doP (one-of '(#\e #\E)) (s <- ( minus plus)) (n <- int) (return (string-append "e" (string s) n)))) (define j:number (doP (s <- (option "" minus)) (i <- int) (f <- (option "" fraction)) (e <- (option "" exponent)) (return (string->number (format "~a~a~a~a" s i f e))))) ;;; 2.5 Strings ;; unescaped = %x20-21 / %x23-5B / %x5D-10FFFF (define unescaped (satisfy (compose (lambda (i) (or (<= #x20 i #x21) (<= #x23 i #x5B) (<= #x5D i #x10FFFF))) char->integer))) (define char-parsers `((#\" . ,(return #\")) (#\\ . ,(return #\\)) (#\/ . ,(return #\/)) (#\b . ,(return #\backspace)) (#\f . ,(return #\page)) (#\n . ,(return #\newline)) (#\r . ,(return #\return)) (#\t . ,(return #\tab)) (#\u . ,(doP (hd <- (count 4 hex-digit)) (return (integer->char (string->number (list->string hd) 16))))))) (define j:char ( unescaped (doP (char #\\) (c <- (one-of (map car char-parsers))) (cdr (assq c char-parsers))))) (define quotes (let ((dq (char #\"))) (between dq dq))) (define j:string (fmap list->string (quotes (many j:char)))) ;;; 2.2 Objects (define j:member (let ((bare-string (doP (c <- letter) (cs <- (many alphanum)) (return (list->string (cons c cs)))))) (doP (k <- (lexeme ( j:string bare-string))) (lexeme (char #\:)) (v <- j:value) (return (cons (string->symbol k) v))))) (define j:object (fmap make-immutable-hasheq (braces (comma-sep (lexeme j:member))))) ;;; 2.3 Arrays (define j:array ;; KLUGE: delaying evaluation of j:value (lambda (input) ((squares (comma-sep (lexeme j:value))) input))) ;;; 2. JSON Grammer (define json-text ( j:object j:array)) ;;; 2.1 Values (define j:false (doP (chars "false") (return #f))) (define j:null (doP (chars "null") (return (void)))) (define j:true (doP (chars "true") (return #t))) (define j:value ( json-text j:string j:false j:true j:number j:null)) ;;; JSON Parser (define json (doP white-space ( json-text (parens json-text)))) (define (read-json in) (parse json in)) ;;; JSON Writer (define (write-json json (out (current-output-port))) (define (dump json) (cond ((list? json) (display "[") (for ((v (in-list json)) (i (in-naturals))) (when (> i 0) (display ",")) (dump v)) (display "]")) ((hash? json) (display "{") (for (((k v) (in-hash json)) (i (in-naturals))) (when (> i 0) (display ",")) (display (format "\"~a\":" k)) (dump v)) (display "}")) ((string? json) (write json)) ((symbol? json) (write (symbol->string json))) ((number? json) (display json)) ((boolean? json) (display (if json "true" "false"))) ((void? json) (display "null")) ((promise? json) (dump (force json))))) (parameterize ((current-output-port out)) (dump json)))