diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/zambyte/meta/json.sld | 2 | ||||
| -rw-r--r-- | lib/zambyte/meta/macduffie.scm | 67 |
2 files changed, 60 insertions, 9 deletions
diff --git a/lib/zambyte/meta/json.sld b/lib/zambyte/meta/json.sld index a385f66..bedbc4a 100644 --- a/lib/zambyte/meta/json.sld +++ b/lib/zambyte/meta/json.sld @@ -138,7 +138,7 @@ (define json-key-not-found (make-parameter (lambda () (values))))) ;; non-portable (cond-expand - ((and (library (macduffie json)) (srfi 69)) + ((and (library (macduffie json)) (library (srfi 69))) (include-library-declarations "macduffie.scm")) ((and guile (library (json))) (import (only (guile) include-from-path import)) diff --git a/lib/zambyte/meta/macduffie.scm b/lib/zambyte/meta/macduffie.scm index 288192b..7e4a79b 100644 --- a/lib/zambyte/meta/macduffie.scm +++ b/lib/zambyte/meta/macduffie.scm @@ -1,5 +1,8 @@ (import (rename (macduffie json) (json-null md:json-null)) + (scheme case-lambda) + (srfi 1) + (srfi 2) (srfi 69)) (begin (define (json-object . pairs) @@ -7,19 +10,67 @@ (define json-list list) (define json-null (md:json-null)) - (define json-object? hash-table?) + + (define (json-object? obj) + (or (hash-table? obj) + (json-record? obj))) + (define json-list? list?) ;; json-null? already defined in macduffie json - (define json-object-contains-key? hash-table-exists?) + + (define (json-object-contains-key? obj key) + (or (and (hash-table? obj) + (hash-table-exists? obj key)) + (and (json-record? obj) + (json-object-contains-key? (json-record->fields obj) key)))) + (define string->json json-read-string) - (define json->string json-write-string) - (define (json-object-ref json key) - (if (hash-table-exists? json key) - (hash-table-ref json key) - ((json-key-not-found)))) + (define (json->string j) + (json-write-string (json->typeless-json j))) + + (define (json-object-ref j key) + (cond + ((hash-table? j) + (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)) + (else ((json-key-not-found))))) + + (define (json-object-set! obj key value) + (cond + ((hash-table? obj) + (hash-table-set! obj key value) + obj) + ((json-record? obj) + (or (and-let* ((pair (assoc key (json-record->mutators obj))) + (mutator (cdr pair))) + (mutator obj value) + obj) + (error "json-object-set!: no mutator for field" (json-record->name obj) key))))) (define json-list-ref list-ref) (define json-list-length length) - (define json-object->alist hash-table->alist) + + (define (json-object-map proc obj) + (let ((res (json-object))) + (hash-table-walk + obj + (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")))))) + 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)) |