Reach feature parity with Gerbil

1 files changed, 60 insertions, 6 deletions

diff --git a/lib/zambyte/meta/gerbil.scm b/lib/zambyte/meta/gerbil.scm
index 173ef71..497445b 100644
--- a/lib/zambyte/meta/gerbil.scm
+++ b/lib/zambyte/meta/gerbil.scm
@@ -1,29 +1,83 @@
 (import (std text json)
+	(scheme case-lambda)
 	(scheme hash-table))
 (begin
   (define (json-object . pairs)
-    (alist->hash-table pairs equal?))
+    (alist->hash-table pairs eq?))
 
   (define json-list list)
   (define json-null (if #f #f))
-  (define json-object? hash-table?)
+
+  (define (json-object? obj)
+    (or (hash-table? obj)
+	(json-record? obj)))
+
   (define json-list? list?)
 
   (define (json-null? obj)
     (eq? obj json-null))
 
   (define (json-object-contains-key? json key)
-    (hash-table-contains? json key))
+    (or (and (hash-table? json)
+	     (hash-table-contains? json key))
+	(and (json-record? json)
+	     (json-object-contains-key? (json-record->fields json) key))))
 
   (define string->json string->json-object)
-  (define json->string json-object->string)
+
+  (define (json->string json)
+    (json-object->string (json->typeless-json json)))
 
   (define (json-object-ref json key)
-    (if (json-object-contains-key? json key)
+    (cond
+     ((hash-table? json)
+      (if (json-object-contains-key? json key)
 	(hash-table-ref json key)
 	((json-key-not-found))))
+     ((json-record? json)
+      (json-object-ref (json-record->fields json) key))
+     (else ((json-key-not-found)))))
+
+  (define (json-object-set! json key value)
+    (cond
+     ((and (hash-table? json)
+	   (json-object-contains-key? json key))
+      (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))
+	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define json-list-ref list-ref)
   (define json-list-length length)
-  (define json-object->alist hash-table->alist)
+
+  (define (json-object-map proc json)
+    (define res (json-object))
+    (hash-table-for-each
+     (lambda (key value)
+       (call-with-values (lambda () (proc key value))
+	 (case-lambda
+	   ((key value) (hash-table-set! res key value))
+	   (_ (error "json-object-map: proc did not return two values")))))
+     json)
+    res)
+
+  (define json-list-map map)
+
+  (define (json-object->alist obj)
+    (cond
+     ((hash-table? obj)
+      (hash-table->alist obj))
+     ((json-record? obj)
+      (json-object->alist (json->typeless-json obj)))
+     (else (error "json-object->alist: not an object" obj))))
+
   (define json-list->list values))