1 files changed, 69 insertions, 47 deletions

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)