mirror of
https://github.com/ebeem/guile-swayer.git
synced 2024-12-27 21:59:13 +01:00
231 lines
11 KiB
Scheme
231 lines
11 KiB
Scheme
|
;;; (json record) --- Guile JSON implementation.
|
||
|
|
|
||
|
|
;; Copyright (C) 2020-2021 Aleix Conchillo Flaque <aconchillo@gmail.com>
|
||
|
|
;; Copyright (C) 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||
|
|
;;
|
||
|
|
;; This file is part of guile-json.
|
||
|
|
;;
|
||
|
|
;; guile-json is free software: you can redistribute it and/or modify
|
||
|
|
;; it under the terms of the GNU General Public License as published by
|
||
|
|
;; the Free Software Foundation; either version 3 of the License, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; guile-json is distributed in the hope that it will be useful, but
|
||
|
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
|
|
;; General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with guile-json. If not, see https://www.gnu.org/licenses/.
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;; JSON module for Guile
|
||
|
|
|
||
|
|
;; The initial code of this file was copied from GNU Guix:
|
||
|
|
;; http://git.savannah.gnu.org/cgit/guix.git/tree/guix/json.scm
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(define-module (sjson record)
|
||
|
|
#:use-module (sjson builder)
|
||
|
|
#:use-module (sjson parser)
|
||
|
|
#:use-module (srfi srfi-9)
|
||
|
|
#:export (<=> define-json-mapping define-json-type))
|
||
|
|
|
||
|
|
(define <=> '<=>)
|
||
|
|
|
||
|
|
(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 alist, into a record created by CTOR and following
|
||
|
|
SPEC, a series of field specifications."
|
||
|
|
(define (json->record input)
|
||
|
|
(let ((table (cond ((port? input)
|
||
|
|
(json->scm input))
|
||
|
|
((string? input)
|
||
|
|
(json-string->scm input))
|
||
|
|
;; This allows to pass native values.
|
||
|
|
((or (null? input) (pair? input))
|
||
|
|
input))))
|
||
|
|
(let-syntax ((extract-field (syntax-rules ()
|
||
|
|
((_ table (field key scm->value value->scm))
|
||
|
|
(scm->value (if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
|
||
|
|
(cdr (assoc key table)) *unspecified*)))
|
||
|
|
((_ table (field key scm->value))
|
||
|
|
(scm->value (if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
|
||
|
|
(cdr (assoc key table)) *unspecified*)))
|
||
|
|
((_ table (field key))
|
||
|
|
(if (and (pair? (assoc key table)) (not (equal? 'null (cdr (assoc key table)))))
|
||
|
|
(cdr (assoc key table)) *unspecified*))
|
||
|
|
((_ table (field))
|
||
|
|
(if (pair? (assoc (symbol->string 'field) table)) (cdr (assoc (symbol->string 'field) table)) *unspecified*)))))
|
||
|
|
(ctor (extract-field table spec) ...)))))
|
||
|
|
|
||
|
|
(define-syntax-rule (define-json-writer record->json spec ...)
|
||
|
|
"Define RECORD->JSON as a procedure that converts a RECORD into its JSON
|
||
|
|
representation following SPEC, a series of field specifications."
|
||
|
|
(define (record->json record)
|
||
|
|
(let-syntax ((extract-field (syntax-rules ()
|
||
|
|
((_ (field getter key scm->value value->scm))
|
||
|
|
(cons key (if (unspecified? (getter record)) *unspecified* (value->scm (getter record)))))
|
||
|
|
((_ (field getter key scm->value))
|
||
|
|
(cons key (getter record)))
|
||
|
|
((_ (field getter key))
|
||
|
|
(cons key (getter record)))
|
||
|
|
((_ (field getter))
|
||
|
|
(cons (symbol->string 'field) (getter record))))))
|
||
|
|
(let* ((full-object `(,(extract-field spec) ...))
|
||
|
|
(object (filter (lambda (p) (not (unspecified? (cdr p))))
|
||
|
|
full-object)))
|
||
|
|
(scm->json-string object)))))
|
||
|
|
|
||
|
|
(define-syntax-rule (define-native-reader scm->record ctor spec ...)
|
||
|
|
"Define SCM->RECORD as a procedure that converts an alist into a record
|
||
|
|
created by CTOR and following SPEC, a series of field specifications."
|
||
|
|
(define (scm->record table)
|
||
|
|
(let-syntax ((extract-field (syntax-rules ()
|
||
|
|
((_ table (field key scm->value value->scm))
|
||
|
|
(scm->value (if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*)))
|
||
|
|
((_ table (field key scm->value))
|
||
|
|
(scm->value (if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*)))
|
||
|
|
((_ table (field key))
|
||
|
|
(if (pair? (assoc key table)) (cdr (assoc key table)) *unspecified*))
|
||
|
|
((_ table (field))
|
||
|
|
(if (pair? (assoc (symbol->string 'field) table)) (cdr (assoc (symbol->string 'field) table)) *unspecified*)))))
|
||
|
|
(ctor (extract-field table spec) ...))))
|
||
|
|
|
||
|
|
(define-syntax-rule (define-native-writer record->scm spec ...)
|
||
|
|
"Define RECORD->SCM as a procedure that converts a RECORD into it an alist
|
||
|
|
representation following SPEC, a series of field specifications."
|
||
|
|
(define (record->scm record)
|
||
|
|
(let-syntax ((extract-field (syntax-rules ()
|
||
|
|
((_ (field getter key scm->value value->scm))
|
||
|
|
(cons key (if (unspecified? (getter record)) *unspecified* (value->scm (getter record)))))
|
||
|
|
((_ (field getter key scm->value))
|
||
|
|
(cons key (getter record)))
|
||
|
|
((_ (field getter key))
|
||
|
|
(cons key (getter record)))
|
||
|
|
((_ (field getter))
|
||
|
|
(cons (symbol->string 'field) (getter record))))))
|
||
|
|
(let ((full-object `(,(extract-field spec) ...)))
|
||
|
|
(filter (lambda (p) (not (unspecified? (cdr p)))) full-object)))))
|
||
|
|
|
||
|
|
(define-syntax define-json-mapping
|
||
|
|
(syntax-rules (<=>)
|
||
|
|
"Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
|
||
|
|
and define JSON->RECORD as a conversion from JSON (from a port, string or alist)
|
||
|
|
to a record of this type. Optionally, define RECORD->JSON as a conversion from a
|
||
|
|
record of this type to a JSON string. Additionally, define SCM->RECORD as a
|
||
|
|
conversion from an alist to a record of this type (equivalent to JSON->RECORD
|
||
|
|
when passing an alist) and RECORD->SCM as a conversion from a record of this
|
||
|
|
type to an alist."
|
||
|
|
((_ rtd ctor pred json->record (field getter spec ...) ...)
|
||
|
|
(begin
|
||
|
|
(define-record-type rtd
|
||
|
|
(ctor field ...)
|
||
|
|
pred
|
||
|
|
(field getter) ...)
|
||
|
|
|
||
|
|
(define-json-reader json->record ctor
|
||
|
|
(field spec ...) ...)))
|
||
|
|
((_ rtd ctor pred json->record <=> record->json (field getter spec ...) ...)
|
||
|
|
(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 ...) ...)))
|
||
|
|
((_ rtd ctor pred json->record <=> record->json <=> scm->record <=> record->scm (field getter spec ...) ...)
|
||
|
|
(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 ...) ...)
|
||
|
|
|
||
|
|
(define-native-reader scm->record ctor
|
||
|
|
(field spec ...) ...)
|
||
|
|
|
||
|
|
(define-native-writer record->scm
|
||
|
|
(field getter spec ...) ...)))))
|
||
|
|
|
||
|
|
(define-syntax define-json-type
|
||
|
|
(lambda (x)
|
||
|
|
"Define RTD as a record type with the given FIELDs. This will automatically
|
||
|
|
define a record and its constructor, predicate and fields with their getters as
|
||
|
|
they would be defined by define-json-mapping."
|
||
|
|
(define (gen-id template-id . args)
|
||
|
|
(datum->syntax
|
||
|
|
template-id
|
||
|
|
(string->symbol
|
||
|
|
(apply string-append
|
||
|
|
(map (lambda (x)
|
||
|
|
(if (string? x) x (symbol->string (syntax->datum x))))
|
||
|
|
args)))))
|
||
|
|
(define (cleanup-single-rtd template-id)
|
||
|
|
(datum->syntax
|
||
|
|
template-id
|
||
|
|
(string->symbol
|
||
|
|
(string-delete
|
||
|
|
(lambda (c) (or (eq? c #\<) (eq? c #\>)))
|
||
|
|
(symbol->string (syntax->datum template-id))))))
|
||
|
|
(define (cleanup-vector-rtd template-id)
|
||
|
|
(cleanup-single-rtd (datum->syntax template-id (vector-ref (syntax->datum template-id) 0))))
|
||
|
|
|
||
|
|
(define (cleanup-rtd template-id)
|
||
|
|
(if (vector? (syntax->datum template-id))
|
||
|
|
(cleanup-vector-rtd template-id)
|
||
|
|
(cleanup-single-rtd template-id)))
|
||
|
|
(syntax-case x (<=>)
|
||
|
|
((_ rtd field ...)
|
||
|
|
(with-syntax ((mapping-rtd #'rtd)
|
||
|
|
(constructor (gen-id #'rtd "make-" (cleanup-rtd #'rtd)))
|
||
|
|
(predicate (gen-id #'rtd (cleanup-rtd #'rtd) "?"))
|
||
|
|
(json->record (gen-id #'rtd "json->" (cleanup-rtd #'rtd)))
|
||
|
|
(record->json (gen-id #'rtd (cleanup-rtd #'rtd) "->json"))
|
||
|
|
(scm->record (gen-id #'rtd "scm->" (cleanup-rtd #'rtd)))
|
||
|
|
(record->scm (gen-id #'rtd (cleanup-rtd #'rtd) "->scm"))
|
||
|
|
((fields ...)
|
||
|
|
(map
|
||
|
|
(lambda (f)
|
||
|
|
(syntax-case f ()
|
||
|
|
((name)
|
||
|
|
#`(name #,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name)))
|
||
|
|
((name key)
|
||
|
|
#`(name #,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name) key))
|
||
|
|
((name key field-rtd)
|
||
|
|
#`(name
|
||
|
|
#,(gen-id #'rtd (cleanup-rtd #'rtd) "-" #'name)
|
||
|
|
key
|
||
|
|
#,(if (vector? (syntax->datum #'field-rtd))
|
||
|
|
#`(lambda (v) (if (unspecified? v)
|
||
|
|
*unspecified*
|
||
|
|
(map #,(gen-id #'field-rtd "scm->" (cleanup-rtd #'field-rtd))
|
||
|
|
(vector->list v))))
|
||
|
|
#`(lambda (v) (if (unspecified? v)
|
||
|
|
*unspecified*
|
||
|
|
(#,(gen-id #'field-rtd "scm->" (cleanup-rtd #'field-rtd)) v))))
|
||
|
|
#,(if (vector? (syntax->datum #'field-rtd))
|
||
|
|
#`(lambda (v)
|
||
|
|
(list->vector
|
||
|
|
(map #,(gen-id #'field-rtd (cleanup-rtd #'field-rtd) "->scm") v)))
|
||
|
|
(gen-id #'field-rtd (cleanup-rtd #'field-rtd) "->scm" ))))))
|
||
|
|
#'(field ...))))
|
||
|
|
#'(define-json-mapping mapping-rtd
|
||
|
|
constructor
|
||
|
|
predicate
|
||
|
|
json->record <=> record->json <=> scm->record <=> record->scm
|
||
|
|
fields ...))))))
|
||
|
|
|
||
|
|
;;; (json record) ends here
|