guix/json.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix json)
  20   #:use-module (json)
  21   #:use-module (srfi srfi-9))
  22
  23 ;;; Commentary:
  24 ;;;
  25 ;;; Helpers to map JSON objects to SRFI-9 records.  Taken from (guix swh).
  26 ;;; This module is superseded by 'define-json-mapping' as found since version
  27 ;;; 4.2.0 of Guile-JSON and will be removed once migration is complete.
  28 ;;;
  29 ;;; Code:
  30
  31 (define-syntax define-as-needed
  32   (lambda (s)
  33     "Define the given syntax rule unless (json) already provides it."
  34     (syntax-case s ()
  35       ((_ (macro args ...) body ...)
  36        (if (module-defined? (resolve-interface '(json))
  37                             (syntax->datum #'macro))
  38            #'(eval-when (expand load eval)
  39                ;; Re-export MACRO from (json).
  40                (module-re-export! (current-module) '(macro)))
  41            #'(begin
  42                ;; Using Guile-JSON < 4.2.0, so provide our own MACRO.
  43                (define-syntax-rule (macro args ...)
  44                  body ...)
  45                (eval-when (expand load eval)
  46                  (module-export! (current-module) '(macro)))))))))
  47
  48 (define-syntax-rule (define-json-reader json->record ctor spec ...)
  49   "Define JSON->RECORD as a procedure that converts a JSON representation,
  50 read from a port, string, or hash table, into a record created by CTOR and
  51 following SPEC, a series of field specifications."
  52   (define (json->record input)
  53     (let ((table (cond ((port? input)
  54                         (json->scm input))
  55                        ((string? input)
  56                         (json-string->scm input))
  57                        ((or (null? input) (pair? input))
  58                         input))))
  59       (let-syntax ((extract-field (syntax-rules ()
  60                                     ((_ table (field key json->value))
  61                                      (json->value (assoc-ref table key)))
  62                                     ((_ table (field key))
  63                                      (assoc-ref table key))
  64                                     ((_ table (field))
  65                                      (assoc-ref table
  66                                                 (symbol->string 'field))))))
  67         (ctor (extract-field table spec) ...)))))
  68
  69 ;; For some reason we cannot just have colliding definitions of
  70 ;; 'define-json-mapping' (that leads to a build failure in users of this
  71 ;; module), hence the use of 'define-as-needed'.
  72 (define-as-needed (define-json-mapping rtd ctor pred json->record
  73                     (field getter spec ...) ...)
  74   "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
  75 and define JSON->RECORD as a conversion from JSON to a record of this type."
  76   (begin
  77     (define-record-type rtd
  78       (ctor field ...)
  79       pred
  80       (field getter) ...)
  81
  82     (define-json-reader json->record ctor
  83       (field spec ...) ...)))