diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/zambyte/meta/sagittarius.scm | 85 |
1 files changed, 69 insertions, 16 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) |