Initial commit

11 files changed, 350 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..75d491d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+**/*~
\ No newline at end of file
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..169e103
--- /dev/null
+++ b/README.org
@@ -0,0 +1,65 @@
+#+TITLE: JSON meta library
+
+* What is a meta library?
+The purpose of this library is to be a portable shim for many JSON libraries.
+
+* Why?
+If one wants to write portable Scheme which does some JSON processing, one must either:
+
+- Abandon hope of being portable, and depend on an implementation specific library.
+- Use a portable JSON library which is redundant, and may conflict with other libraries that expect parsed JSON to be represented in a certain way.
+- Write a bunch of cond-expands to act as a portability layer, and use different JSON libraries in different contexts.
+
+This library aims to be an implementation of the latter which you can just plug in as a dependency, instead of writing your own.
+
+* API
+** Constructors
+~(json-object pairs ...)~:
+Constructs a new JSON object.
+pairs are ~pair?~ objects with a ~string?~ as the ~car~, and a ~json-value?~ as the ~cdr~.
+
+An alist can be converted to a JSON object like so: ~(apply json-object alist)~
+
+~(json-list objs ...)~:
+Constructs a new JSON list.
+objs are ~json-value?~ objects.
+
+A list can be converted to a JSON list like so: ~(apply json-list some-list)~
+
+~json-null~:
+This is not a constructor, but instead it is a value which represents null in JSON.
+** Predicates
+~(json-value? obj)~:
+Returns true if ~obj~ is a value that can be serialized as JSON.
+This is true for values related to the constructors, and for numbers, strings, and booleans.
+
+~(json-object? obj)~:
+Returns true if ~obj~ is a value that can be serialized as a JSON object.
+Either the result of deserializing a string formatted as a JSON object, or from the ~json-object~ constructor.
+
+~(json-list? obj)~:
+Returns true if ~obj~ is a value that can be serialized as a JSON list.
+Either the result of deserializing a string formatted as a JSON list, or from the ~json-list~ constructor.
+
+~(json-null? obj)~:
+Returns true if ~obj~ is ~eq?~ to ~json-null~.
+** Serialization
+~(json->string obj)~:
+Convert a ~json-value?~ to a JSON formatted ~string?~.
+
+~(string->json str)~
+Converts a ~string?~ into a ~json-value?~
+** Selectors
+~(json-object-ref obj key)~:
+Returns the ~json-value?~ associated with ~key~ in ~obj~.
+~key~ should be a ~string?~, and the behavior when ~obj~ does not contain ~key~ is currently undefined.
+
+~(json-list-ref lst i)~:
+Returns the ~json-value?~ at index ~i~
+
+** Conversion
+~(json-object->alist obj)~:
+Convert ~obj~ to a ~list?~ of ~pair?~ where the ~car~ of each pair is a ~string?~ and the ~cdr~ is the associated ~json-value?~.
+
+~(json-object->list lst)~:
+Convert ~lst~ to a ~list?~ of ~json-value?~.
diff --git a/lib/gerbil.pkg b/lib/gerbil.pkg
new file mode 100644
index 0000000..39dcdf2
--- /dev/null
+++ b/lib/gerbil.pkg
@@ -0,0 +1 @@
+(prelude: :scheme/r7rs)
diff --git a/lib/zambyte/meta/180.scm b/lib/zambyte/meta/180.scm
new file mode 100644
index 0000000..735a895
--- /dev/null
+++ b/lib/zambyte/meta/180.scm
@@ -0,0 +1,40 @@
+(import (except (srfi 180) json-null)
+	(srfi 1)
+	(srfi 2))
+(begin
+  (define (string->json str)
+    (call-with-port (open-input-string str)
+      (lambda (port)
+	(json-read port))))
+
+  (define (json->string json)
+    (call-with-port (open-output-string)
+      (lambda (port)
+	(json-write json port)
+	(get-output-string port))))
+
+  (define (json-object . pairs)
+    (map
+     (lambda (pair)
+       (cons (string->symbol (car pair)) (cdr pair)))
+     pairs))
+
+  (define json-list vector)
+  (define json-null 'null)
+  (define json-object? list?)
+  (define json-list? vector?)
+  ;; json-null? already defined in srfi 180
+
+  (define (json-object-ref json key)
+    (and-let* ((pair (assoc (string->symbol key) json)))
+      (cdr pair)))
+
+  (define json-list-ref vector-ref)
+
+  (define (json-object->alist json)
+    (map
+     (lambda (pair)
+       (cons (symbol->string (car pair)) (cdr pair)))
+     json))
+
+  (define (json-list->list vector->list)))
diff --git a/lib/zambyte/meta/chibi.scm b/lib/zambyte/meta/chibi.scm
new file mode 100644
index 0000000..49f72f6
--- /dev/null
+++ b/lib/zambyte/meta/chibi.scm
@@ -0,0 +1,34 @@
+(import (chibi json)
+	(srfi 1)
+	(srfi 2))
+(begin
+  ;; json->string already defined in chibi json
+  ;; string->json already defined in chibi json
+
+  (define (json-object . pairs)
+    (map
+     (lambda (pair)
+       (cons (string->symbol (car pair)) (cdr pair)))
+     pairs))
+
+  (define json-list vector)
+  (define json-null (if #f #f))
+  (define json-object? list?)
+  (define json-list? vector?)
+
+  (define (json-null? obj)
+    (eq? obj json-null))
+
+  (define (json-object-ref json key)
+    (and-let* ((pair (assoc (string->symbol key) json)))
+      (cdr pair)))
+
+  (define json-list-ref vector-ref)
+
+  (define (json-object->alist json)
+    (map
+     (lambda (pair)
+       (cons (symbol->string (car pair)) (cdr pair)))
+     json))
+
+  (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/gauche.scm b/lib/zambyte/meta/gauche.scm
new file mode 100644
index 0000000..733599a
--- /dev/null
+++ b/lib/zambyte/meta/gauche.scm
@@ -0,0 +1,32 @@
+(import (gauche base)
+	(rfc json)
+	(srfi 1))
+(begin
+  (define array-handler list->vector)
+  (define object-handler identity)
+  (define (special-handler x)
+    (case x
+      ((true) #t)
+      ((false) #f)
+      (else => identity)))
+
+  (define (string->json str)
+    (parameterize ((json-array-handler array-handler)
+		   (json-object-handler object-handler)
+		   (json-special-handler special-handler))
+      (parse-json-string str)))
+
+  (define json->string construct-json-string)
+  (define json-object list)
+  (define json-list vector)
+  (define json-null 'null)
+  (define json-object? list?)
+  (define json-list? vector?)
+
+  (define (json-null? obj)
+    (eq? obj json-null))
+
+  (define json-object-ref assoc-ref)
+  (define json-list-ref vector-ref)
+  (define json-object->alist identity)
+  (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/gerbil.scm b/lib/zambyte/meta/gerbil.scm
new file mode 100644
index 0000000..00f7b0e
--- /dev/null
+++ b/lib/zambyte/meta/gerbil.scm
@@ -0,0 +1,23 @@
+(import (std text json)
+	(scheme hash-table))
+(begin
+  (define string->json string->json-object)
+  (define json->string json-object->string)
+
+  (define (json-object . pairs)
+    (alist->hash-table pairs equal?))
+
+  (define json-list list)
+  (define json-null #!void)
+  (define json-object? hash-table?)
+  (define json-list? list?)
+
+  (define (json-null? obj)
+    (eq? obj json-null))
+
+  (define (json-object-ref json key)
+    (hash-table-ref json (string->symbol key)))
+
+  (define json-list-ref list-ref)
+  (define json-object->alist hash-table->alist)
+  (define json-list->list values))
diff --git a/lib/zambyte/meta/guile.scm b/lib/zambyte/meta/guile.scm
new file mode 100644
index 0000000..cbd998b
--- /dev/null
+++ b/lib/zambyte/meta/guile.scm
@@ -0,0 +1,22 @@
+(import (json)
+	(srfi 1)
+	(srfi 2))
+(begin
+  (define string->json json-string->scm)
+  (define json->string scm->json-string)
+  (define json-object list)
+  (define json-list vector)
+  (define json-null 'null)
+  (define json-object? list?)
+  (define json-list? vector?)
+
+  (define (json-null? obj)
+    (eq? obj json-null))
+
+  (define (json-object-ref json key)
+    (and-let* ((pair (assoc key json)))
+      (cdr pair)))
+
+  (define json-list-ref vector-ref)
+  (define json-object->alist values)
+  (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/json.sld b/lib/zambyte/meta/json.sld
new file mode 100644
index 0000000..0313516
--- /dev/null
+++ b/lib/zambyte/meta/json.sld
@@ -0,0 +1,57 @@
+(define-library (zambyte meta json)
+  ;; portable
+  (export json-ref
+	  json-value?)
+  ;; non-portable
+  (export string->json
+	  json->string
+
+	  json-object
+	  json-list
+	  json-null
+
+	  json-object?
+	  json-list?
+	  json-null?
+
+	  json-object-ref
+	  json-list-ref
+
+	  json-object->alist
+	  json-list->list)
+  (import (scheme base))
+  ;; portable
+  (begin
+    (define (json-ref json key . keys)
+      (let ((ref (cond ((json-object? json) json-object-ref)
+		       ((json-list? json) json-list-ref)
+		       (else (error "json-ref: cannot get reference on json value" json)))))
+	(if (null? keys)
+	    (ref json key)
+	    (apply json-ref (ref json key) keys))))
+
+    (define (json-value? obj)
+      (or (boolean? obj)
+	  (number? obj)
+	  (string? obj)
+	  (json-null? obj)
+	  (json-list? obj)
+	  (json-object? obj))))
+  ;; non-portable
+  (cond-expand
+   ((and (library (macduffie json)) (srfi 69))
+    (include-library-declarations "macduffie.scm"))
+   ((and guile (library (json)))
+    (include-library-declarations "guile.scm"))
+   (gauche
+    (include-library-declarations "gauche.scm"))
+   (gerbil
+    (include-library-declarations "gerbil.scm"))
+   (sagittarius
+    (include-library-declarations "sagittarius.scm"))
+   ((library (chibi json))
+    (include-library-declarations "chibi.scm"))
+   ((library (srfi 180))
+    (include-library-declarations "180.scm"))
+   (else
+    (error "No implementation of JSON library available."))))
diff --git a/lib/zambyte/meta/macduffie.scm b/lib/zambyte/meta/macduffie.scm
new file mode 100644
index 0000000..f80ea18
--- /dev/null
+++ b/lib/zambyte/meta/macduffie.scm
@@ -0,0 +1,19 @@
+(import (rename (macduffie json)
+		(json-null md:json-null))
+	(srfi 69))
+(begin
+  (define string->json json-read-string)
+  (define json->string json-write-string)
+
+  (define (json-object . pairs)
+    (alist->hash-table pairs))
+
+  (define json-list list)
+  (define json-null (md:json-null))
+  (define json-object? hash-table?)
+  (define json-list? list?)
+  ;; json-null? already defined in macduffie json
+  (define json-object-ref hash-table-ref)
+  (define json-list-ref list-ref)
+  (define json-object->alist hash-table->alist)
+  (define json-list->list values))
diff --git a/lib/zambyte/meta/sagittarius.scm b/lib/zambyte/meta/sagittarius.scm
new file mode 100644
index 0000000..3b5a741
--- /dev/null
+++ b/lib/zambyte/meta/sagittarius.scm
@@ -0,0 +1,56 @@
+(import (text json)
+	(srfi 1)
+	(srfi 2))
+(begin
+  (define (string->json str)
+    (call-with-port (open-input-string str)
+      (lambda (port)
+	(json-read port))))
+
+  (define (json->string json)
+    (call-with-port (open-output-string)
+      (lambda (port)
+	(json-write json port)
+	(get-output-string port))))
+
+  (define (json-object . pairs)
+    (if (eq? (*json-map-type*) 'vector)
+	(apply vector pairs)
+	(apply list pairs)))
+
+  (define (json-list . objs)
+    (if (eq? (*json-map-type*) 'vector)
+	(apply list objs)
+	(apply vector objs)))
+
+  (define json-null 'null)
+
+  (define (json-object? json)
+    (if (eq? (*json-map-type*) 'vector)
+	(vector? json)
+	(list? json)))
+
+  (define (json-list? json)
+    (if (eq? (*json-map-type*) 'vector)
+	(list? json)
+	(vector? json)))
+
+  (define (json-null? obj)
+    (eq? obj json-null))
+
+  (define (json-object-ref json key)
+    (and-let* ((pair (assoc key (json-object->alist json))))
+      (cdr pair)))
+
+  (define (json-list-ref json index)
+    (list-ref (json-list->list json) index))
+
+  (define (json-object->alist json)
+    (if (eq? (*json-map-type*) 'vector)
+	(vector->list json)
+	json))
+
+  (define (json-list->list json)
+    (if (eq? (*json-map-type*) 'vector)
+	json
+	(vector->list json))))