From b35d1b01b2d3dd96599fbb381bed4efb23c5632f Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Mon, 12 Mar 2012 03:44:42 -0400
Subject: [PATCH] Initial import of Dave Herman's json library.

This commit has the unmodified original.
---
 collects/json/info.rkt   |   3 +
 collects/json/json.scrbl |  89 +++++++++++++++
 collects/json/main.rkt   | 226 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 318 insertions(+)
 create mode 100644 collects/json/info.rkt
 create mode 100644 collects/json/json.scrbl
 create mode 100644 collects/json/main.rkt

diff --git a/collects/json/info.rkt b/collects/json/info.rkt
new file mode 100644
index 0000000000..ec04bd2359
--- /dev/null
+++ b/collects/json/info.rkt
@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("json.scrbl" () (parsing-library))))
diff --git a/collects/json/json.scrbl b/collects/json/json.scrbl
new file mode 100644
index 0000000000..1d840a22e9
--- /dev/null
+++ b/collects/json/json.scrbl
@@ -0,0 +1,89 @@
+#lang scribble/doc
+
+@require[scribble/manual
+         scribble/base
+         scribble/eval
+         scribble/bnf
+         scheme/runtime-path]
+
+@require[(for-syntax scheme/base)]
+
+@require[(for-label scheme/base json)]
+
+@define-runtime-path[home (build-path 'same)]
+
+@define[the-eval
+        (let ([the-eval (make-base-eval)])
+          (parameterize ([current-directory home])
+            (the-eval `(require (file ,(path->string (build-path home "main.ss"))))))
+          the-eval)]
+
+@title[#:tag "top"]{@bold{JSON}}
+
+by Dave Herman (@tt{dherman at ccs dot neu dot edu})
+
+This library provides utilities for marshalling and unmarshalling data in the JSON data exchange format.
+See the @link["http://www.json.org"]{JSON web site} and the @link["http://www.ietf.org/rfc/rfc4627.txt?number=4627"]{JSON RFC}
+for more information about JSON.
+
+@defmodule[json]
+
+@section[#:tag "jsexprs"]{JS-Expressions}
+
+This library defines a subset of Scheme values that can be represented as JSON strings.
+A @deftech{JS-Expression}, or @deftech{jsexpr}, is one of:
+
+@itemlist[
+@item{@schemevalfont{#\null}}
+@item{@scheme[boolean?]}
+@item{@scheme[string?]}
+@item{@scheme[(or integer? inexact-real?)]}
+@item{@scheme[(listof jsexpr?)]}
+@item{@scheme[(hasheqof symbol? jsexpr?)]}
+]
+
+@defproc[(jsexpr? [x any]) boolean?]{
+Performs a deep check to determine whether @scheme[x] is a @tech{jsexpr}.}
+
+@defproc[(read-json [in input-port? (current-input-port)]) jsexpr?]{
+Reads an immutable @tech{jsexpr} from a JSON-encoded input port @scheme[in].}
+
+@defproc[(write-json [x jsexpr?] [out output-port? (current-output-port)]) any]{
+Writes the @tech{jsexpr} @scheme[x], encoded as JSON, to output port @scheme[out].}
+
+@defproc[(jsexpr->json [x jsexpr?]) string?]{
+Generates a JSON source string for the @tech{jsexpr} @scheme[x].}
+
+@defproc[(json->jsexpr [s string?]) jsexpr?]{
+Parses the JSON string @scheme[s] as an immutable @tech{jsexpr}.}
+
+@;examples[#:eval the-eval 42]
+
+@section[#:tag "rationale"]{A word about design}
+
+Because JSON distinguishes syntactically between @tt{null}, array literals, and object literals,
+this library uses non-overlapping datatypes for the three corresponding variants of @tech{jsexpr}.
+
+Since the Scheme null value @scheme['()] overlaps with lists, there is no natural choice for the
+@tech{jsexpr} represented as @tt{null}. We prefer @schemevalfont{#\null} as the least objectionable
+option from Scheme's host of singleton datatypes (note that the @void-const and @undefined-const
+constants do not have @scheme[read]able and @scheme[write]able representations, which makes them
+less convenient choices).
+
+The @link["http://www.ietf.org/rfc/rfc4627.txt?number=4627"]{JSON RFC} only states that object
+literal expressions "SHOULD" contain unique keys, but does not proscribe them entirely. Looking at
+existing practice, it appears that popular JSON libraries parse object literals with duplicate keys
+by simply picking one of the key-value pairs and discarding the others with the same key. This
+behavior is naturally paralleled by PLT Scheme hash tables, making them a natural analog.
+
+Finally, the @link["http://www.ietf.org/rfc/rfc4627.txt?number=4627"]{JSON RFC} is almost completely
+silent about the order of key-value pairs. While the RFC only specifies the syntax of JSON, which of
+course always must represent object literals as an ordered collection, the introduction states:
+
+@nested[#:style 'inset]{An object is an unordered collection of zero or more name/value
+pairs, where a name is a string and a value is a string, number,
+boolean, null, object, or array.}
+
+In practice, JSON libraries discard the order of object literals in parsed JSON text and make no
+guarantees about the order of generated object literals. This again makes hash tables a good choice
+for representing as JSON object literals.
diff --git a/collects/json/main.rkt b/collects/json/main.rkt
new file mode 100644
index 0000000000..21addf7b09
--- /dev/null
+++ b/collects/json/main.rkt
@@ -0,0 +1,226 @@
+#lang racket/base
+
+#| Based on the PLaneT package by Dave Herman,
+   Originally released under MIT license.
+|#
+
+(require (only-in scheme/base [read scheme:read] [write scheme:write]))
+(provide read-json write-json jsexpr->json json->jsexpr jsexpr?)
+
+(define (write-json json [port (current-output-port)])
+  (cond
+    [(hash? json)
+     (display "{" port)
+     (for ([(key value) json]
+           [i (in-naturals)])
+       (when (> i 0)
+         (display ", " port))
+       (fprintf port "\"~a\"" key)
+       (display ": " port)
+       (write-json value port))
+     (display "}" port)]
+    [(list? json)
+     (display "[" port)
+     (for ([(value i) (in-indexed json)])
+       (when (> i 0)
+         (display ", " port))
+       (write-json value port))
+     (display "]" port)]
+    [(or (string? json) (and (number? json) (or (integer? json) (inexact? json))))
+     (scheme:write json port)]
+    [(boolean? json) (scheme:write (if json 'true 'false) port)]
+    [(null-jsexpr? json) (scheme:write 'null port)]
+    [else (error 'json "bad json value: ~v" json)]))
+
+(define (read-json [port (current-input-port)])
+  (skip-whitespace port)
+  (case (peek-char port)
+    [(#\{) (read/hash port)]
+    [(#\[) (read/list port)]
+    [(#\") (read/string port)]
+    [(#\t) (read/true port)]
+    [(#\f) (read/false port)]
+    [(#\n) (read/null port)]
+    [else (read/number port)]))
+
+(define (expect ch . expected)
+  (unless (memq ch expected)
+    (error 'read "expected: ~v, got: ~a" expected ch))
+  ch)
+
+(define (expect-string port expected)
+  (list->string (for/list ([ch expected])
+                  (expect (read-char port) ch))))
+
+(define (skip-whitespace port)
+  (let ([ch (peek-char port)])
+    (when (char-whitespace? ch)
+      (read-char port)
+      (skip-whitespace port))))
+
+(define (in-port-until port reader done?)
+  (make-do-sequence (lambda ()
+                      (values reader
+                              (lambda (port) port)
+                              port
+                              (lambda (port)
+                                (not (done? port)))
+                              (lambda values #t)
+                              (lambda (port . values) #t)))))
+
+(define (read/hash port)
+  (expect (read-char port) #\{)
+  (skip-whitespace port)
+  (begin0 (for/hasheq ([(key value)
+                        (in-port-until port
+                                       (lambda (port)
+                                         (let ([key (read/string port)])
+                                           (unless (string? key)
+                                             (error 'read "expected: string, got: ~v" key))
+                                           (skip-whitespace port)
+                                           (expect (read-char port) #\:)
+                                           (skip-whitespace port)
+                                           (let ([value (read-json port)])
+                                             (skip-whitespace port)
+                                             (expect (peek-char port) #\, #\})
+                                             (values (string->symbol key) value))))
+                                       (lambda (port)
+                                         (eq? (peek-char port) #\})))])
+            (when (eq? (peek-char port) #\,)
+              (read-char port))
+            (skip-whitespace port)
+            (values key value))
+          (expect (read-char port) #\})))
+
+(define (read/list port)
+  (expect (read-char port) #\[)
+  (begin0 (for/list ([value
+                      (in-port-until port
+                                     (lambda (port)
+                                       (skip-whitespace port)
+                                       (begin0 (read-json port)
+                                               (skip-whitespace port)
+                                               (expect (peek-char port) #\, #\])))
+                                     (lambda (port)
+                                       (eq? (peek-char port) #\])))])
+            (when (eq? (peek-char port) #\,)
+              (read-char port))
+            value)
+          (expect (read-char port) #\])))
+
+(define (read/string port)
+  (expect (read-char port) #\")
+  (begin0 (list->string
+           (for/list ([ch (in-port-until port
+                                         (lambda (port)
+                                           (let ([ch (read-char port)])
+                                             (when (eof-object? ch)
+                                               (error 'read "unexpected EOF"))
+                                             (if (eq? ch #\\)
+                                                 (let ([esc (read-char port)])
+                                                   (when (eof-object? ch)
+                                                     (error 'read "unexpected EOF"))
+                                                   (case esc
+                                                     [(#\b) #\backspace]
+                                                     [(#\n) #\newline]
+                                                     [(#\r) #\return]
+                                                     [(#\f) #\page]
+                                                     [(#\t) #\tab]
+                                                     [(#\\) #\\]
+                                                     [(#\") #\"]
+                                                     [(#\/) #\/]
+                                                     [(#\u) (unescape (read-string 4 port))]
+                                                     [else esc]))
+                                                 ch)))
+                                         (lambda (port)
+                                           (eq? (peek-char port) #\")))])
+             ch))
+          (expect (read-char port) #\")))
+
+(define (unescape str)
+  (unless (regexp-match #px"[a-fA-F0-9]{4}" str)
+    (error 'read "bad unicode escape sequence: \"\\u~a\"" str))
+  (integer->char (string->number str 16)))
+
+(define (read/true port)
+  (expect-string port "true")
+  #t)
+
+(define (read/false port)
+  (expect-string port "false")
+  #f)
+
+(define (read/null port)
+  (expect-string port "null")
+  null-jsexpr)
+
+(define (read/digits port)
+  (let ([digits (for/list ([digit (in-port-until port
+                                                 read-char
+                                                 (lambda (port)
+                                                   (let ([ch (peek-char port)])
+                                                     (or (eof-object? ch)
+                                                         (not (char-numeric? ch))))))])
+                  digit)])
+    (when (and (null? digits) (eof-object? (peek-char port)))
+      (error 'read "unexpected EOF"))
+    (when (null? digits)
+      (error 'read "expected: digits, got: ~a" (peek-char port)))
+    digits))
+
+(define (read/exponent port)
+  (let ([sign (case (peek-char port)
+                [(#\- #\+) (list (read-char port))]
+                [else '()])])
+    (append sign (read/digits port))))
+
+(define (read/number port)
+  (let* ([sign (if (eq? (peek-char port) #\-) (list (read-char port)) '())]
+         [digits (read/digits port)]
+         [frac (if (eq? (peek-char port) #\.)
+                   (list* (read-char port) (read/digits port))
+                   '())]
+         [exp (if (memq (peek-char port) '(#\e #\E))
+                  (list* (read-char port) (read/exponent port))
+                  '())])
+    (string->number
+     (list->string
+      (append sign digits frac exp)))))
+
+(define (jsexpr? x)
+  (or (integer? x)
+      (and (number? x) (inexact? x))
+      (null-jsexpr? x)
+      (boolean? x)
+      (string? x)
+      (null? x)
+      (array-jsexpr? x)
+      (object-jsexpr? x)))
+
+(define (array-jsexpr? x)
+  (or (null? x)
+      (and (pair? x)
+           (jsexpr? (car x))
+           (array-jsexpr? (cdr x)))))
+
+(define (object-jsexpr? x)
+  (let/ec return
+    (and (hash? x)
+         (for ([(key value) x])
+           (unless (and (symbol? key) (jsexpr? value))
+             (return #f)))
+         #t)))
+
+(define (null-jsexpr? x)
+  (eqv? x #\null))
+
+(define null-jsexpr #\null)
+
+(define (jsexpr->json x)
+  (let ([out (open-output-string)])
+    (write-json x out)
+    (get-output-string out)))
+
+(define (json->jsexpr s)
+  (let ([in (open-input-string s)])
+    (read-json in)))