tapris/tapris/json-mapping.scm

;; 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 ...) ...)))