123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869 |
- ;; this is based on the json reader code from guile-mastodon
- (define-module (tapris json-mapping)
- #:use-module (json)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-69)
- #:export (define-json-mapping))
- ;; TODO: maybe not go through a hashtable?
- (define-syntax-rule (define-json-reader json->record ctor spec ...)
- "Define JSON->RECORD as a procedure that converts a JSON representation,
- read from a port, string, or hash table, into a record created by CTOR and
- following SPEC, a series of field specifications."
- (define (json->record input)
- (let ((table (cond ((port? input)
- (alist->hash-table (json->scm input)))
- ((string? input)
- (alist->hash-table (json-string->scm input)))
- ((hash-table? input)
- input)
- (else (alist->hash-table input)))))
- (if (not (hash-table? table))
- (throw 'pleroma `(("errror" . "couldn't convert to a hash table")
- ("input" . ,`input))))
- (let-syntax ((extract-field (syntax-rules ()
- ((_ table (field key json->value value->json))
- (json->value (hash-table-ref/default table key #f)))
- ((_ table (field key json->value))
- (json->value (hash-table-ref/default table key #f)))
- ((_ table (field key))
- (hash-table-ref/default table key #f))
- ((_ table (field))
- (hash-table-ref/default table
- (symbol->string 'field)
- #f)))))
- (ctor (extract-field table spec) ...)))))
- (define-syntax-rule (define-json-writer record->json spec ...)
- "Define RECORD->JSON as a procedure that converts a record to a JSON
- representation."
- (define* (record->json input #:optional #:key (pretty #f))
- (let-syntax ((extract-field (syntax-rules ()
- ((_ rec (field getter))
- `(,(symbol->string 'field) . ,(getter rec)))
- ((_ rec (field getter key))
- `(key . ,(getter rec)))
- ((_ rec (field getter key json->value))
- `(key . ,(getter rec)))
- ((_ rec (field getter key json->value value->json))
- `(key . ,(value->json (getter rec)))))))
- (scm->json-string
- (list (extract-field input spec) ...)
- #:pretty pretty))))
- (define-syntax-rule (define-json-mapping rtd ctor pred json->record record->json
- (field getter spec ...) ...)
- "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
- and define JSON->RECORD (RECORD->JSON) as a conversion from (to) JSON
- to (from) a record of this type."
- (begin
- (define-record-type rtd
- (ctor field ...)
- pred
- (field getter) ...)
-
- (define-json-reader json->record ctor
- (field spec ...) ...)
- (define-json-writer record->json (field getter spec ...) ...)))
|