summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/zambyte/meta/180.scm17
-rw-r--r--lib/zambyte/meta/chibi.scm14
-rw-r--r--lib/zambyte/meta/gauche.scm11
-rw-r--r--lib/zambyte/meta/gerbil.scm20
-rw-r--r--lib/zambyte/meta/guile-json.scm13
-rw-r--r--lib/zambyte/meta/json.sld116
-rw-r--r--lib/zambyte/meta/macduffie.scm14
-rw-r--r--test/run.scm13
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)))
generated by cgit (git 2.34.1) at 2025-05-20 20:17:17 +0000