From 52d5f0ba2db43d812c4f13e4c2de4a1702b0ab64 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Sun, 4 Mar 2018 19:10:58 +0800 Subject: [PATCH] guile-json - initial commit --- borrowed/CMakeLists.txt | 3 +- borrowed/guile-json/AUTHORS | 9 + borrowed/guile-json/CMakeLists.txt | 9 + borrowed/guile-json/COPYING.LESSER | 165 +++++++++++++ borrowed/guile-json/NEWS | 62 +++++ borrowed/guile-json/README | 158 ++++++++++++ borrowed/guile-json/json.scm | 45 ++++ borrowed/guile-json/json/builder.scm | 204 ++++++++++++++++ borrowed/guile-json/json/parser.scm | 351 +++++++++++++++++++++++++++ borrowed/guile-json/json/syntax.scm | 76 ++++++ 10 files changed, 1081 insertions(+), 1 deletion(-) create mode 100644 borrowed/guile-json/AUTHORS create mode 100644 borrowed/guile-json/CMakeLists.txt create mode 100644 borrowed/guile-json/COPYING.LESSER create mode 100644 borrowed/guile-json/NEWS create mode 100644 borrowed/guile-json/README create mode 100644 borrowed/guile-json/json.scm create mode 100644 borrowed/guile-json/json/builder.scm create mode 100644 borrowed/guile-json/json/parser.scm create mode 100644 borrowed/guile-json/json/syntax.scm diff --git a/borrowed/CMakeLists.txt b/borrowed/CMakeLists.txt index c88aa6165d..f9d588e747 100644 --- a/borrowed/CMakeLists.txt +++ b/borrowed/CMakeLists.txt @@ -1,6 +1,7 @@ ADD_SUBDIRECTORY(libc) ADD_SUBDIRECTORY(goffice) +ADD_SUBDIRECTORY(guile-json) ADD_SUBDIRECTORY(gwengui-gtk3) SET_LOCAL_DIST(borrowed_DIST_local CMakeLists.txt README) -SET(borrowed_DIST ${borrowed_DIST_local} ${libc_DIST} ${goffice_DIST} ${gwengui_gtk3_DIST} PARENT_SCOPE) +SET(borrowed_DIST ${borrowed_DIST_local} ${libc_DIST} ${guile-json_DIST} ${goffice_DIST} ${gwengui_gtk3_DIST} PARENT_SCOPE) diff --git a/borrowed/guile-json/AUTHORS b/borrowed/guile-json/AUTHORS new file mode 100644 index 0000000000..3343d4c788 --- /dev/null +++ b/borrowed/guile-json/AUTHORS @@ -0,0 +1,9 @@ +Aleix Conchillo Flaque is the author and current +maintainer of guile-json. More details at . + +List of contributors (in alphabetical order): + +Jan Nieuwenhuizen +Ian Price +David Thompson +Doug Woos diff --git a/borrowed/guile-json/CMakeLists.txt b/borrowed/guile-json/CMakeLists.txt new file mode 100644 index 0000000000..aeb9703b62 --- /dev/null +++ b/borrowed/guile-json/CMakeLists.txt @@ -0,0 +1,9 @@ + +GNC_ADD_SCHEME_TARGETS(guile-json + json.scm + json/builder.scm + json/parser.scm + json/syntax.scm +) + +SET_DIST_LIST(guile-json_DIST CMakeLists.txt ${guile-json_DATA}) diff --git a/borrowed/guile-json/COPYING.LESSER b/borrowed/guile-json/COPYING.LESSER new file mode 100644 index 0000000000..65c5ca88a6 --- /dev/null +++ b/borrowed/guile-json/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/borrowed/guile-json/NEWS b/borrowed/guile-json/NEWS new file mode 100644 index 0000000000..d4317c1a77 --- /dev/null +++ b/borrowed/guile-json/NEWS @@ -0,0 +1,62 @@ + +* Version 0.6.0 (Jan 16, 2017) + + - Deprecate json macro in favor of scheme data types. + + +* Version 0.5.0 (Feb 21, 2015) + + - Allow converting simple alists to json + e.g.: (scm->json-string '((a . 1) (b . 2)))) + (thanks to Jan Nieuwenhuizen) + + +* Version 0.4.0 (Aug 17, 2014) + + - Add unquote-splicing support to json form. + (thanks to David Thompson) + + +* Version 0.3.1 (Jul 6, 2013) + + - Use pure sh script syntax in env.in. + (thanks to Andrew Gaylard) + + +* Version 0.3.0 (May 13, 2013) + + - Re-licensed under LGPLv3. + + - Use new guile.m4 macro. + + - Convert rationals to floats to comply with JSON spec. + (closes github #3, patch from Doug Woos) + + +* Version 0.2.0 (Apr 2, 2013) + + - Improve parser errors by providing an additional parser argument to + the json-invalid exception. + + +* Version 0.1.3 (Feb 10, 2013) + + - Automatically update pkg-list.scm version. + + +* Version 0.1.2 (Feb 7, 2013) + + - Fix pretty printing. + + - Use (display) instead of (simple-format) when possible. + + +* Version 0.1.1 (Feb 2, 2013) + + - Use (car)/(cdr) instead of (drop-right)/(last). This should be more + efficient. + + +* Version 0.1.0 (Jan 30, 2013) + + Initial release. diff --git a/borrowed/guile-json/README b/borrowed/guile-json/README new file mode 100644 index 0000000000..920f85ce9f --- /dev/null +++ b/borrowed/guile-json/README @@ -0,0 +1,158 @@ + +* guile-json + +guile-json is a JSON module for Guile. It supports parsing and +building JSON documents according to the http://json.org +specification. These are the main features: + +- Mostly complies with http://json.org specification (see UTF-8 below). + +- Build JSON documents programmatically using scheme data types. + +- Supports UTF-8 (doesn't fully support unicode hexadecimal digits). + +- Allows JSON pretty printing. + + +* Installation + +guile-json is freely available for download under the terms of the GNU +Lesser General Public License version 3 (LGPLv3+). + +Download the latest tarball and untar it: + +- [[http://download.savannah.gnu.org/releases/guile-json/guile-json-0.6.0.tar.gz][guile-json-0.6.0.tar.gz]] + +Then, run the typical sequence: + + : $ ./configure --prefix= + : $ make + : $ sudo make install + +Where should preferably be the same as your system Guile +installation directory (e.g. /usr). + +If everything installed successfully you should be up and running: + + : $ guile + : scheme@(guile-user)> (use-modules (json)) + : scheme@(guile-user)> (scm->json '(1 2 3)) + : [1, 2, 3] + +It might be that you installed guile-json somewhere differently than +your system's Guile. If so, you need to indicate Guile where to find +guile-json, for example: + + : $ GUILE_LOAD_PATH=/usr/local/share/guile/site guile + +A pkg-list.scm file is also provided for users of the +Guildhall/Dorodango packaging system. + + +* Usage + +guile-json provides a few procedures to parse and build a JSON +document. A JSON document is transformed into or from native Guile +values according to the following table: + +| JSON | Guile | +|--------+-------------| +| string | string | +| number | number | +| object | hash-table* | +| array | list | +| true | #t | +| false | #f | +| null | #nil | + +*Note* (*): Association lists are also tranformed to JSON objects, in +this case ordered will be preserved. + +To start using guile-json procedures and macros you first need to load +the module: + + : scheme@(guile-user)> (use-modules (json)) + + +** Procedures + +- (*json->scm* #:optional port) : Reads a JSON document from the given + port, or from the current input port if none is given. + + - /port/ : is optional, it defaults to the current input port. + +- (*json-string->scm* str) : Reads a JSON document from the given + string. + +- (*scm->json* native #:optional port #:key escape pretty) : Creates a + JSON document from the given native Guile value. The JSON document is + written into the given port, or to the current output port if non is + given. + + - /port/ : it defaults to the current output port. + - /escape/ : if true, the slash (/ solidus) character will be escaped. + - /pretty/ : if true, the JSON document will be pretty printed. + +- (*scm->json-string* native #:key escape pretty) : Creates a JSON + document from the given native Guile value into a string. + + - /escape/ : if true, the slash (/ solidus) character will be escaped. + - /pretty/ : if true, the JSON document will be pretty printed. + + +** Exceptions + +A /json-invalid/ exception is thrown if an error is found during the +JSON parsing. Since version 0.2.0, the /json-invalid/ exception has a +single parser argument (see predicate and accessors below). The line or +column where the error occured can be easily obtained from the parser +port (calling /port-line/ or /port-column/ on the port). + +- (*json-parser?* parser) : Tells whether the given argument is a JSON + parser record type. + +- (*json-parser-port* parser) : Get the port that the parser was reading + from. + + +** Examples + +- Build the string "hello world": + + : scheme@(guile-user)> (scm->json "hello world") + : "hello world" + +- Build the [1, 2, 3] array: + + : scheme@(guile-user)> (scm->json '(1 2 3)) + : [1, 2, 3] + +- Build the [1, 2, 3, 4] array using unquote-splicing: + + : scheme@(guile-user)> (define values '(2 3)) + : scheme@(guile-user)> (scm->json `(1 ,@values 4)) + : [1, 2, 3, 4] + +- Build the object { "project" : "foo", "author" : "bar" } using an + association list (see how symbols can also be used): + + : scheme@(guile-user)> (scm->json '(("project" . "foo") (author . bar))) + : {"project" : "foo","author" : "bar"} + +- Build again the same object { "project" : "foo", "author" : "bar" } + using a hash table: + + : scheme@(guile-user)> (scm->json (alist->hash-table '((project . foo) (author . bar)))) + : {"project" : "foo","author" : "bar"} + +- Build the object { "values" : [ 234, 98.56 ] }: + + : scheme@(guile-user)> (scm->json '(("values" 234 98.56))) + : {"values" : [234, 98.56]} + +- Build the object { "values" : [ 234, 98.56 ] } again, this time using + a variable: + + : scheme@(guile-user)> (define values '(234 98.56)) + : scheme@(guile-user)> (scm->json `(("values" ,@values))) + : {"values" : [234, 98.56]} diff --git a/borrowed/guile-json/json.scm b/borrowed/guile-json/json.scm new file mode 100644 index 0000000000..8e45f93400 --- /dev/null +++ b/borrowed/guile-json/json.scm @@ -0,0 +1,45 @@ +;;; (json) --- Guile JSON implementation. + +;; Copyright (C) 2013 Aleix Conchillo Flaque +;; +;; 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 Lesser 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with guile-json; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; JSON module for Guile + +;;; Code: + +(define-module (json) + #:use-module (json builder) + #:use-module (json parser) + #:use-module (json syntax)) + +(define-syntax re-export-modules + (syntax-rules () + ((_ (mod ...) ...) + (begin + (module-use! (module-public-interface (current-module)) + (resolve-interface '(mod ...))) + ...)))) + +(re-export-modules (json builder) + (json parser) + (json syntax)) + +;;; (json) ends here diff --git a/borrowed/guile-json/json/builder.scm b/borrowed/guile-json/json/builder.scm new file mode 100644 index 0000000000..e1339b24e2 --- /dev/null +++ b/borrowed/guile-json/json/builder.scm @@ -0,0 +1,204 @@ +;;; (json builder) --- Guile JSON implementation. + +;; Copyright (C) 2013 Aleix Conchillo Flaque +;; Copyright (C) 2015,2016 Jan Nieuwenhuizen +;; +;; 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 Lesser 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with guile-json; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; JSON module for Guile + +;;; Code: + +(define-module (json builder) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) + #:export (scm->json + scm->json-string)) + +;; +;; String builder helpers +;; + +(define (unicode->string unicode) + (format #f "\\u~4,'0x" unicode)) + +(define (char->unicode-string c) + (let ((unicode (char->integer c))) + (if (< unicode 32) + (unicode->string unicode) + (string c)))) + +(define (u8v-2->unicode bv) + (let ((bv0 (bytevector-u8-ref bv 0)) + (bv1 (bytevector-u8-ref bv 1))) + (+ (ash (logand bv0 #b00011111) 6) + (logand bv1 #b00111111)))) + +(define (u8v-3->unicode bv) + (let ((bv0 (bytevector-u8-ref bv 0)) + (bv1 (bytevector-u8-ref bv 1)) + (bv2 (bytevector-u8-ref bv 2))) + (+ (ash (logand bv0 #b00001111) 12) + (ash (logand bv1 #b00111111) 6) + (logand bv2 #b00111111)))) + +(define (build-char-string c) + (let* ((bv (string->utf8 (string c))) + (len (bytevector-length bv))) + (cond + ;; A single byte UTF-8 + ((eq? len 1) (char->unicode-string c)) + ;; If we have a 2 or 3 byte UTF-8 we need to output it as \uHHHH + ((or (eq? len 2) (eq? len 3)) + (let ((unicode (if (eq? len 2) + (u8v-2->unicode bv) + (u8v-3->unicode bv)))) + (unicode->string unicode))) + ;; Anything else should wrong, hopefully. + (else (throw 'json-invalid))))) + +;; +;; Object builder functions +;; + +(define (build-object-pair p port escape pretty level) + (display (indent-string pretty level) port) + (json-build-string (car p) port escape) + (display " : " port) + (json-build (cdr p) port escape pretty level)) + +(define (build-newline port pretty) + (cond (pretty (newline port)))) + +(define (indent-string pretty level) + (if pretty (format #f "~v_" (* 4 level)) "")) + +;; +;; Main builder functions +;; + +(define (json-build-null port) + (display "null" port)) + +(define (json-build-boolean scm port) + (display (if scm "true" "false") port)) + +(define (json-build-number scm port) + (if (and (rational? scm) (not (integer? scm))) + (display (number->string (exact->inexact scm)) port) + (display (number->string scm) port))) + +(define (->string x) + (cond ((char? x) (make-string 1 x)) + ((number? x) (number->string x)) + ((symbol? x) (symbol->string x)) + (else x))) + +(define (atom? x) + (or (char? x) (number? x) (string? x) (symbol? x))) + +(define (json-alist? x) + (and (pair? x) + (let loop ((x x)) + (or (null? x) + (null? (car x)) + (and (pair? (car x)) (atom? (caar x)) + (loop (cdr x))))))) + +(define (json-build-string scm port escape) + (display "\"" port) + (display + (list->string + (fold-right append '() + (map + (lambda (c) + (case c + ((#\" #\\) `(#\\ ,c)) + ((#\bs) '(#\\ #\b)) + ((#\ff) '(#\\ #\f)) + ((#\lf) '(#\\ #\n)) + ((#\cr) '(#\\ #\r)) + ((#\ht) '(#\\ #\t)) + ((#\/) (if escape `(#\\ ,c) (list c))) + (else (string->list (build-char-string c))))) + (string->list (->string scm))))) + port) + (display "\"" port)) + +(define (json-build-array scm port escape pretty level) + (display "[" port) + (unless (null? scm) + (json-build (car scm) port escape pretty (+ level 1)) + (for-each (lambda (v) + (display ", " port) + (json-build v port escape pretty (+ level 1))) + (cdr scm))) + (display "]" port)) + +(define (json-build-object scm port escape pretty level) + (build-newline port pretty) + (simple-format port "~A{" (indent-string pretty level)) + (build-newline port pretty) + (let ((pairs scm)) + (unless (null? pairs) + (build-object-pair (car pairs) port escape pretty (+ level 1)) + (for-each (lambda (p) + (display "," port) + (build-newline port pretty) + (build-object-pair p port escape pretty (+ level 1))) + (cdr pairs)))) + (build-newline port pretty) + (simple-format port "~A}" (indent-string pretty level))) + +(define (json-build scm port escape pretty level) + (cond + ((eq? scm #nil) (json-build-null port)) + ((boolean? scm) (json-build-boolean scm port)) + ((number? scm) (json-build-number scm port)) + ((symbol? scm) (json-build-string (symbol->string scm) port escape)) + ((string? scm) (json-build-string scm port escape)) + ((json-alist? scm) (json-build-object scm port escape pretty level)) + ((list? scm) (json-build-array scm port escape pretty level)) + ((hash-table? scm) + (json-build-object (hash-map->list cons scm) port escape pretty level)) + (else (throw 'json-invalid)))) + +;; +;; Public procedures +;; + +(define* (scm->json scm + #:optional (port (current-output-port)) + #:key (escape #f) (pretty #f)) + "Creates a JSON document from native. The argument @var{scm} contains +the native value of the JSON document. Takes one optional argument, +@var{port}, which defaults to the current output port where the JSON +document will be written." + (json-build scm port escape pretty 0)) + +(define* (scm->json-string scm #:key (escape #f) (pretty #f)) + "Creates a JSON document from native into a string. The argument +@var{scm} contains the native value of the JSON document." + (call-with-output-string + (lambda (p) + (scm->json scm p #:escape escape #:pretty pretty)))) + +;;; (json builder) ends here diff --git a/borrowed/guile-json/json/parser.scm b/borrowed/guile-json/json/parser.scm new file mode 100644 index 0000000000..e285803c9d --- /dev/null +++ b/borrowed/guile-json/json/parser.scm @@ -0,0 +1,351 @@ +;;; (json parser) --- Guile JSON implementation. + +;; Copyright (C) 2013 Aleix Conchillo Flaque +;; +;; 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 Lesser 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with guile-json; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; JSON module for Guile + +;;; Code: + +(define-module (json parser) + #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:export (json->scm + json-string->scm + json-parser? + json-parser-port)) + +;; +;; Parser record and read helpers +;; + +(define-record-type json-parser + (make-json-parser port) + json-parser? + (port json-parser-port)) + +(define (parser-peek-char parser) + (peek-char (json-parser-port parser))) + +(define (parser-read-char parser) + (read-char (json-parser-port parser))) + +(define (parser-read-delimited parser delim handle-delim) + (let ((port (json-parser-port parser))) + (read-delimited delim port handle-delim))) + +;; +;; Number parsing helpers +;; + +;; Read + or -. . If something different is found, return empty string. +(define (read-sign parser) + (let loop ((c (parser-peek-char parser)) (s "")) + (case c + ((#\+ #\-) + (let ((ch (parser-read-char parser))) + (string-append s (string ch)))) + (else s)))) + +;; Read digits [0..9]. If something different is found, return empty +;; string. +(define (read-digits parser) + (let loop ((c (parser-peek-char parser)) (s "")) + (case c + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((ch (parser-read-char parser))) + (loop (parser-peek-char parser) + (string-append s (string ch))))) + (else s)))) + +(define (read-exp-part parser) + (let ((c (parser-peek-char parser)) (s "")) + (case c + ;; Stop parsing if whitespace found. + ((#\ht #\vt #\lf #\cr #\sp) s) + ;; We might be in an array or object, so stop here too. + ((#\, #\] #\}) s) + ;; We might have the exponential part + ((#\e #\E) + (let ((ch (parser-read-char parser)) ; current char + (sign (read-sign parser)) + (digits (read-digits parser))) + ;; If we don't have sign or digits, we have an invalid + ;; number. + (if (not (and (string-null? sign) + (string-null? digits))) + (string-append s (string ch) sign digits) + #f))) + ;; If we have a character different than e or E, we have an + ;; invalid number. + (else #f)))) + +(define (read-real-part parser) + (let ((c (parser-peek-char parser)) (s "")) + (case c + ;; Stop parsing if whitespace found. + ((#\ht #\vt #\lf #\cr #\sp) s) + ;; We might be in an array or object, so stop here too. + ((#\, #\] #\}) s) + ;; If we read . we might have a real number + ((#\.) + (let ((ch (parser-read-char parser)) + (digits (read-digits parser))) + ;; If we have digits, try to read the exponential part, + ;; otherwise we have an invalid number. + (cond + ((not (string-null? digits)) + (let ((exp (read-exp-part parser))) + (cond + (exp (string-append s (string ch) digits exp)) + (else #f)))) + (else #f)))) + ;; If we have a character different than . we might continue + ;; processing. + (else #f)))) + +(define (read-number parser) + (let loop ((c (parser-peek-char parser)) (s "")) + (case c + ;; Stop parsing if whitespace found. + ((#\ht #\vt #\lf #\cr #\sp) s) + ;; We might be in an array or object, so stop here too. + ((#\, #\] #\}) s) + ((#\-) + (let ((ch (parser-read-char parser))) + (loop (parser-peek-char parser) + (string-append s (string ch))))) + ((#\0) + (let ((ch (parser-read-char parser))) + (string-append s + (string ch) + (or (read-real-part parser) + (throw 'json-invalid parser))))) + ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((ch (parser-read-char parser))) + (string-append s + (string ch) + (read-digits parser) + (or (read-real-part parser) + (read-exp-part parser) + (throw 'json-invalid parser))))) + (else (throw 'json-invalid parser))))) + +;; +;; Object parsing helpers +;; + +(define (read-pair parser) + ;; Read string key + (let ((key (json-read-string parser))) + (let loop ((c (parser-peek-char parser))) + (case c + ;; Skip whitespaces + ((#\ht #\vt #\lf #\cr #\sp) + (parser-read-char parser) + (loop (parser-peek-char parser))) + ;; Skip colon and read value + ((#\:) + (parser-read-char parser) + (cons key (json-read parser))) + ;; invalid object + (else (throw 'json-invalid parser)))))) + +(define (read-object parser) + (let loop ((c (parser-peek-char parser)) + (pairs (make-hash-table))) + (case c + ;; Skip whitespaces + ((#\ht #\vt #\lf #\cr #\sp) + (parser-read-char parser) + (loop (parser-peek-char parser) pairs)) + ;; end of object + ((#\}) + (parser-read-char parser) + pairs) + ;; Read one pair and continue + ((#\") + (let ((pair (read-pair parser))) + (hash-set! pairs (car pair) (cdr pair)) + (loop (parser-peek-char parser) pairs))) + ;; Skip comma and read more pairs + ((#\,) + (parser-read-char parser) + (loop (parser-peek-char parser) pairs)) + ;; invalid object + (else (throw 'json-invalid parser))))) + +;; +;; Array parsing helpers +;; + +(define (read-array parser) + (let loop ((c (parser-peek-char parser)) (values '())) + (case c + ;; Skip whitespace and comma + ((#\ht #\vt #\lf #\cr #\sp #\,) + (parser-read-char parser) + (loop (parser-peek-char parser) values)) + ;; end of array + ((#\]) + (parser-read-char parser) + values) + ;; this can be any json object + (else + (let ((value (json-read parser))) + (loop (parser-peek-char parser) + (append values (list value)))))))) + +;; +;; String parsing helpers +;; + +(define (expect parser expected) + (let ((ch (parser-read-char parser))) + (if (not (char=? ch expected)) + (throw 'json-invalid parser) + ch))) + +(define (expect-string parser expected) + (list->string + (map (lambda (ch) (expect parser ch)) + (string->list expected)))) + +(define (read-hex-digit parser) + (let ((c (parser-read-char parser))) + (case c + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f) c) + (else (throw 'json-invalid parser))))) + +(define (read-control-char parser) + (let ((c (parser-read-char parser))) + (case c + ((#\" #\\ #\/) (string c)) + ((#\b) (string #\bs)) + ((#\f) (string #\ff)) + ((#\n) (string #\lf)) + ((#\r) (string #\cr)) + ((#\t) (string #\ht)) + ((#\u) + (let* ((utf1 (string (read-hex-digit parser) + (read-hex-digit parser))) + (utf2 (string (read-hex-digit parser) + (read-hex-digit parser))) + (vu8 (list (string->number utf1 16) + (string->number utf2 16))) + (utf (u8-list->bytevector vu8))) + (utf16->string utf))) + (else #f)))) + +(define (read-string parser) + ;; Read characters until \ or " are found. + (let loop ((result "") + (current (parser-read-delimited parser "\\\"" 'split))) + (case (cdr current) + ((#\") + (string-append result (car current))) + ((#\\) + (let ((ch (read-control-char parser))) + (if ch + (loop (string-append result (car current) ch) + (parser-read-delimited parser "\\\"" 'split)) + (throw 'json-invalid parser )))) + (else + (throw 'json-invalid parser))))) + +;; +;; Main parser functions +;; + +(define-syntax json-read-delimited + (syntax-rules () + ((json-read-delimited parser delim read-func) + (let loop ((c (parser-read-char parser))) + (case c + ;; skip whitespace + ((#\ht #\vt #\lf #\cr #\sp) (loop (parser-peek-char parser))) + ;; read contents + ((delim) (read-func parser)) + (else (throw 'json-invalid parser))))))) + +(define (json-read-true parser) + (expect-string parser "true") + #t) + +(define (json-read-false parser) + (expect-string parser "false") + #f) + +(define (json-read-null parser) + (expect-string parser "null") + #nil) + +(define (json-read-object parser) + (json-read-delimited parser #\{ read-object)) + +(define (json-read-array parser) + (json-read-delimited parser #\[ read-array)) + +(define (json-read-string parser) + (json-read-delimited parser #\" read-string)) + +(define (json-read-number parser) + (string->number (read-number parser))) + +(define (json-read parser) + (let loop ((c (parser-peek-char parser))) + (cond + ;;If we reach the end we might have an incomplete document + ((eof-object? c) (throw 'json-invalid parser)) + (else + (case c + ;; skip whitespaces + ((#\ht #\vt #\lf #\cr #\sp) + (parser-read-char parser) + (loop (parser-peek-char parser))) + ;; read json values + ((#\t) (json-read-true parser)) + ((#\f) (json-read-false parser)) + ((#\n) (json-read-null parser)) + ((#\{) (json-read-object parser)) + ((#\[) (json-read-array parser)) + ((#\") (json-read-string parser)) + ;; anything else should be a number + (else (json-read-number parser))))))) + +;; +;; Public procedures +;; + +(define* (json->scm #:optional (port (current-input-port))) + "Parse a JSON document into native. Takes one optional argument, +@var{port}, which defaults to the current input port from where the JSON +document is read." + (json-read (make-json-parser port))) + +(define* (json-string->scm str) + "Parse a JSON document into native. Takes a string argument, +@var{str}, that contains the JSON document." + (call-with-input-string str (lambda (p) (json->scm p)))) + +;;; (json parser) ends here diff --git a/borrowed/guile-json/json/syntax.scm b/borrowed/guile-json/json/syntax.scm new file mode 100644 index 0000000000..10e20997a0 --- /dev/null +++ b/borrowed/guile-json/json/syntax.scm @@ -0,0 +1,76 @@ +;;; (json syntax) --- Guile JSON implementation. + +;; Copyright (C) 2013-2017 Aleix Conchillo Flaque +;; +;; 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 Lesser 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with guile-json; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; JSON module for Guile + +;;; Code: + +(define-module (json syntax) + #:use-module (ice-9 deprecated) + #:use-module (ice-9 match) + #:export (json)) + +(define (list->hash-table lst) + (let loop ((table (make-hash-table)) + (lst lst)) + (match lst + (((key value) . rest) + (hash-set! table key value) + (loop table rest)) + (() table)))) + +(define-syntax json + (syntax-rules (unquote unquote-splicing array object) + ((_ (unquote val)) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + val)) + ((_ ((unquote-splicing val) . rest)) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + (append val (json rest)))) + ((_ (array val . rest)) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + (cons (json val) (json rest)))) + ((_ (object key+val ...)) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + (list->hash-table + (json (array key+val ...))))) + ((_ (val . rest)) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + (cons (json val) (json rest)))) + ((_ val) + (begin + (issue-deprecation-warning + "`json' macro is deprecated. Use scheme data types instead.") + (quote val))))) + +;;; (json syntax) ends here