json.scm 4.14 KB
Newer Older
Ludovic Courtès's avatar
Ludovic Courtès committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
;;; Guix-kernel -- Guix kernel for Jupyter
;;; Copyright (C) 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This program 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.
;;;
;;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (jupyter json)
  #:use-module (json)
  #:use-module (srfi srfi-9)
  #:export (define-json-mapping))

;;; Commentary:
;;;
;;; Helpers to map JSON objects to SRFI-9 records.  Taken from (guix swh).
;;;
;;; Code:

(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)
                        (json->scm input))
                       ((string? input)
                        (json-string->scm input))
                       ((or (null? input) (pair? input))
                        input))))
      (let-syntax ((extract-field (syntax-rules ()
                                    ((_ table (field key json->value))
                                     (json->value (assoc-ref table key)))
                                    ((_ table (field key))
                                     (assoc-ref table key))
                                    ((_ table (field))
                                     (assoc-ref table
                                                (symbol->string 'field))))))
        (ctor (extract-field table spec) ...)))))

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
(define-syntax-rule (define-json-writer record->json
                      (field-spec ...) ...)
  "Define RECORD->JSON as a procedure that returns an alist, the Guile-JSON
representation of the given record."
  (define (record->json record)
    (let-syntax ((field->alist (syntax-rules ()
                                 ((_ field getter)
                                  (cons (symbol->string 'field)
                                        (getter record)))
                                 ((_ field getter key _ value->json)
                                  (cons key
                                        (value->json (getter record))))
                                 ((_ field getter key _ (... ...))
                                  (cons key
                                        (getter record))))))
      (list (field->alist field-spec ...) ...))))
Ludovic Courtès's avatar
Ludovic Courtès committed
65

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
(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 to a record of this type.
Optionally, define RECORD->JSON as the conversion from a record of this type
to its JSON representation (an alist)."
    ((_ rtd ctor pred json->record <=> record->json
        (field getter spec ...) ...)
     (begin
       (define-json-mapping rtd ctor pred json->record
         (field getter spec ...) ...)

       (define-json-writer record->json
         (field getter spec ...) ...)))
    ((_ 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 ...) ...)))))
90
91
92
93
94
95
96
97
98
99

(set! (@@ (json builder) json-build)
  ;; Work around a bug in Guile-JSON 3.1.0:
  ;; <https://github.com/aconchillo/guile-json/issues/47>.
  (let ((real-json-build (@@ (json builder) json-build)))

    (lambda (scm port . rest)
      (if (eq? scm '())                           ;match '() but not #nil
          (display "{}" port)
          (apply real-json-build scm port rest)))))