Finish basic json-record functionality.

Can serialize and deserialize nested records correctly.

Add json-object-map and json-list-map to facilitate recursively demoting records.

Add json-object-set! to make the record mutators functional.

2 files changed, 66 insertions, 14 deletions

diff --git a/lib/zambyte/meta/chibi.scm b/lib/zambyte/meta/chibi.scm
index 7cc777d..ba5a919 100644
--- a/lib/zambyte/meta/chibi.scm
+++ b/lib/zambyte/meta/chibi.scm
@@ -1,5 +1,7 @@
 (import (rename (chibi json) (json->string base:json->string))
-	(srfi 1))
+	(scheme case-lambda)
+	(srfi 1)
+	(srfi 2))
 (begin
   (define json-object list)
   (define json-list vector)
@@ -21,11 +23,9 @@
   (define (json-null? obj)
     (eq? obj json-null))
 
-  ;; json->string already defined in chibi json
   (define (json->string json)
-    (if (json-record? json)
-	(json->string (json-record->fields json))
-	(base:json->string json)))
+    (base:json->string (json->typeless-json json)))
+
   ;; string->json already defined in chibi json
 
   (define (json-object-ref json key)
@@ -37,11 +37,36 @@
 	    ((json-key-not-found)))))
      ((json-record? json)
       (json-object-ref (json-record->fields json) key))
-     (else (error "json-object-ref: not an object" json))))
+     (else ((json-key-not-found)))))
+
+  (define (json-object-set! json key value)
+    (cond
+     ((and (list? json)
+	   (json-object-contains-key? json key))
+      (set-cdr! (assoc key json) value))
+     ((null? json)
+      (error "json-object-set!: cannot set on an empty object" json))
+     ((list? json)
+      (append! json (list (cons key value))))
+     ((json-record? json)
+      (or (and-let* ((pair (assoc key (json-record->mutators json)))
+		     (mutator (cdr pair)))
+	    (mutator json value))
+	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define json-list-ref vector-ref)
   (define json-list-length vector-length)
 
+  (define (json-object-map proc json)
+    (map (lambda (pair)
+	   (call-with-values (lambda () (proc (car pair) (cdr pair)))
+	     (case-lambda
+	       ((key value) (cons key value))
+	       (_ (error "json-object-map: wrong return wrong number of values")))))
+	 json))
+
+  (define json-list-map vector-map)
+
   (define (json-object->alist json)
     (cond
      ((list? json) json)
diff --git a/lib/zambyte/meta/json.sld b/lib/zambyte/meta/json.sld
index 5542884..448c4ec 100644
--- a/lib/zambyte/meta/json.sld
+++ b/lib/zambyte/meta/json.sld
@@ -20,9 +20,13 @@
 	  json->string
 
 	  json-object-ref
+	  json-object-set!
 	  json-list-ref
 	  json-list-length
 
+	  json-object-map
+	  json-list-map
+
 	  json-object->alist
 	  json-list->list)
   (import (scheme base))
@@ -42,9 +46,6 @@
 	     value
 	     (error "json: not a json value" value)))))
 
-    ;; TODO: implement this
-    (define (json-object-set! . args) #f)
-
     (define-syntax handle-field-declarations
       (syntax-rules ()
 	((_ (field accessor))
@@ -55,7 +56,19 @@
 	   (define (accessor obj)
 	     (json-object-ref obj 'field))
 	   (define (mutator obj value)
-	     (json-object-set! obj 'field value))))))
+	     (json-object-set! (json-record->fields obj) 'field value))))))
+
+    (define-syntax get-accessor
+      (syntax-rules ()
+	((_ (field accessor rest ...))
+	 `(field . ,accessor))))
+
+    (define-syntax get-mutator
+      (syntax-rules ()
+	((_ (field _ mutator))
+	 `(field . ,mutator))
+	((_ (field _))
+	 `(field . #f))))
 
     (define-syntax define-json-record-type
       (syntax-rules ()
@@ -68,7 +81,9 @@
 	   (define (constructor fields ...)
 	     (make-json-record 'type
 			       (json-object `(fields . ,fields) ...)
-			       from-json-string))
+			       from-json-string
+			       (list (get-accessor field-declarations) ...)
+			       (list (get-mutator field-declarations) ...)))
 
 	   (define (predicate obj)
 	     (cond
@@ -81,16 +96,28 @@
 	       (parameterize ((json-key-not-found
 			       (lambda ()
 				 (error "key not found in json string when converting to a record" 'from-json-string))))
-		 (constructor (json-ref json 'fields) ...))))
+		 (constructor (json-object-ref json 'fields) ...))))
 
 	   (handle-field-declarations field-declarations) ...))))
 
     (define-record-type <json-record>
-      (make-json-record name fields from-json-string)
+      (make-json-record name fields from-json-string accessors mutators)
       json-record?
       (name json-record->name)
       (fields json-record->fields)
-      (from-json-string json-record->from-json-string))
+      (from-json-string json-record->from-json-string)
+      (accessors json-record->accessors)
+      (mutators json-record->mutators))
+
+    (define (json->typeless-json json)
+      (cond
+       ((json-record? json)
+	(json->typeless-json (json-record->fields json)))
+       ((json-object? json)
+	(json-object-map (lambda (k v) (values k (json->typeless-json v))) json))
+       ((json-list? json)
+	(json-list-map (lambda (v) (json->typeless-json v)) json))
+       (else json)))
 
     (define (json-ref json key . keys)
       (let ((ref (cond ((json-object? json) json-object-ref)