From 3600a2c69e6f03e2db23900f7bc7caf088460836 Mon Sep 17 00:00:00 2001
From: Robby Zambito <contact@robbyzambito.me>
Date: Fri, 17 Feb 2023 00:27:42 -0500
Subject: 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.
---
 lib/zambyte/meta/json.sld | 43 +++++++++++++++++++++++++++++++++++--------
 1 file changed, 35 insertions(+), 8 deletions(-)

(limited to 'lib/zambyte/meta/json.sld')

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)
-- 
cgit