Reach feature parity with Sagittarius

3 files changed, 84 insertions, 23 deletions

diff --git a/lib/zambyte/meta/sagittarius.scm b/lib/zambyte/meta/sagittarius.scm
index 90d5f0b..7bde9f3 100644
--- a/lib/zambyte/meta/sagittarius.scm
+++ b/lib/zambyte/meta/sagittarius.scm
@@ -1,10 +1,15 @@
+;; https://ktakashi.github.io/sections/section762.html
 (import (text json)
-	(srfi 1))
+	(srfi 1)
+	(srfi 2)
+	(util vector)
+	(scheme case-lambda))
 (begin
   (define (json-object . pairs)
-    (if (eq? (*json-map-type*) 'vector)
-	(apply vector pairs)
-	(apply list pairs)))
+    (let ((pairs (map (lambda (p) (cons (symbol->string (car p)) (cdr p))) pairs)))
+      (if (eq? (*json-map-type*) 'vector)
+	  (apply vector pairs)
+	  (apply list pairs))))
 
   (define (json-list . objs)
     (if (eq? (*json-map-type*) 'vector)
@@ -14,9 +19,10 @@
   (define json-null 'null)
 
   (define (json-object? json)
-    (if (eq? (*json-map-type*) 'vector)
-	(vector? json)
-	(list? json)))
+    (or (json-record? json)
+	(if (eq? (*json-map-type*) 'vector)
+	    (vector? json)
+	    (list? json))))
 
   (define (json-list? json)
     (if (eq? (*json-map-type*) 'vector)
@@ -27,7 +33,11 @@
     (eq? obj json-null))
 
   (define (json-object-contains-key? obj key)
-    (and (assoc key (json-object->alist obj)) #t))
+    (or (and ((if (eq? (*json-map-type*) 'vector) vector? list?) obj)
+	     (assoc key (json-object->alist obj))
+	     #t)
+	(and (json-record? obj)
+	     (json-object-contains-key? (json-record->fields obj) key))))
 
   (define (string->json str)
     (call-with-port (open-input-string str)
@@ -37,14 +47,36 @@
   (define (json->string json)
     (call-with-port (open-output-string)
       (lambda (port)
-	(json-write json port)
+	(json-write (json->typeless-json json) port)
 	(get-output-string port))))
 
   (define (json-object-ref json key)
-    (let ((pair (assoc key (json-object->alist json))))
-      (if pair
-	  (cdr pair)
-	  ((json-key-not-found)))))
+    (cond
+     ((and (not (json-record? json)) (json-object? json))
+      (let ((pair (assoc key (json-object->alist json))))
+	(if pair
+	    (cdr pair)
+	    ((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 (not (json-record? json))
+	   (json-object? json)
+	   (json-object-contains-key? json key))
+      (set-cdr! (if (eq? (*json-map-type*) 'vector)
+		    (vector-find (lambda (pair) (eq? (string->symbol (car pair)) key)) json)
+		    (assoc (symbol->string key) json))
+		value)
+      json)
+     ((json-record? json)
+      (or (and-let* ((pair (assoc key (json-record->mutators json)))
+		     (mutator (cdr pair)))
+	    (set! json (mutator json value))
+	    json)
+	  (error "json-object-set!: no mutator for field" (json-record->name json) key)))))
 
   (define (json-list-ref json index)
     (list-ref (json-list->list json) index))
@@ -54,10 +86,31 @@
 	(length json)
 	(vector-length json)))
 
-  (define (json-object->alist json)
+  (define (json-object-map proc json)
+    ((if (eq? (*json-map-type*) 'vector)
+	 vector-map
+	 map)
+     (lambda (pair)
+       (call-with-values (lambda () (proc (string->symbol (car pair)) (cdr pair)))
+	 (case-lambda
+	   ((key value) (cons (symbol->string key) value))
+	   (_ (error "json-object-map: proc did not return two values")))))
+     json))
+
+  (define (json-list-map proc json-list)
     (if (eq? (*json-map-type*) 'vector)
-	(vector->list json)
-	json))
+	(map proc json-list)
+	(vector-map proc json-list)))
+
+  (define (json-object->alist json)
+    (cond
+     ((and (not (json-record? json)) (json-object? json))
+      (map (lambda (p) (cons (string->symbol (car p)) (cdr p)))
+	   (if (eq? (*json-map-type*) 'vector)
+	       (vector->list json)
+	       json)))
+     ((json-record? json) (json-object->alist (json->typeless-json obj)))
+     (else (error "json-object->alist: not an object" obj))))
 
   (define (json-list->list json)
     (if (eq? (*json-map-type*) 'vector)
diff --git a/test/run.scm b/test/run.scm
index 416c0f4..d0b0e27 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -120,7 +120,7 @@
 (test-equal "should be able to mutate the value of a field using json-object-set!"
   1
   (let ((p (json-object '(x . 5))))
-    (json-object-set! p 'x 1)
+    (set! p (json-object-set! p 'x 1))
     (json-ref p 'x)))
 
 ;; json macro tests
@@ -174,7 +174,7 @@
 (test-assert "should be able to mutate mutable record fields using json-object-set!"
   (guard (_ (else #f))
     (let ((p (point 1 2)))
-      (json-object-set! p 'y #t)
+      (set! p (json-object-set! p 'y #t))
       (point->y p))))
 
 (test-assert "should not be able to mutate immutable record fields using json-object-set!"
@@ -217,11 +217,9 @@
     (point? (line-segment->start ls))))
 
 (test-assert "nested records should be able to round trip to a string"
-  (let* ((p1 (point 1 2))
-	     (p2 (point 3 4))
-	     (ls (line-segment p1 p2))
-	     (str (json->string ls))
-	     (res (string->line-segment str)))
+  (let* ((ls (line-segment (point 1 2) (point 3 4)))
+	 (str (json->string ls))
+	 (res (string->line-segment str)))
     (and (line-segment? res)
 	 (point? (line-segment->start res)))))
 
diff --git a/test/sagittarius.scm b/test/sagittarius.scm
new file mode 100644
index 0000000..47aa1a2
--- /dev/null
+++ b/test/sagittarius.scm
@@ -0,0 +1,10 @@
+(import (scheme base)
+	(scheme case-lambda)
+	(srfi 64))
+
+(import (zambyte meta json))
+
+(test-begin "sagittarius")
+(include "run.scm")
+(test-end "sagittarius")
+