Use internal record to store JSON record data.

8 files changed, 134 insertions, 84 deletions

diff --git a/lib/zambyte/meta/180.scm b/lib/zambyte/meta/180.scm
index 832e3e2..073b5e8 100644
--- a/lib/zambyte/meta/180.scm
+++ b/lib/zambyte/meta/180.scm
@@ -19,7 +19,7 @@
 	     (assoc key obj)
 	     #t)
 	(and (json-record? obj)
-	     (json-object-contains-key? (json-record->fields obj) key))))
+	     (json-object-contains-key? ((json-record->typeless obj)) key))))
 
   (define (string->json str)
     (call-with-port (open-input-string str)
@@ -40,8 +40,12 @@
 	    (cdr pair)
 	    ((json-key-not-found)))))
      ((json-record? json)
-      (json-object-ref (json-record->fields json) key))
-     (else ((key-not-found)))))
+      (or (and-let* ((pair (assoc key (json-record->mutators json)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record json) value)
+	    json)
+	  (error "json-object-ref: no accessor for field" (json-record->name json) key)))
+     (else ((json-key-not-found)))))
 
   (define (json-object-set! json key value)
     (cond
@@ -58,8 +62,9 @@
       (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))
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record json) value)
+	    json)
 	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define json-list-ref vector-ref)
@@ -78,7 +83,7 @@
   (define (json-object->alist obj)
     (cond
      ((list? obj) obj)
-     ((json-record? obj) (json-record->fields obj))
+     ((json-record? obj) ((json-record->typeless obj)))
      (else (error "json-object->alist: not an object" obj))))
 
   (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/chibi.scm b/lib/zambyte/meta/chibi.scm
index 3ce8192..e765d44 100644
--- a/lib/zambyte/meta/chibi.scm
+++ b/lib/zambyte/meta/chibi.scm
@@ -18,7 +18,7 @@
 	     (assoc key obj)
 	     #t)
 	(and (json-record? obj)
-	     (json-object-contains-key? (json-record->fields obj) key))))
+	     (json-object-contains-key? ((json-record->typeless obj)) key))))
 
   (define (json-null? obj)
     (eq? obj json-null))
@@ -36,7 +36,10 @@
 	    (cdr pair)
 	    ((json-key-not-found)))))
      ((json-record? json)
-      (json-object-ref (json-record->fields json) key))
+      (or (and-let* ((pair (assoc key (json-record->accessors json)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record json)))
+	  (error "json-object-ref: no accessor for field" (json-record->name json) key)))
      (else ((json-key-not-found)))))
 
   (define (json-object-set! json key value)
@@ -51,8 +54,9 @@
       (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))
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record json) value)
+	    json)
 	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define json-list-ref vector-ref)
@@ -71,7 +75,7 @@
   (define (json-object->alist json)
     (cond
      ((list? json) json)
-     ((json-record? json) (json-record->fields json))
+     ((json-record? json) ((json-record->typeless json)))
      (else (error "json-object->alist: not an object" json))))
 
   (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/gauche.scm b/lib/zambyte/meta/gauche.scm
index 51972a0..373c408 100644
--- a/lib/zambyte/meta/gauche.scm
+++ b/lib/zambyte/meta/gauche.scm
@@ -24,7 +24,7 @@
 	     (assoc (symbol->string key) obj)
 	     #t)
 	(and (json-record? obj)
-	     (json-object-contains-key? (json-record->fields obj) key))))
+	     (json-object-contains-key? ((json-record->typeless obj)) key))))
 
   (define array-handler list->vector)
   (define object-handler identity)
@@ -51,7 +51,10 @@
 	    (cdr pair)
 	    ((json-key-not-found)))))
      ((json-record? json)
-      (json-object-ref (json-record->fields json) key))
+      (or (and-let* ((pair (assoc key (json-record->accessors json)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record json)))
+	  (error "json-object-ref: no accessor for field" (json-record->name json) key)))
      (else ((json-key-not-found)))))
 
   (define (json-object-set! json key value)
@@ -66,8 +69,8 @@
       (append! json (list (cons (symbol->string key) value))))
      ((json-record? json)
       (or (and-let* ((pair (assoc key (json-record->mutators json)))
-		     (mutator (cdr pair)))
-	    (mutator json value)
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record json) value)
 	    json)
 	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
diff --git a/lib/zambyte/meta/gerbil.scm b/lib/zambyte/meta/gerbil.scm
index 497445b..9d9cb64 100644
--- a/lib/zambyte/meta/gerbil.scm
+++ b/lib/zambyte/meta/gerbil.scm
@@ -21,7 +21,7 @@
     (or (and (hash-table? json)
 	     (hash-table-contains? json key))
 	(and (json-record? json)
-	     (json-object-contains-key? (json-record->fields json) key))))
+	     (json-object-contains-key? ((json-record->typeless json)) key))))
 
   (define string->json string->json-object)
 
@@ -35,7 +35,10 @@
 	(hash-table-ref json key)
 	((json-key-not-found))))
      ((json-record? json)
-      (json-object-ref (json-record->fields json) key))
+      (or (and-let* ((pair (assoc key (json-record->accessors json)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record json)))
+	  (error "json-object-ref: no accessor for field" (json-record->name json) key)))
      (else ((json-key-not-found)))))
 
   (define (json-object-set! json key value)
@@ -45,15 +48,10 @@
       (hash-table-set! json key value)
       json)
      ((json-record? json)
-      (or (let ((pair (assoc key (json-record->mutators json))))
-	    (if pair
-		(let ((mutator (cdr pair)))
-		  (if mutator
-		      (begin
-			(mutator json value)
-			json)
-		      #f))
-		#f))
+      (or (and-let* ((pair (assoc key (json-record->mutators json)))
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record json) value)
+	    json)
 	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define json-list-ref list-ref)
diff --git a/lib/zambyte/meta/guile-json.scm b/lib/zambyte/meta/guile-json.scm
index bcdd0cb..ebbbd47 100644
--- a/lib/zambyte/meta/guile-json.scm
+++ b/lib/zambyte/meta/guile-json.scm
@@ -23,7 +23,7 @@
 	     (assoc (symbol->string key) obj)
 	     #t)
 	(and (json-record? obj)
-	     (json-object-contains-key? (json-record->fields obj) key))))
+	     (json-object-contains-key? ((json-record->typeless obj)) key))))
 
   (define string->json json-string->scm)
 
@@ -38,7 +38,10 @@
 	    (cdr pair)
 	    ((json-key-not-found)))))
      ((json-record? json)
-      (json-object-ref (json-record->fields json) key))
+      (or (and-let* ((pair (assoc key (json-record->accessors json)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record json)))
+	  (error "json-object-ref: no accessor for field" (json-record->name json) key)))
      (else ((json-key-not-found)))))
 
   (define (json-object-set! json key value)
@@ -53,8 +56,8 @@
       (append! json (list (cons (symbol->string key) value))))
      ((json-record? json)
       (or (and-let* ((pair (assoc key (json-record->mutators json)))
-		     (mutator (cdr pair)))
-	    (mutator json value)
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record json) value)
 	    json)
 	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
@@ -74,7 +77,7 @@
   (define (json-object->alist json)
     (cond
      ((list? json) (map (lambda (pair) (cons (string->symbol (car pair)) (cdr pair))) json))
-     ((json-record? json) (json-record->fields json))
+     ((json-record? json) ((json-record->typeless json)))
      (else (error "json-object->alist: not an object" json))))
 
   (define json-list->list vector->list))
diff --git a/lib/zambyte/meta/json.sld b/lib/zambyte/meta/json.sld
index afac535..0802f94 100644
--- a/lib/zambyte/meta/json.sld
+++ b/lib/zambyte/meta/json.sld
@@ -2,7 +2,6 @@
   ;; portable
   (export json
 	  define-json-record-type
-	  json->typeless-json
 	  json-ref
 	  json-value?
 
@@ -32,6 +31,11 @@
 	  json-object->alist
 	  json-list->list)
   (import (scheme base))
+  (cond-expand
+   (gerbil (import (std srfi 1)
+		   (only (gerbil core) and-let*)))
+   (else (import (srfi 1)
+		 (srfi 2))))
   ;; portable
   (begin
     (define-syntax json
@@ -48,30 +52,6 @@
 	     value
 	     (error "json: not a json value" value)))))
 
-    (define-syntax handle-field-declarations
-      (syntax-rules ()
-	((_ (field accessor))
-	 (define (accessor obj)
-	   (json-object-ref obj 'field)))
-	((_ (field accessor mutator))
-	 (begin
-	   (define (accessor obj)
-	     (json-object-ref obj 'field))
-	   (define (mutator obj 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 ()
 	((_ type
@@ -83,46 +63,88 @@
 	   (define-values (constructor predicate from-json-string)
 	     ((lambda ()
 		(define-record-type type
-		  (make-tag)
-		  pred?)
-		(define tag (make-tag))
+		  (internal-json-record fields ...)
+		  internal-json-record?
+		  field-declarations ...)
+
+		(define-syntax accessors
+		  (syntax-rules ::: ()
+		    ((_) '())
+		    ((_ (name accessor . optional-mutator) rest :::)
+		     (cons `(name . ,accessor) (accessors rest :::)))))
+
+		(define-syntax mutators
+		  (syntax-rules ::: ()
+		    ((_) '())
+		    ((_ (name accessor) rest :::)
+		     (mutators rest :::))
+		    ((_ (name accessor mutator) rest :::)
+		     (cons `(name . ,mutator) (mutators rest :::)))))
+
 		(define (constructor fields ...)
-		  (make-json-record 'type
-				    tag
-				    (json-object `(fields . ,fields) ...)
-				    from-json-string
-				    (list (get-accessor field-declarations) ...)
-				    (list (get-mutator field-declarations) ...)))
+		  (define (typeless)
+		    (json-object `(fields . ,fields) ...))
+		  (json-record (internal-json-record fields ...)
+			       'type
+			       typeless
+			       (accessors field-declarations ...)
+			       (mutators field-declarations ...)))
 
 		(define (predicate obj)
 		  (cond
-		   ((json-record? obj) (pred? (json-record->tag obj)))
+		   ((json-record? obj) (internal-json-record?
+					(json-record->internal-record obj)))
 		   ((json-object? obj) (and (json-object-contains-key? obj 'fields) ...))
 		   (else #f)))
 
 		(define (from-json-string str)
 		  (let ((json (string->json str)))
 		    (if (json-record-from-string-allow-missing-keys)
-			(make-json-record 'type
-					  tag
-					  (string->json str)
-					  from-json-string
-					  (list (get-accessor field-declarations) ...)
-					  (list (get-mutator field-declarations) ...))
+			;; Assume that json-key-not-found is set to something sensible
+			(constructor (json-object-ref json 'fields) ...)
 			(parameterize ((json-key-not-found
 					(lambda ()
 					  (error "key not found in json string when converting to a record" 'type))))
 			  (constructor (json-object-ref json 'fields) ...)))))
 		(values constructor predicate from-json-string))))
-	   (handle-field-declarations field-declarations) ...))))
+	   (define-syntax define-accessors-and-mutators
+	     (syntax-rules ::: ()
+	       ((_) (values))
+	       ((_ (name accessor) rest :::)
+		(begin
+		  (define (accessor json)
+		    (if (json-record? json)
+			(or (and-let* ((pair (assoc 'name (json-record->accessors json)))
+				       (acc (cdr pair)))
+			      (acc (json-record->internal-record json)))
+			    (error (string-append (symbol->string 'accessor) ": no accessor for field") (json-record->name json) 'name))
+			(json-object-ref json 'name)))
+		  (define-accessors-and-mutators rest :::)))
+	       ((_ (name accessor mutator) rest :::)
+		(begin
+		  (define (accessor json)
+		    (if (json-record? json)
+			(or (and-let* ((pair (assoc 'name (json-record->accessors json)))
+				       (acc (cdr pair)))
+			      (acc (json-record->internal-record json)))
+			    (error (string-append (symbol->string 'accessor) ": no accessor for field") (json-record->name json) 'name))
+			(json-object-ref json 'name)))
+		  (define (mutator json value)
+		    (if (json-record? json)
+			(or (and-let* ((pair (assoc 'name (json-record->mutators json)))
+				       (mut! (cdr pair)))
+			      (mut! (json-record->internal-record json) value))
+			    (error (string-append (symbol->string 'mutator) ": no mutator for field") (json-record->name json) 'name))
+			(json-object-set! json 'name value)))
+		  (define-accessors-and-mutators rest :::)))))
+	   (define-accessors-and-mutators field-declarations ...)))))
 
     (define-record-type <json-record>
-      (make-json-record name tag fields from-json-string accessors mutators)
+      (json-record internal-record name typeless accessors mutators)
       json-record?
+      (internal-record json-record->internal-record)
       (name json-record->name)
-      (tag json-record->tag)
-      (fields json-record->fields)
-      (from-json-string json-record->from-json-string)
+      (typeless json-record->typeless)
       (accessors json-record->accessors)
       (mutators json-record->mutators))
 
@@ -131,7 +153,7 @@
     (define (json->typeless-json json)
       (cond
        ((json-record? json)
-	(json->typeless-json (json-record->fields json)))
+	(json->typeless-json ((json-record->typeless json))))
        ((json-object? json)
 	(json-object-map (lambda (k v) (values k (json->typeless-json v))) json))
        ((json-list? json)
diff --git a/lib/zambyte/meta/macduffie.scm b/lib/zambyte/meta/macduffie.scm
index 652bf1d..676e085 100644
--- a/lib/zambyte/meta/macduffie.scm
+++ b/lib/zambyte/meta/macduffie.scm
@@ -22,7 +22,7 @@
     (or (and (hash-table? obj)
 	     (hash-table-exists? obj key))
 	(and (json-record? obj)
-	     (json-object-contains-key? (json-record->fields obj) key))))
+	     (json-object-contains-key? ((json-record->typeless obj)) key))))
 
   (define string->json json-read-string)
 
@@ -35,8 +35,12 @@
       (if (hash-table-exists? j key)
 	  (hash-table-ref j key)
 	  ((json-key-not-found))))
-     ((json-record? j)
-      (json-object-ref (json-record->fields j) key))
+     ((json-record? obj)
+      (or (and-let* ((pair (assoc key (json-record->accessors obj)))
+		     (accessor (cdr pair)))
+	    (accessor (json-record->internal-record obj))
+	    obj)
+	  (error "json-object-ref: no accessor for field" (json-record->name obj) key)))
      (else ((json-key-not-found)))))
 
   (define (json-object-set! obj key value)
@@ -46,8 +50,8 @@
       obj)
      ((json-record? obj)
       (or (and-let* ((pair (assoc key (json-record->mutators obj)))
-		     (mutator (cdr pair)))
-	    (mutator obj value)
+		     (mutator! (cdr pair)))
+	    (mutator! (json-record->internal-record obj) value)
 	    obj)
 	  (error "json-object-set!: no mutator for field" (json-record->name obj) key)))))
 
diff --git a/test/run.scm b/test/run.scm
index 91d57ca..b3020c5 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -168,9 +168,20 @@
 (test-equal "record mutator should mutate the record instance"
   3
   (let ((p (point 1 2)))
-    (set! p (point-set-y! p 3))
+    (point-set-y! p 3)
     (point->y p)))
 
+(test-equal "json-object->alist should return the correct values after mutating the record"
+  3
+  (let ((p (point 1 2)))
+    (point-set-y! p 3)
+    (cdr (assoc 'y (json-object->alist p)))))
+
+(test-equal "should be able to reference record fields with json-object-ref"
+  2
+  (let ((p (point 1 2)))
+    (json-object-ref p 'y)))
+
 (test-assert "should be able to mutate mutable record fields using json-object-set!"
   (guard (_ (else #f))
     (let ((p (point 1 2)))