diff options
| -rw-r--r-- | lib/zambyte/meta/gerbil.scm | 66 |
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)) |