diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..2d8f977 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,5 @@ +((nil . ((geiser-default-implementation . chicken) + (geiser-scheme-implementation . chicken) + (geiser-active-implementations . (chicken)) + (org-confirm-babel-evaluate . nil))) + (org . ((org-confirm-babel-evaluate . nil)))) diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..8983807 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use nix -p chicken chickenPackages_5.chickenEggs.apropos chickenPackages_5.chickenEggs.chicken-doc chickenPackages_5.chickenEggs.srfi-1 chickenPackages_5.chickenEggs.srfi-18 chickenPackages_5.chickenEggs.srfi-34 chickenPackages_5.chickenEggs.srfi-35 chickenPackages_5.chickenEggs.srfi-158 chicken chickenPackages_5.chickenEggs.apropos chickenPackages_5.chickenEggs.chicken-doc chickenPackages_5.chickenEggs.srfi-1 chickenPackages_5.chickenEggs.srfi-18 chickenPackages_5.chickenEggs.test diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..909b517 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (C) 2022 Daniel Ziltener + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.org b/README.org new file mode 100644 index 0000000..571a2a4 --- /dev/null +++ b/README.org @@ -0,0 +1,216 @@ +# Created 2024-09-14 Sat 00:15 +#+title: SRFI-180 +#+author: Daniel Ziltener +#+export_file_name: README.org +#+property: header-args:scheme :session *chicken* :comments none +#+property: header-args:fundamental :eval no + +* Dependencies + +Main dependencies: + +#+name: dependencies +| Egg | Description | +|----------+--------------------| +| srfi-34 | Exception Handling | +| srfi-35 | Exception Types | +| srfi-158 | Generators | +|----------+--------------------| + +Test dependencies: +#+name: test-dependencies +| Egg | Description | +|------+--------------------------------| +| test | The de-facto standard test egg | + +* API + +** Exceptions +This library defines an SRFI-35 exception type ~&json-error~ that gets raised when invalid tokens are encountered. The exception type has a field ~json-invalid-token~ that contains the offending token. +#+begin_src scheme + (define-condition-type &json-error &error + json-error? + (json-error-reason json-error-reason) + (json-invalid-token json-invalid-token)) +#+end_src + + +** Parameters +This library offers the following configuration parameters: +#+name: parameters +| Parameter | Default | Description | +|--------------------------------+---------+-----------------------------------------------------| +| json-nesting-depth-limit | +inf.0 | the maximum nesting depth of JSON that can be read. | +| json-number-of-character-limit | +inf.0 | the maximum length of JSON input that can be read. | + +** Predicates +For some reason, this SRFI includes a predicate to check for JSON null values: +#+begin_src scheme + (define (json-null? obj) (eq? obj 'null)) +#+end_src + +** Reading JSON + +*** json-generator + +~(json-generator [port-or-generator]) → generator~ + +Streaming event-based JSON reader. =PORT-OR-GENERATOR= default value is the value returned by =current-input-port=. It must be a textual input port or a generator of characters. =json-generator= returns a generator of Scheme objects, each of which must be one of: + +- ~'array-start~ symbol denoting that an array should be constructed. +- ~'array-end~ symbol denoting that the construction of the array for which the last ~'array-start~ was generated and not closed is finished. +- ~'object-start~ symbol denoting that an object should be constructed. The object's key-value pairs are emitted in sequence like those in a property list (plist) where keys are strings. That is, the generation of a key is always followed by the generation of a value. Otherwise, the JSON would be invalid and =json-generator= would raise an error. +- ~'object-end~ symbol denoting that the construction of the object for which the last ~'object-start~ was generated and not closed is finished. +- the symbol ~'null~ +- boolean +- number +- string + +In the case where nesting of arrays or objects reaches the value returned by the parameter =json-nesting-depth-limit=, the generator must raise an object that satisfies the predicate =json-error?=. + +In cases where the JSON is invalid, the generator returned by =json-generator= should raise an object that satisfies the predicate =json-error?=. + +Otherwise, if =PORT-OR-GENERATOR= contains valid JSON text, the generator returned by =json-generator= must yield an end-of-file object in two situations: + +- The first time the generator returned by =json-generator= is called, it returns an object that is a boolean, a number, a string or the symbol ='null=. +- The first time the generator returned by =json-generator= is called, it returns a symbol that is not the symbol ='null=. When the underlying JSON text is valid, it should be the symbol starting a structure: ='object-start= or ='array-start=. The end-of-file object is generated when that structure is finished. + +In other words, the generator returned by =json-generator= will parse at most one JSON value or one top-level structure. If =PORT= is not finished, as in the case of JSON lines, the user should call =json-generator= again with the same =PORT-OR-GENERATOR=. + +**** Examples + +#+begin_src scheme + + (call-with-input-string "42 101 1337" (lambda (port) (generator->list (json-generator port)))) +#+end_src + +#+results: +#+begin_src scheme + (42) +#+end_src + +#+begin_src scheme + + (call-with-input-string "[42] 101 1337" (lambda (port) (generator->list (json-generator port)))) +#+end_src + +#+results: +#+begin_src scheme + (array-start 42 array-end) +#+end_src + +*** json-fold + +~(json-fold proc array-start array-end object-start object-end seed [port-or-generator])~ + +Fundamental JSON iterator. + +=json-fold= will read the JSON text from =PORT-OR-GENERATOR=, which has ~(current-input-port)~ as its default value. =json-fold= will call the procedures passed as argument: + +- ~(PROC obj seed)~ is called when a JSON value is generated or a complete JSON structure is read. =PROC= should return the new seed that will be used to iterate over the rest of the generator. Termination is described below. +- ~(OBJECT-START seed)~ is called with a seed and should return a seed that will be used as the seed of the iteration over the key and values of that object. +- ~(OBJECT-END seed)~ is called with a seed and should return a new seed that is the result of the iteration over a JSON object. +=ARRAY-START= and =ARRAY-END= take the same arguments, and have similar behavior, but are called for iterating on JSON arrays. +=json-fold= must return the seed when: + +- =PORT-OR-GENERATOR= yields an object that satisfies the predicate =eof-object?= +- All structures, array or object, that were started have ended. The returned object is ~(PROC obj SEED)~ where obj is the object returned by =ARRAY-END= or =OBJECT-END= + +*** json-read + +~(json-read [port-or-generator]) → object~ + +JSON reader procedure. =PORT-OR-GENERATOR= must be a textual input port or a generator of characters. The default value of =PORT-OR-GENERATOR= is the value returned by the procedure =current-input-port=. The returned value is a Scheme object. =json-read= must return only the first toplevel JSON value or structure. When there are multiple toplevel values or structures in =PORT-OR-GENERATOR=, the user should call =json-read= several times to read all of it. + +The mapping between JSON types and Scheme objects is the following: + +- =null= → the symbol ='null= +- =true= → =#t= +- =false= → =#f= +- =number= → number +- =string= → string +- =array= → vector +- =object= → association list with keys that are symbols + +In the case where nesting of arrays or objects reaches the value returned by the parameter =json-nesting-depth-limit=, =json-read= must raise an object that satisfies the predicate =json-error?= + +*** json-lines-read + +~(json-lines-read [port-or-generator]) → generator~ + +JSON reader of jsonlines or ndjson. As its first and only argument, it takes a generator of characters or a textual input port whose default value is the value returned by =current-input-port=. It will return a generator of Scheme objects as specified in =json-read=. + +*** json-sequence-read + +~(json-sequence-read [port-or-generator]) → generator~ + +JSON reader of JSON Text Sequences (RFC 7464). As its first and only argument, it takes a generator of characters or a textual input port whose default value is the value returned by =current-input-port=. It will return a generator of Scheme objects as specified in =json-read=. + +*** json-accumulator + +~(json-accumulator port-or-accumulator) → procedure~ + +Streaming event-based JSON writer. =PORT-OR-ACCUMULATOR= must be a textual output port or an accumulator that accepts characters and strings. It returns an accumulator procedure that accepts Scheme objects as its first and only argument and that follows the same protocol as described in =json-generator=. Any deviation from the protocol must raise an error that satisfies =json-error?=. In particular, objects and arrays must be properly nested. + +Mind the fact that most JSON parsers have a nesting limit that is not documented by the standard. Even if you can produce arbitrarily nested JSON with this library, you might not be able to read it with another library. + +*** json-write + +~(json-write obj [port-or-accumulator]) → unspecified~ + +JSON writer procedure. =PORT-OR-ACCUMULATOR= must be a textual output port, or an accumulator that accepts characters and strings. The default value of =PORT-OR-ACCUMULATOR= is the value returned by the procedure =current-output-port=. The value returned by =json-write= is unspecified. + +=json-write= will validate that =OBJ= can be serialized into JSON before writing to =PORT=. An error that satisfies =json-error?= is raised in the case where =OBJ= is not an object or a composition of the following types: + +- symbol ='null= +- boolean +- number. Must be integers or inexact rationals. (That is, they must not be complex, infinite, NaN, or exact rationals that are not integers.) +- string +- vector +- association list with keys as symbols + +* About this egg + +** Source + +The source is available at [[https://gitea.lyrion.ch/Chicken/srfi-180]]. + +** Author + +Daniel Ziltener + +** Version History + +#+name: version-history +| 1.5 | Reimplementation | +| 1.0 | Reference Implementation | + +* License + +#+begin_src fundamental + Copyright (C) 2022 Daniel Ziltener + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + ,* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + ,* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + ,* Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND + ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +#+end_src diff --git a/srfi-180.egg b/srfi-180.egg index 5d9cb66..b121495 100644 --- a/srfi-180.egg +++ b/srfi-180.egg @@ -1,19 +1,11 @@ -;;; -*- scheme -*- - -((author "Amirouche Boubekki") - (synopsis "This library describes a JavaScript Object Notation (JSON) parser and printer. It supports JSON that may be bigger than memory.") +;; -*- Scheme -*- +((author "Daniel Ziltener") + (synopsis "A JSON parser and printer that supports JSON bigger than memory.") (category parsing) - (license "MIT") - (version "1.0.0") - (dependencies r7rs srfi-60 srfi-145) - (build-dependencies srfi-121) + (license "BSD") + (version "1.5.0") + (dependencies srfi-34 srfi-35 srfi-158) + (test-dependencies test) (components - (extension srfi.180.helpers - (csc-options "-X" "r7rs" "-R" "r7rs")) - (extension srfi-180 - (component-dependencies srfi.180.helpers) - (csc-options "-X" "r7rs" "-R" "r7rs")) - (extension srfi.180.checks - (component-dependencies srfi-180) - (csc-options "-X" "r7rs" "-R" "r7rs")) - )) + (extension srfi-180 + (csc-options "-sJ")))) diff --git a/srfi-180.impl.scm b/srfi-180.impl.scm new file mode 100644 index 0000000..3d2d863 --- /dev/null +++ b/srfi-180.impl.scm @@ -0,0 +1,297 @@ +(import + (scheme) + (chicken format) + (chicken port) + (chicken string) + (srfi-34) ;;Exception Handling + (srfi-35) ;;Exception Types + (srfi-158) ;;Generators + ) + +(define-condition-type &json-error &error + json-error? + (json-error-reason json-error-reason) + (json-invalid-token json-invalid-token)) + +(define json-nesting-depth-limit (make-parameter +inf.0)) ;; the maximum nesting depth of JSON that can be read. +(define json-number-of-character-limit (make-parameter +inf.0)) ;; the maximum length of JSON input that can be read. + +(define (json-null? obj) (eq? obj 'null)) + +(define (is-array-start? c) + (char=? #\[ c)) + +(define (is-array-end? c) + (char=? #\] c)) + +(define (is-object-start? c) + (char=? #\{ c)) + +(define (is-object-end? c) + (char=? #\} c)) + +(define (is-number-start? c) + (or (char-numeric? c) + (char=? #\+ c) + (char=? #\- c))) + +(define (is-string-start? c) + (char=? #\" c)) + +(define (is-null-start? c) + (char=? #\n c)) + +(define (is-bool-start? c) + (or (char=? #\t c) + (char=? #\f c))) + +(define (is-whitespace? c) + (or (char-whitespace? c) + (char=? #\, c) + (char=? #\: c))) + +(define (is-delimiter? x) + (or (eof-object? x) + (is-whitespace? x) + (is-array-start? x) + (is-array-end? x) + (is-object-start? x) + (is-object-end? x))) + +(define (determine-reader-proc peek-char) + (cond + ((is-array-start? peek-char) read-array-start) + ((is-array-end? peek-char) read-array-end) + ((is-object-start? peek-char) read-object-start) + ((is-object-end? peek-char) read-object-end) + ((is-null-start? peek-char) read-null-sym) + ((is-bool-start? peek-char) read-boolean) + ((is-number-start? peek-char) read-number) + ((is-string-start? peek-char) read-string) + ((is-whitespace? peek-char) read-whitespace) + (else (raise (make-condition &json-error 'json-error-reason "Invalid token" 'json-invalid-token peek-char))))) + +(define (json-generator #!optional (port-or-generator (current-input-port))) + (let* ((input-generator (if (procedure? port-or-generator) + port-or-generator + (lambda () (read-char port-or-generator)))) + (nesting-limit (json-nesting-depth-limit)) + (character-limit (json-number-of-character-limit))) + (make-coroutine-generator + (lambda (yield) + (let loop ((next-char (input-generator)) + (json-nesting-depth #f) + (json-number-of-characters 0)) + (cond + ((> (or json-nesting-depth 0) nesting-limit) + (raise (make-condition &json-error + 'json-error-reason "Nesting depth exceeded" + 'json-invalid-token next-char))) + ((> json-number-of-characters character-limit) + (raise (make-condition &json-error + 'json-error-reason "Character limit exceeded" + 'json-invalid-token next-char))) + ((and (eof-object? next-char) + (< 0 json-nesting-depth)) + (raise (make-condition &json-error + 'json-error-reason "Unfinished JSON expression" + 'json-invalid-token next-char))) + ((or (eof-object? next-char) + (eq? 0 json-nesting-depth)) + #!eof) + (else + (let-values (((token next-char* new-charcount nesting-delta) + ((determine-reader-proc next-char) + json-number-of-characters next-char input-generator))) + (if (not (eq? '() token)) + (yield token)) + (loop next-char* (+ (or json-nesting-depth 0) nesting-delta) new-charcount))))))))) + +(define (read-whitespace charcount next-char input-proc) + (values '() (input-proc) (+ charcount 1) 0)) + +(define (read-array-start charcount next-char input-proc) + (values 'array-start (input-proc) (+ charcount 1) +1)) + +(define (read-array-end charcount next-char input-proc) + (values 'array-end (input-proc) (+ charcount 1) -1)) + +(define (read-object-start charcount next-char input-proc) + (values 'object-start (input-proc) (+ charcount 1) +1)) + +(define (read-object-end charcount next-char input-proc) + (values 'object-end (input-proc) (+ charcount 1) -1)) + +(define (read-null-sym charcount next-char input-proc) + (if (not (is-delimiter? next-char)) + (read-null-sym (+ charcount 1) (input-proc) input-proc) + (values 'null next-char charcount 0))) + +(define (read-boolean charcount next-char input-proc #!optional (accu '())) + (set! accu (cons next-char accu)) + (let ((accu-str (reverse-list->string accu))) + (cond + ((string=? "true" accu-str) (values #t (input-proc) (+ charcount 1) 0)) + ((string=? "false" accu-str) (values #f (input-proc) (+ charcount 1) 0)) + (else (let ((next-char* (input-proc))) + (if (is-delimiter? next-char*) + (values accu next-char* charcount 0) ;; TODO: Throw error instead + (read-boolean (+ charcount 1) next-char* input-proc accu))))))) + +(define (read-number charcount next-char input-proc #!optional (accu '())) + (set! accu (cons next-char accu)) + (let ((next-char* (input-proc))) + (if (is-delimiter? next-char*) + (values (string->number (reverse-list->string accu)) + next-char* (+ charcount 1) 0) + (read-number (+ charcount 1) next-char* input-proc accu)))) + +(define (read-string charcount next-char input-proc #!optional (beginning? #t) (accu '()) (esc? #f)) + (cond + (beginning? + (read-string (+ charcount 1) + (input-proc) + input-proc + #f '() #f)) + ((and (not esc?) (char=? next-char #\")) + (values (reverse-list->string accu) + (input-proc) (+ charcount 1) 0)) + (else (read-string (+ charcount 1) + (input-proc) input-proc + #f (cons next-char accu) + (and (not esc?) (char=? next-char #\\)))))) + +(define-record json-foldstate mode cache accumulator) + +(define (json-proc obj foldstate) + (if (json-foldstate? foldstate) + (case (json-foldstate-mode foldstate) + ((%array) (begin + (json-foldstate-accumulator-set! + foldstate + (cons obj (json-foldstate-accumulator foldstate))) + foldstate)) + ((%object) (begin + (if (equal? '() (json-foldstate-cache foldstate)) + (begin + (json-foldstate-cache-set! foldstate obj)) + (begin + (json-foldstate-accumulator-set! + foldstate + (cons (cons (json-foldstate-cache foldstate) obj) + (json-foldstate-accumulator foldstate))) + (json-foldstate-cache-set! foldstate '()))) + foldstate))) + obj)) + +(define (object-start seed) + (make-json-foldstate '%object '() '())) + +(define (object-end seed) + (reverse (json-foldstate-accumulator seed))) + +(define (array-start seed) + (make-json-foldstate '%array '() '())) + +(define (array-end seed) + (list->vector (reverse (json-foldstate-accumulator seed)))) + +(define (json-fold proc array-start array-end object-start object-end seed #!optional (port-or-generator (current-input-port))) + (let ((generator (json-generator port-or-generator))) + (let recurse ((seed seed) + (jump #f)) + (generator-fold + (lambda (token seed) + (case token + ((array-start) (proc + (call-with-current-continuation + (lambda (jump) + (recurse (array-start seed) jump))) + seed)) + ((array-end) (if jump + (jump (array-end seed)) + (array-end seed))) + ((object-start) (proc + (call-with-current-continuation + (lambda (jump) + (recurse (object-start seed) jump))) + seed)) + ((object-end) (if jump + (jump (object-end seed)) + (object-end seed))) + (else (proc token seed)))) + seed generator)))) + +(define (json-read #!optional (port-or-generator (current-input-port))) + (json-fold json-proc array-start array-end object-start object-end '() port-or-generator)) + +(define json-lines-read json-read) + +(define json-sequence-read json-read) + +(define (accumulate-boolean accumulator bool) + (if bool (accumulator 'true) (accumulator 'false))) + +(define (accumulate-null accumulator) + (accumulator 'null)) + +(define (accumulate-number accumulator num) + (accumulator num)) + +(define (accumulate-string accumulator str) + (accumulator str)) + +(define (accumulate-vector accumulator vec) + (accumulator #\[) + (let ((max-index (- (vector-length vec) 1))) + (let loop ((index 0)) + (accumulate-dispatch accumulator + (vector-ref vec index)) + (if (< index max-index) + (begin (accumulator #\,) (accumulator #\space) + (loop (+ index 1)))))) + (accumulator #\])) + +(define (accumulate-alist accumulator alist) + (accumulator #\{) + (let loop ((alist alist)) + (let ((kv-pair (car alist))) + (if (not (pair? kv-pair)) + (raise (make-condition &json-error + 'json-error-reason "Unbalanced alist" + 'json-invalid-token kv-pair))) + (accumulate-dispatch accumulator + (symbol->string (car kv-pair))) + (accumulator #\:) (accumulator #\space) + (accumulate-dispatch accumulator (cdr kv-pair)) + (if (not (eq? '() (cdr alist))) + (begin + (accumulator #\,) (accumulator #\space) + (loop (cdr alist)))))) + (accumulator #\})) + +(define (accumulate-dispatch accumulator obj) + (cond + ((number? obj) (accumulate-number accumulator obj)) + ((string? obj) (accumulate-string accumulator obj)) + ((boolean? obj) (accumulate-boolean accumulator obj)) + ((eq? 'null obj) (accumulate-null accumulator)) + ((vector? obj) (accumulate-vector accumulator obj)) + ((list? obj) (accumulate-alist accumulator obj)))) + +(define (json-accumulator #!optional (port-or-accumulator (current-output-port))) + (let ((accumulator (if (procedure? port-or-accumulator) + port-or-accumulator + (lambda (txt) + (if (char? txt) + (display txt port-or-accumulator) + (write txt port-or-accumulator))))) + (leading-space? #f)) + (lambda (obj) + (if leading-space? (accumulator #\space) (set! leading-space? #t)) + (accumulate-dispatch accumulator obj)))) + +(define (json-write obj #!optional (port-or-accumulator (current-output-port))) + (let ((black-hole (make-output-port (lambda (poor-soul) #t) (lambda () #t)))) + ((json-accumulator black-hole) obj)) + ((json-accumulator port-or-accumulator) obj)) diff --git a/srfi-180.org b/srfi-180.org new file mode 100644 index 0000000..fcdf6c1 --- /dev/null +++ b/srfi-180.org @@ -0,0 +1,1015 @@ +#+title: SRFI-180 +#+author: Daniel Ziltener +#+export_file_name: README.org +#+property: header-args:scheme :session *chicken* :comments none +#+property: header-args:fundamental :eval no + +* Helpers :noexport: +:PROPERTIES: +:header-args:scheme: :prologue "(import (chicken string))" +:END: +** Strip garbage from test results +#+name: test-post +#+begin_src scheme :var input='() :results output +(for-each (lambda (str) + (or (substring=? str ";") + (substring=? str "Note") + (print str))) + (string-split input "\n")) +#+end_src + +** Prepare in-line testing +#+name: prep-test +#+begin_src scheme :noweb yes :tangle tests/run.scm :results silent + (import test + (chicken base) + (chicken format) + (chicken port) + (chicken string) + (chicken io) + <> + ) +#+end_src + +* Dependencies + +Main dependencies: + +#+name: dependencies +| Egg | Description | +|----------+--------------------| +| srfi-34 | Exception Handling | +| srfi-35 | Exception Types | +| srfi-158 | Generators | +|----------+--------------------| + +Test dependencies: +#+name: test-dependencies +| Egg | Description | +|------+--------------------------------| +| test | The de-facto standard test egg | + +#+name: dependencies-for-egg +#+begin_src emacs-lisp :var tbl=dependencies :colnames yes :results raw :exports none + (mapconcat (lambda (row) (car row)) tbl " ") +#+end_src + +#+name: dependencies-for-imports +#+begin_src emacs-lisp :var tbl=dependencies :colnames yes :results raw :exports none + (mapconcat (lambda (row) (concat "(" (car row) ")\t ;;" (cadr row))) tbl "\n") +#+end_src + +#+name: dependencies-for-nix +#+begin_src emacs-lisp :var tbl=dependencies :colnames yes :results raw :exports none + (concat + "chicken chickenPackages_5.chickenEggs.apropos chickenPackages_5.chickenEggs.chicken-doc chickenPackages_5.chickenEggs.srfi-1 chickenPackages_5.chickenEggs.srfi-18 " + (mapconcat (lambda (row) (concat "chickenPackages_5.chickenEggs." (car row))) tbl " ")) +#+end_src + +#+begin_src fundamental :noweb yes :tangle .envrc :exports none +use nix -p <> <> +#+end_src + +#+begin_src scheme :tangle tests/run.scm :exports none :results silent +(include-relative "../srfi-180.impl.scm") +#+end_src + +* API + +#+begin_src scheme :noweb yes :tangle srfi-180.scm :exports none + (module (srfi 180) + (&json-error + json-error? + json-error-reason + json-invalid-token + json-nesting-depth-limit + json-number-of-character-limit + json-generator + json-null? + json-fold + json-read + json-lines-read + json-sequence-read + json-accumulator + json-write) + (import (chicken base)) + (include-relative "srfi-180.impl.scm")) +#+end_src + +#+begin_src scheme :noweb yes :tangle srfi-180.impl.scm :exports none + (import + (scheme) + (chicken format) + (chicken port) + (chicken string) + <> + ) +#+end_src + +** Exceptions +This library defines an SRFI-35 exception type ~&json-error~ that gets raised when invalid tokens are encountered. The exception type has a field ~json-invalid-token~ that contains the offending token. +#+begin_src scheme :tangle srfi-180.impl.scm + (define-condition-type &json-error &error + json-error? + (json-error-reason json-error-reason) + (json-invalid-token json-invalid-token)) +#+end_src + + +** Parameters +This library offers the following configuration parameters: +#+name: parameters +| Parameter | Default | Description | +|--------------------------------+---------+-----------------------------------------------------| +| json-nesting-depth-limit | +inf.0 | the maximum nesting depth of JSON that can be read. | +| json-number-of-character-limit | +inf.0 | the maximum length of JSON input that can be read. | + +#+name: parameters-codegen +#+begin_src emacs-lisp :var tbl=parameters :colnames yes :results raw :exports none + (mapconcat (lambda (row) (concat "(define " (car row) " (make-parameter " (cadr row) "))\t;; " (caddr row))) + tbl "\n") +#+end_src + +#+name: global-parameters +#+begin_src scheme :noweb yes :tangle srfi-180.impl.scm :exports none + <> +#+end_src + +** Predicates +For some reason, this SRFI includes a predicate to check for JSON null values: +#+begin_src scheme :tangle srfi-180.impl.scm + (define (json-null? obj) (eq? obj 'null)) +#+end_src + +*** Tokenizer Predicates :noexport: +The needed token predicates are: + +**** Start/End of Arrays +#+name: tokpred-array +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-array-start? c) + (char=? #\[ c)) + + (define (is-array-end? c) + (char=? #\] c)) +#+end_src + +**** Start/End of Objects +#+name: tokpred-object +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-object-start? c) + (char=? #\{ c)) + + (define (is-object-end? c) + (char=? #\} c)) +#+end_src + +**** Numbers +#+name: tokpred-number +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-number-start? c) + (or (char-numeric? c) + (char=? #\+ c) + (char=? #\- c))) +#+end_src + +**** Strings +#+name: tokpred-string +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-string-start? c) + (char=? #\" c)) +#+end_src + +**** Symbols +#+name: tokpred-symbol +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-null-start? c) + (char=? #\n c)) + + (define (is-bool-start? c) + (or (char=? #\t c) + (char=? #\f c))) +#+end_src + +**** Whitespace + +#+name: tokpred-whitespace +#+begin_src scheme :tangle srfi-180.impl.scm + (define (is-whitespace? c) + (or (char-whitespace? c) + (char=? #\, c) + (char=? #\: c))) +#+end_src + +#+name: tokenpred-whitespace-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + (test-group "Whitespace predicate" + (test "#\\space" + #t (is-whitespace? #\space))) +#+end_src + +#+RESULTS: tokenpred-whitespace-test +: -- testing Whitespace predicate ---------------------------------------------- +: #\space .............................................................. [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing Whitespace predicate ----------------------------------------- + +**** Delimiter check for readers + +#+name: tokpred-delimiter +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (is-delimiter? x) + (or (eof-object? x) + (is-whitespace? x) + (is-array-start? x) + (is-array-end? x) + (is-object-start? x) + (is-object-end? x))) +#+end_src + +**** Aggregated for tests +#+name: tokenpredicates +#+begin_src scheme :noweb yes + <> + <> + <> + <> + <> + <> + <> +#+end_src + +** Reading JSON + +*** json-generator + +~(json-generator [port-or-generator]) → generator~ + +Streaming event-based JSON reader. =PORT-OR-GENERATOR= default value is the value returned by =current-input-port=. It must be a textual input port or a generator of characters. =json-generator= returns a generator of Scheme objects, each of which must be one of: + +- ~'array-start~ symbol denoting that an array should be constructed. +- ~'array-end~ symbol denoting that the construction of the array for which the last ~'array-start~ was generated and not closed is finished. +- ~'object-start~ symbol denoting that an object should be constructed. The object's key-value pairs are emitted in sequence like those in a property list (plist) where keys are strings. That is, the generation of a key is always followed by the generation of a value. Otherwise, the JSON would be invalid and =json-generator= would raise an error. +- ~'object-end~ symbol denoting that the construction of the object for which the last ~'object-start~ was generated and not closed is finished. +- the symbol ~'null~ +- boolean +- number +- string + +#+name: json-generator +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (determine-reader-proc peek-char) + (cond + ((is-array-start? peek-char) read-array-start) + ((is-array-end? peek-char) read-array-end) + ((is-object-start? peek-char) read-object-start) + ((is-object-end? peek-char) read-object-end) + ((is-null-start? peek-char) read-null-sym) + ((is-bool-start? peek-char) read-boolean) + ((is-number-start? peek-char) read-number) + ((is-string-start? peek-char) read-string) + ((is-whitespace? peek-char) read-whitespace) + (else (raise (make-condition &json-error 'json-error-reason "Invalid token" 'json-invalid-token peek-char))))) + + (define (json-generator #!optional (port-or-generator (current-input-port))) + (let* ((input-generator (if (procedure? port-or-generator) + port-or-generator + (lambda () (read-char port-or-generator)))) + (nesting-limit (json-nesting-depth-limit)) + (character-limit (json-number-of-character-limit))) + (make-coroutine-generator + (lambda (yield) + (let loop ((next-char (input-generator)) + (json-nesting-depth #f) + (json-number-of-characters 0)) + (cond + ((> (or json-nesting-depth 0) nesting-limit) + (raise (make-condition &json-error + 'json-error-reason "Nesting depth exceeded" + 'json-invalid-token next-char))) + ((> json-number-of-characters character-limit) + (raise (make-condition &json-error + 'json-error-reason "Character limit exceeded" + 'json-invalid-token next-char))) + ((and (eof-object? next-char) + (< 0 json-nesting-depth)) + (raise (make-condition &json-error + 'json-error-reason "Unfinished JSON expression" + 'json-invalid-token next-char))) + ((or (eof-object? next-char) + (eq? 0 json-nesting-depth)) + #!eof) + (else + (let-values (((token next-char* new-charcount nesting-delta) + ((determine-reader-proc next-char) + json-number-of-characters next-char input-generator))) + (if (not (eq? '() token)) + (yield token)) + (loop next-char* (+ (or json-nesting-depth 0) nesting-delta) new-charcount))))))))) +#+end_src + +#+name: json-generator-pack +#+begin_src scheme :noweb yes :exports none :results silent + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> +#+end_src + +#+name: json-generator-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + (test-group "JSON Generator" + (test "Basic test" + '(array-start 1 2 3 "Hello" object-start "a" 1 object-end array-end) + (with-input-from-string "[1, 2, 3, \"Hello\", {\"a\", 1}] true [5 4 3 2]" + (lambda () + (let ((generator (json-generator))) + (let loop ((accu '())) + (let ((token (generator))) + (if (not (eof-object? token)) + (loop (cons token accu)) + (reverse accu))))))))) +#+end_src + +#+RESULTS: json-generator-test +: -- testing JSON Generator ---------------------------------------------------- +: Basic test ........................................................... [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing JSON Generator ----------------------------------------------- + +In the case where nesting of arrays or objects reaches the value returned by the parameter =json-nesting-depth-limit=, the generator must raise an object that satisfies the predicate =json-error?=. + +In cases where the JSON is invalid, the generator returned by =json-generator= should raise an object that satisfies the predicate =json-error?=. + +Otherwise, if =PORT-OR-GENERATOR= contains valid JSON text, the generator returned by =json-generator= must yield an end-of-file object in two situations: + +- The first time the generator returned by =json-generator= is called, it returns an object that is a boolean, a number, a string or the symbol ='null=. +- The first time the generator returned by =json-generator= is called, it returns a symbol that is not the symbol ='null=. When the underlying JSON text is valid, it should be the symbol starting a structure: ='object-start= or ='array-start=. The end-of-file object is generated when that structure is finished. + +In other words, the generator returned by =json-generator= will parse at most one JSON value or one top-level structure. If =PORT= is not finished, as in the case of JSON lines, the user should call =json-generator= again with the same =PORT-OR-GENERATOR=. + +**** Examples + +#+begin_src scheme :noweb strip-export :results code :exports both + <> + (call-with-input-string "42 101 1337" (lambda (port) (generator->list (json-generator port)))) +#+end_src + +#+RESULTS: +#+begin_src scheme +(42) +#+end_src + +#+begin_src scheme :noweb strip-export :results code :exports both + <> + (call-with-input-string "[42] 101 1337" (lambda (port) (generator->list (json-generator port)))) +#+end_src + +#+RESULTS: +#+begin_src scheme +(array-start 42 array-end) +#+end_src + +**** Reader implementations :noexport: + +Whitespace reader + +#+name: whitespace-reader +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-whitespace charcount next-char input-proc) + (values '() (input-proc) (+ charcount 1) 0)) +#+end_src + + Array delimiter reader + +#+name: array-delimiter-readers +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-array-start charcount next-char input-proc) + (values 'array-start (input-proc) (+ charcount 1) +1)) + + (define (read-array-end charcount next-char input-proc) + (values 'array-end (input-proc) (+ charcount 1) -1)) +#+end_src + +#+name: array-delimiter-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + (test-group "Array delimiter reading" + (test "Start delimiter" + '(array-start " " 1) + (let-values (((val input charcount nesting-delta) (read-array-start 0 "[" (lambda () " ")))) + (list val input charcount))) + (test "End delimiter" + '(array-end " " 9) + (let-values (((val input charcount nesting-delta) (read-array-end 8 "]" (lambda () " ")))) + (list val input charcount)))) +#+end_src + +#+RESULTS: array-delimiter-reader-test +: -- testing Array delimiter reading ------------------------------------------- +: Start delimiter ...................................................... [ PASS] +: End delimiter ........................................................ [ PASS] +: 2 tests completed in 0.0 seconds. +: 2 out of 2 (100%) tests passed. +: -- done testing Array delimiter reading -------------------------------------- + +Object delimiter reader + +#+name: object-delimiter-readers +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-object-start charcount next-char input-proc) + (values 'object-start (input-proc) (+ charcount 1) +1)) + + (define (read-object-end charcount next-char input-proc) + (values 'object-end (input-proc) (+ charcount 1) -1)) +#+end_src + +#+name: object-delimiter-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + (test-group "Object delimiter reading" + (test "Start delimiter" + '(object-start " " 1) + (let-values (((val input charcount nesting-delta) (read-object-start 0 "{" (lambda () " ")))) + (list val input charcount))) + (test "End delimiter" + '(object-end " " 5) + (let-values (((val input charcount nesting-delta) (read-object-end 4 "}" (lambda () " ")))) + (list val input charcount)))) +#+end_src + +#+RESULTS: object-delimiter-reader-test +: -- testing Object delimiter reading ------------------------------------------ +: Start delimiter ...................................................... [ PASS] +: End delimiter ........................................................ [ PASS] +: 2 tests completed in 0.0 seconds. +: 2 out of 2 (100%) tests passed. +: -- done testing Object delimiter reading ------------------------------------- + +Null value reader + +#+name: null-value-reader +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-null-sym charcount next-char input-proc) + (if (not (is-delimiter? next-char)) + (read-null-sym (+ charcount 1) (input-proc) input-proc) + (values 'null next-char charcount 0))) +#+end_src + +#+name: null-value-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + <> + (test-group "Null reading" + (let ((input '(#\u #\l #\l #\space))) + (test "Null reading" + '(null #\space 4) + (let-values (((val input charcount nesting-delta) + (read-null-sym 0 #\n (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) +#+end_src + +#+RESULTS: null-value-reader-test +: -- testing Null reading ------------------------------------------------------ +: Null reading ......................................................... [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing Null reading ------------------------------------------------- + +Boolean reader + +#+name: boolean-reader +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-boolean charcount next-char input-proc #!optional (accu '())) + (set! accu (cons next-char accu)) + (let ((accu-str (reverse-list->string accu))) + (cond + ((string=? "true" accu-str) (values #t (input-proc) (+ charcount 1) 0)) + ((string=? "false" accu-str) (values #f (input-proc) (+ charcount 1) 0)) + (else (let ((next-char* (input-proc))) + (if (is-delimiter? next-char*) + (values accu next-char* charcount 0) ;; TODO: Throw error instead + (read-boolean (+ charcount 1) next-char* input-proc accu))))))) +#+end_src + +#+name: boolean-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + <> + (test-group "Boolean reading" + (let ((input '(#\r #\u #\e #\space))) + (test "True values" + '(#t #\space 4) + (let-values (((val input charcount nesting-delta) + (read-boolean 0 #\t (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) +#+end_src + +#+RESULTS: boolean-reader-test +: -- testing Boolean reading --------------------------------------------------- +: True values .......................................................... [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing Boolean reading ---------------------------------------------- + +Number reader + +#+name: number-reader +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-number charcount next-char input-proc #!optional (accu '())) + (set! accu (cons next-char accu)) + (let ((next-char* (input-proc))) + (if (is-delimiter? next-char*) + (values (string->number (reverse-list->string accu)) + next-char* (+ charcount 1) 0) + (read-number (+ charcount 1) next-char* input-proc accu)))) +#+end_src + +#+name: number-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + <> + (test-group "Number reading" + (let ((input '(#\2 #\3 #\4 #\space))) + (test "Integer" + '(1234 #\space 4) + (let-values (((val input charcount nesting-delta) + (read-number 0 #\1 (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) +#+end_src + +#+RESULTS: number-reader-test +: -- testing Number reading ---------------------------------------------------- +: Integer .............................................................. [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing Number reading ----------------------------------------------- + +String reader + +#+name: string-reader +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (read-string charcount next-char input-proc #!optional (beginning? #t) (accu '()) (esc? #f)) + (cond + (beginning? + (read-string (+ charcount 1) + (input-proc) + input-proc + #f '() #f)) + ((and (not esc?) (char=? next-char #\")) + (values (reverse-list->string accu) + (input-proc) (+ charcount 1) 0)) + (else (read-string (+ charcount 1) + (input-proc) input-proc + #f (cons next-char accu) + (and (not esc?) (char=? next-char #\\)))))) +#+end_src + +#+name: string-reader-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + <> + (test-group "String reading" + (let ((input '(#\T #\e #\s #\t #\space #\T #\e #\\ #\s #\\ #\" #\t #\" #\space))) + (test "String" + '("Test Te\\s\\\"t" #\space 14) + (let-values (((val input charcount nesting-delta) + (read-string 0 #\" (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) +#+end_src + +#+RESULTS: string-reader-test +: -- testing String reading ---------------------------------------------------- +: String ............................................................... [ PASS] +: 1 test completed in 0.0 seconds. +: 1 out of 1 (100%) test passed. +: -- done testing String reading ----------------------------------------------- + +*** json-fold + +~(json-fold proc array-start array-end object-start object-end seed [port-or-generator])~ + +Fundamental JSON iterator. + +=json-fold= will read the JSON text from =PORT-OR-GENERATOR=, which has ~(current-input-port)~ as its default value. =json-fold= will call the procedures passed as argument: + +#+name: json-foldstate-record +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define-record json-foldstate mode cache accumulator) +#+end_src + + - ~(PROC obj seed)~ is called when a JSON value is generated or a complete JSON structure is read. =PROC= should return the new seed that will be used to iterate over the rest of the generator. Termination is described below. +#+name: json-fold-proc +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (json-proc obj foldstate) + (if (json-foldstate? foldstate) + (case (json-foldstate-mode foldstate) + ((%array) (begin + (json-foldstate-accumulator-set! + foldstate + (cons obj (json-foldstate-accumulator foldstate))) + foldstate)) + ((%object) (begin + (if (equal? '() (json-foldstate-cache foldstate)) + (begin + (json-foldstate-cache-set! foldstate obj)) + (begin + (json-foldstate-accumulator-set! + foldstate + (cons (cons (json-foldstate-cache foldstate) obj) + (json-foldstate-accumulator foldstate))) + (json-foldstate-cache-set! foldstate '()))) + foldstate))) + obj)) +#+end_src + +- ~(OBJECT-START seed)~ is called with a seed and should return a seed that will be used as the seed of the iteration over the key and values of that object. +#+name: json-fold-object-start +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (object-start seed) + (make-json-foldstate '%object '() '())) +#+end_src + +- ~(OBJECT-END seed)~ is called with a seed and should return a new seed that is the result of the iteration over a JSON object. +#+name: json-fold-object-end +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (object-end seed) + (reverse (json-foldstate-accumulator seed))) +#+end_src + +=ARRAY-START= and =ARRAY-END= take the same arguments, and have similar behavior, but are called for iterating on JSON arrays. +#+name: json-fold-arrays +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (array-start seed) + (make-json-foldstate '%array '() '())) + + (define (array-end seed) + (list->vector (reverse (json-foldstate-accumulator seed)))) +#+end_src + +=json-fold= must return the seed when: + +- =PORT-OR-GENERATOR= yields an object that satisfies the predicate =eof-object?= +- All structures, array or object, that were started have ended. The returned object is ~(PROC obj SEED)~ where obj is the object returned by =ARRAY-END= or =OBJECT-END= + +#+name: json-folder +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (json-fold proc array-start array-end object-start object-end seed #!optional (port-or-generator (current-input-port))) + (let ((generator (json-generator port-or-generator))) + (let recurse ((seed seed) + (jump #f)) + (generator-fold + (lambda (token seed) + (case token + ((array-start) (proc + (call-with-current-continuation + (lambda (jump) + (recurse (array-start seed) jump))) + seed)) + ((array-end) (if jump + (jump (array-end seed)) + (array-end seed))) + ((object-start) (proc + (call-with-current-continuation + (lambda (jump) + (recurse (object-start seed) jump))) + seed)) + ((object-end) (if jump + (jump (object-end seed)) + (object-end seed))) + (else (proc token seed)))) + seed generator)))) +#+end_src + +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + <> + <> + <> + <> + <> + <> + (test-group "JSON folding" + (test "Single value" + 42 + (with-input-from-string "42 25" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Simple array" + #(24 42 43) + (with-input-from-string "[24 42 43]" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Nested array" + #(24 #(42 24) 42) + (with-input-from-string "[24 [42 24] 42]" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Nested object" + '(("a" . 1) ("b" . 2) ("c" . (("d" . 4)))) + (with-input-from-string "{\"a\": 1, \"b\": 2, \"c\": {\"d\": 4}}" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '()))))) +#+end_src + +#+RESULTS: +: -- testing JSON folding ------------------------------------------------------ +: Single value ......................................................... [ PASS] +: Simple array ......................................................... [ PASS] +: Nested array ......................................................... [ PASS] +: Nested object ........................................................ [ PASS] +: 4 tests completed in 0.001 seconds. +: 4 out of 4 (100%) tests passed. +: -- done testing JSON folding ------------------------------------------------- + +*** json-read + +~(json-read [port-or-generator]) → object~ + +JSON reader procedure. =PORT-OR-GENERATOR= must be a textual input port or a generator of characters. The default value of =PORT-OR-GENERATOR= is the value returned by the procedure =current-input-port=. The returned value is a Scheme object. =json-read= must return only the first toplevel JSON value or structure. When there are multiple toplevel values or structures in =PORT-OR-GENERATOR=, the user should call =json-read= several times to read all of it. + +The mapping between JSON types and Scheme objects is the following: + +- =null= → the symbol ='null= +- =true= → =#t= +- =false= → =#f= +- =number= → number +- =string= → string +- =array= → vector +- =object= → association list with keys that are symbols + +In the case where nesting of arrays or objects reaches the value returned by the parameter =json-nesting-depth-limit=, =json-read= must raise an object that satisfies the predicate =json-error?= + +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (json-read #!optional (port-or-generator (current-input-port))) + (json-fold json-proc array-start array-end object-start object-end '() port-or-generator)) +#+end_src + +*** json-lines-read + +~(json-lines-read [port-or-generator]) → generator~ + +JSON reader of jsonlines or ndjson. As its first and only argument, it takes a generator of characters or a textual input port whose default value is the value returned by =current-input-port=. It will return a generator of Scheme objects as specified in =json-read=. + +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent +(define json-lines-read json-read) +#+end_src + +*** json-sequence-read + +~(json-sequence-read [port-or-generator]) → generator~ + +JSON reader of JSON Text Sequences (RFC 7464). As its first and only argument, it takes a generator of characters or a textual input port whose default value is the value returned by =current-input-port=. It will return a generator of Scheme objects as specified in =json-read=. + +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent +(define json-sequence-read json-read) +#+end_src + +*** json-accumulator + +~(json-accumulator port-or-accumulator) → procedure~ + +Streaming event-based JSON writer. =PORT-OR-ACCUMULATOR= must be a textual output port or an accumulator that accepts characters and strings. It returns an accumulator procedure that accepts Scheme objects as its first and only argument and that follows the same protocol as described in =json-generator=. Any deviation from the protocol must raise an error that satisfies =json-error?=. In particular, objects and arrays must be properly nested. + +Mind the fact that most JSON parsers have a nesting limit that is not documented by the standard. Even if you can produce arbitrarily nested JSON with this library, you might not be able to read it with another library. + +#+name: json-accumulator +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (accumulate-boolean accumulator bool) + (if bool (accumulator 'true) (accumulator 'false))) + + (define (accumulate-null accumulator) + (accumulator 'null)) + + (define (accumulate-number accumulator num) + (accumulator num)) + + (define (accumulate-string accumulator str) + (accumulator str)) + + (define (accumulate-vector accumulator vec) + (accumulator #\[) + (let ((max-index (- (vector-length vec) 1))) + (let loop ((index 0)) + (accumulate-dispatch accumulator + (vector-ref vec index)) + (if (< index max-index) + (begin (accumulator #\,) (accumulator #\space) + (loop (+ index 1)))))) + (accumulator #\])) + + (define (accumulate-alist accumulator alist) + (accumulator #\{) + (let loop ((alist alist)) + (let ((kv-pair (car alist))) + (if (not (pair? kv-pair)) + (raise (make-condition &json-error + 'json-error-reason "Unbalanced alist" + 'json-invalid-token kv-pair))) + (accumulate-dispatch accumulator + (symbol->string (car kv-pair))) + (accumulator #\:) (accumulator #\space) + (accumulate-dispatch accumulator (cdr kv-pair)) + (if (not (eq? '() (cdr alist))) + (begin + (accumulator #\,) (accumulator #\space) + (loop (cdr alist)))))) + (accumulator #\})) + + (define (accumulate-dispatch accumulator obj) + (cond + ((number? obj) (accumulate-number accumulator obj)) + ((string? obj) (accumulate-string accumulator obj)) + ((boolean? obj) (accumulate-boolean accumulator obj)) + ((eq? 'null obj) (accumulate-null accumulator)) + ((vector? obj) (accumulate-vector accumulator obj)) + ((list? obj) (accumulate-alist accumulator obj)))) + + (define (json-accumulator #!optional (port-or-accumulator (current-output-port))) + (let ((accumulator (if (procedure? port-or-accumulator) + port-or-accumulator + (lambda (txt) + (if (char? txt) + (display txt port-or-accumulator) + (write txt port-or-accumulator))))) + (leading-space? #f)) + (lambda (obj) + (if leading-space? (accumulator #\space) (set! leading-space? #t)) + (accumulate-dispatch accumulator obj)))) +#+end_src + +#+name: json-accumulator-test +#+begin_src scheme :tangle tests/run.scm :noweb strip-tangle :exports none :post test-post(input=*this*) :results output + <> + <> + (test-group "JSON Accumulator" + (test "Accumulate a number" + "1234" + (with-output-to-string + (lambda () + ((json-accumulator) 1234)))) + (test "Accumulate a string" + "\"Accumulator\"" + (with-output-to-string + (lambda () + ((json-accumulator) "Accumulator")))) + (test "Accumulate a boolean" + "true" + (with-output-to-string + (lambda () + ((json-accumulator) #t)))) + (test "Accumulate an array" + "[1, 2, 3, true, null, \"Test\"]" + (with-output-to-string + (lambda () + ((json-accumulator) + #(1 2 3 #t null "Test"))))) + (test "Accumulate an alist" + "{\"a\": 1, \"b\": 2}" + (with-output-to-string + (lambda () + ((json-accumulator) + '((a . 1) (b . 2))))))) +#+end_src + +#+RESULTS: json-accumulator-test +: -- testing JSON Accumulator -------------------------------------------------- +: Accumulate a number .................................................. [ PASS] +: Accumulate a string .................................................. [ PASS] +: Accumulate a boolean ................................................. [ PASS] +: Accumulate an array .................................................. [ PASS] +: Accumulate an alist .................................................. [ PASS] +: 5 tests completed in 0.0 seconds. +: 5 out of 5 (100%) tests passed. +: -- done testing JSON Accumulator --------------------------------------------- + +*** json-write + +~(json-write obj [port-or-accumulator]) → unspecified~ + +JSON writer procedure. =PORT-OR-ACCUMULATOR= must be a textual output port, or an accumulator that accepts characters and strings. The default value of =PORT-OR-ACCUMULATOR= is the value returned by the procedure =current-output-port=. The value returned by =json-write= is unspecified. + +=json-write= will validate that =OBJ= can be serialized into JSON before writing to =PORT=. An error that satisfies =json-error?= is raised in the case where =OBJ= is not an object or a composition of the following types: + +- symbol ='null= +- boolean +- number. Must be integers or inexact rationals. (That is, they must not be complex, infinite, NaN, or exact rationals that are not integers.) +- string +- vector +- association list with keys as symbols + +#+name: json-write +#+begin_src scheme :tangle srfi-180.impl.scm :exports none :results silent + (define (json-write obj #!optional (port-or-accumulator (current-output-port))) + (let ((black-hole (make-output-port (lambda (poor-soul) #t) (lambda () #t)))) + ((json-accumulator black-hole) obj)) + ((json-accumulator port-or-accumulator) obj)) +#+end_src + +* About this egg + +#+begin_src scheme :noweb yes :tangle srfi-180.egg :exports none +;; -*- Scheme -*- +((author "Daniel Ziltener") + (synopsis "A JSON parser and printer that supports JSON bigger than memory.") + (category parsing) + (license "BSD") + (version <>) + (dependencies <>) + (test-dependencies <>) + (components + (extension srfi-180 + (csc-options "-sJ")))) +#+end_src + +#+begin_src scheme :tangle tests/run.scm :exports none :eval no +(test-exit) +#+end_src + +** Source + +The source is available at [[https://gitea.lyrion.ch/Chicken/srfi-180]]. + +** Author + +Daniel Ziltener + +** Version History + +#+name: version-history +| 1.5.0 | Reimplementation | +| 1.0.0 | Reference Implementation | + +#+name: gen-releases +#+begin_src emacs-lisp :var vers=version-history :results raw :exports none + (mapconcat (lambda (row) (concat "(release \"" (car row) "\") ;; " (cadr row))) + vers "\n") +#+end_src + +#+name: latest-release +#+begin_src emacs-lisp :var vers=version-history :exports none :results code + (caar vers) +#+end_src + +#+begin_src scheme :noweb yes :tangle srfi-180.release-info :exports none +;; -*- Scheme -*- +(repo git "https://gitea.lyrion.ch/Chicken/srfi-180.git") +(uri targz "https://gitea.lyrion.ch/Chicken/srfi-180/archive/{egg-release}.tar.gz") +<> +#+end_src + +* License + +#+begin_src fundamental :tangle LICENSE +Copyright (C) 2022 Daniel Ziltener + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +#+end_src diff --git a/srfi-180.release-info b/srfi-180.release-info index 6fd200c..2710644 100644 --- a/srfi-180.release-info +++ b/srfi-180.release-info @@ -1,3 +1,4 @@ -(repo git "https://gitea.lyrion.ch/zilti/srfi-180.git") -(uri targz "https://gitea.lyrion.ch/zilti/srfi-180/archive/{egg-release}.tar.gz") -(release "1.0.0") +;; -*- Scheme -*- +(repo git "https://gitea.lyrion.ch/Chicken/srfi-180.git") +(uri targz "https://gitea.lyrion.ch/Chicken/srfi-180/archive/{egg-release}.tar.gz") +(release "1.0.0") ;; Reference Implementation diff --git a/srfi-180.scm b/srfi-180.scm index a30dcdc..1932100 100644 --- a/srfi-180.scm +++ b/srfi-180.scm @@ -1,24 +1,17 @@ -(import (r7rs)) - -(define-library (srfi 180) - (import (scheme base) - (scheme inexact) - (scheme case-lambda) - (scheme char) - (scheme write) - (srfi 180 helpers) - (srfi 145) - (only (srfi 60) arithmetic-shift bitwise-ior)) - (export json-number-of-character-limit - json-nesting-depth-limit - json-null? - json-error? - json-error-reason - json-fold - json-generator - json-read - json-lines-read - json-sequence-read - json-accumulator - json-write) - (include "srfi.180-impl.scm")) +(module (srfi 180) + (&json-error + json-error? + json-error-reason + json-invalid-token + json-nesting-depth-limit + json-number-of-character-limit + json-generator + json-null? + json-fold + json-read + json-lines-read + json-sequence-read + json-accumulator + json-write) + (import (chicken base)) + (include-relative "srfi-180.impl.scm")) diff --git a/srfi.180-impl.scm b/srfi.180-impl.scm deleted file mode 100644 index ac565ec..0000000 --- a/srfi.180-impl.scm +++ /dev/null @@ -1,750 +0,0 @@ -(define (pk . args) - (write args) - (newline) - (car (reverse args))) - -(define json-number-of-character-limit (make-parameter +inf.0)) - -(define json-nesting-depth-limit (make-parameter +inf.0)) - -(define (json-null? obj) - (eq? obj 'null)) - -(define-record-type - (make-json-error reason) - json-error? - (reason json-error-reason)) - -(define (json-whitespace? char) - (case char - ((#\x20 ; Space - #\x09 ; Horizontal tab - #\x0A ; Line feed or New line - #\x0D - #\x1E ;; Record Separator - ) - #t) - (else #f))) - -(define (expect value other) - (when (eof-object? value) - (raise (make-json-error "Unexpected end-of-file."))) - (assume (and (char? value) (char? other)) "invalid argument" '%json-tokens expect value other) - (unless (char=? value other) - (raise (make-json-error "Unexpected character.")))) - -(define (port->generator port) - (let ((count 0) - (limit (json-number-of-character-limit))) - (lambda () - (let ((out (guard (ex ((read-error? ex) (raise (make-json-error "Read error!")))) - (read-char port)))) - (if (= count limit) - (raise (make-json-error "Maximum number of character reached.")) - (begin - (set! count (+ count 1)) - out)))))) - -(define (gcons head generator) - ;; returns a generator that will yield, HEAD the first time, and - ;; after than, it will yield items from GENERATOR. - (let ((head? #t)) - (lambda () - (if head? - (begin (set! head? #f) head) - (generator))))) - -(define (%json-tokens generator) - - (define (maybe-ignore-whitespace generator) - (let loop ((char (generator))) - (if (json-whitespace? char) - (loop (generator)) - char))) - - (define (expect-null generator) - (expect (generator) #\u) - (expect (generator) #\l) - (expect (generator) #\l)) - - (define (expect-true generator) - (expect (generator) #\r) - (expect (generator) #\u) - (expect (generator) #\e)) - - (define (expect-false generator) - (expect (generator) #\a) - (expect (generator) #\l) - (expect (generator) #\s) - (expect (generator) #\e)) - - (define (maybe-char generator) - (let ((char (generator))) - (when (eof-object? char) - (raise (make-json-error "Unexpected end-of-file."))) - (when (char=? char #\") - (raise (make-json-error "Unexpected end of string."))) - char)) - - (define (read-unicode-escape generator) - (let* ((one (maybe-char generator)) - (two (maybe-char generator)) - (three (maybe-char generator)) - (four (maybe-char generator))) - (let ((out (string->number (list->string (list one two three four)) 16))) - (if out - out - (raise (make-json-error "Invalid code point.")))))) - - (define ash arithmetic-shift) - - (define (read-json-string generator) - (let loop ((char (generator)) - (out '())) - - (when (eof-object? char) - (raise (make-json-error "Unexpected end of file."))) - - (when (or (char=? char #\x00) - (char=? char #\newline) - (char=? char #\tab)) - (raise (make-json-error "Unescaped control char."))) - - ;; XXX: Here be dragons. - (if (char=? char #\\) - (begin - (let loop-unescape ((char (generator)) - (chars-unescaped '())) - (case char - ((#\" #\\ #\/) (loop (generator) - (cons char (append chars-unescaped - out)))) - ((#\b) (loop (generator) (cons #\backspace - (append chars-unescaped - out)))) - ((#\f) (loop (generator) (cons #\x0C - (append chars-unescaped - out)))) - ((#\n) (loop (generator) (cons #\newline - (append chars-unescaped - out)))) - ((#\r) (loop (generator) (cons #\x0D - (append chars-unescaped - out)))) - ((#\t) (loop (generator) (cons #\tab - (append chars-unescaped - out)))) - ((#\u) (let loop-unicode ((code1 (read-unicode-escape generator)) - (chars chars-unescaped)) - (let ((next-char (generator))) - (if (and (<= #xd800 code1 #xdbff) - (char=? next-char #\\)) - (if (char=? (generator) #\u) - (let ((code2 (read-unicode-escape generator))) - (if (<= #xdc00 code2 #xdfff) - (let ((integer - (+ #x10000 (bitwise-ior - (ash (- code1 #xd800) 10) - (- code2 #xdc00))))) - ;; full escape of unicode is parsed... - (loop (generator) - (cons (integer->char integer) - (append chars - out)))) - ;; This is another unicode char - (loop-unicode (read-unicode-escape generator) - (cons (integer->char code1) chars)))) - ;; The escaped unicode char is - ;; parsed, need to parse another - ;; escape that is not a unicode - ;; escape sequence - (loop-unescape char (cons (integer->char code1) - chars))) - ;; This is not a big-ish unicode char and - ;; the next thing is some other char. - (loop next-char - (cons (integer->char code1) (append chars out))))))) - (else (raise (make-json-error "Unexpected escaped sequence.")))))) - (cond - ((char=? char #\") - (list->string (reverse out))) - (else - (loop (generator) (cons char out))))))) - - (define (maybe-read-number generator) - ;; accumulate chars until a control char or whitespace is reached, - ;; validate that it is JSON number, then intrepret it as Scheme - ;; number using string->number - (let loop ((char (generator)) - (out '())) - (if (or (eof-object? char) - (json-whitespace? char) - (char=? char #\,) - (char=? char #\]) - (char=? char #\})) - (let ((string (list->string (reverse out)))) - (if (valid-number? string) - (let ((number (string->number string))) - (if number - (values number char) - (raise (make-json-error "Invalid number.")))) - (raise (make-json-error "Invalid number.")))) - (loop (generator) (cons char out))))) - - ;; gist - (assume (procedure? generator) "invalid argument" generator) - - (let ((char (generator))) - (if (eof-object? char) - eof-object ;; return an empty generator - (begin - - (unless (char=? char #\xFEFF) - ;; if it is not a UTF-8 BOM, put back the char in front of - ;; the generator - (set! generator (gcons char generator))) - - (lambda () - - (define char (maybe-ignore-whitespace generator)) - - (if (eof-object? char) - char ;; return that eof-object - (case char - ((#\n) (expect-null generator) 'null) - ((#\t) (expect-true generator) #t) - ((#\f) (expect-false generator) #f) - ((#\:) 'colon) - ((#\,) 'comma) - ((#\[) 'array-start) - ((#\]) 'array-end) - ((#\{) 'object-start) - ((#\}) 'object-end) - ((#\") (read-json-string generator)) - (else - (call-with-values (lambda () (maybe-read-number (gcons char generator))) - (lambda (number next) - (set! generator (gcons next generator)) - number)))))))))) - -(define json-tokens - (case-lambda - (() (json-tokens (current-input-port))) - ((port-or-generator) - (cond - ((procedure? port-or-generator) - (%json-tokens port-or-generator)) - ((and (textual-port? port-or-generator) (input-port? port-or-generator)) - (%json-generator (port->generator port-or-generator))) - (else (error 'json "json-tokens error, argument is not valid" port-or-generator)))))) - -(define (%json-generator tokens) - - (define limit (json-nesting-depth-limit)) - (define count 0) - - (define (handle-limit!) - (if (= count limit) - (raise (make-json-error "Maximum JSON nesting depth reached")) - (set! count (+ count 1)))) - - (define (array-maybe-continue tokens k) - (lambda () - (let ((token (tokens))) - (case token - ((comma) (start tokens (array-maybe-continue tokens k))) - ((array-end) (values 'array-end k)) - (else (raise (make-json-error "Invalid array, expected comma or array close."))))))) - - (define (array-start tokens k) - (lambda () - (handle-limit!) - (let ((token (tokens))) - (if (eq? token 'array-end) - (values 'array-end k) - (start (gcons token tokens) (array-maybe-continue tokens k)))))) - - (define (object-maybe-continue tokens k) - (lambda () - (let ((token (tokens))) - (case token - ((object-end) (values 'object-end k)) - ((comma) (let ((token (tokens))) - (unless (string? token) - (raise (make-json-error "Invalid object, expected an object key"))) - (values token - (object-colon tokens k)))) - (else (raise (make-json-error "Invalid object, expected comma or object close."))))))) - - (define (object-colon tokens k) - (lambda () - (let ((token (tokens))) - (if (eq? token 'colon) - (let ((token (tokens))) - (if (eof-object? token) - (raise (make-json-error "Invalid object, expected object value.")) - (start (gcons token tokens) (object-maybe-continue tokens k)))) - (raise (make-json-error "Invalid object, expected colon.")))))) - - (define (object-start tokens k) - (lambda () - (handle-limit!) - (let ((token (tokens))) - (cond - ((eq? token 'object-end) (values 'object-end k)) - ((string? token) - (values token - (object-colon tokens k))) - (else (raise (make-json-error "Invalid object, expected object key or object close."))))))) - - (define (start tokens k) - (let ((token (tokens))) - (if (eof-object? token) - (values token k) - (cond - ((or (json-null? token) - (number? token) - (string? token) - (boolean? token)) - (values token k)) - ((eq? token 'array-start) - (values 'array-start (array-start tokens k))) - ((eq? token 'object-start) - (values 'object-start (object-start tokens k))) - (else (raise (make-json-error "Is it JSON text?!"))))))) - - (define (end-of-top-level-value) - ;; json-generator returns a generator that reads one top-level - ;; json. If there is more than one top-level json value in the - ;; generator separated with space as it is the case of json-lines, - ;; you need to call json-generator with the same port or - ;; generator. - (values (eof-object) #f)) - - (define (make-trampoline-generator tokens) - (let ((continuation (lambda () (start tokens end-of-top-level-value)))) - (lambda () - (when continuation - (call-with-values continuation - (lambda (event new-continuation) - (set! continuation new-continuation) - event)))))) - - ;; gist - - (assume (procedure? tokens) "invalid argument" %json-generator tokens) - - (make-trampoline-generator tokens)) - -(define json-generator-error - "Argument does not look like a generator and is not a textual input port.") - -(define json-generator - (case-lambda - (() (json-generator (current-input-port))) - ((port) - (%json-generator (json-tokens (port->generator port)))))) - -;; XXX: procedure foldts is not used as-is. It was copied here for -;; documentation purpose (public domain, by Oleg Kiselyov). -(define (foldts fdown fup fhere seed tree) - ;; - fhere is applied to the leafs of the tree - ;; - ;; - fdown is invoked when a non-leaf node is entered before any of - ;; the node's children are visited. fdown action has to generate a - ;; seed to be passed to the first visited child of the node. - ;; - ;; - fup is invoked after all the children of a node have been - ;; seen. The first argument is the local state at the moment the - ;; traversal process enters the branch rooted at the current node. The - ;; second argument is the result of visiting all child branches. The - ;; action of fup isto produce a seed that is taken to be the state of - ;; the traversal after the process leave the currents the current - ;; branch. - (cond - ((null? tree) seed) - ((not (pair? tree)) ; An atom - (fhere seed tree)) - (else - (let loop ((kid-seed (fdown seed tree)) - (kids (cdr tree))) - (if (null? kids) - (fup seed kid-seed tree) - (loop (foldts fdown fup fhere kid-seed (car kids)) - (cdr kids))))))) - -(define (%json-fold proc array-start array-end object-start object-end seed port-or-generator) - - ;; json-fold is inspired from the above foldts definition, unlike - ;; the above definition, it is continuation-passing-style. fhere is - ;; renamed PROC. Unlike foldts, json-fold will call (proc obj seed) - ;; everytime a JSON value or complete structure is read from the - ;; EVENTS generator, where OBJ will be: a) In the case of - ;; structures, the the result of the recursive call or b) a JSON - ;; value. - - ;; json-fold will terminates in three cases: - ;; - ;; - eof-object was generated, return the seed. - ;; - ;; - event-type 'array-end is generated, if EVENTS is returned by - ;; json-generator, it means a complete array was read. - ;; - ;; - event-type 'object-end is generated, similarly, if EVENTS is - ;; returned by json-generator, it means complete array was - ;; read. - ;; - ;; IF EVENTS does not follow the json-generator protocol, the - ;; behavior is unspecified. - - (define events (json-generator port-or-generator)) - - (define (ruse seed k) - (lambda () - (let loop ((seed seed)) - (let ((event (events))) - (if (eof-object? event) - (begin (k seed) #f) - (case event - ;; termination cases - ((array-end) (k seed)) - ((object-end) (k seed)) - ;; recursion - ((array-start) (ruse (array-start seed) - (lambda (out) (loop (proc (array-end out) seed))))) - ((object-start) (ruse (object-start seed) - (lambda (out) (loop (proc (object-end out) seed))))) - (else (loop (proc event seed))))))))) - - (define (make-trampoline-fold k) - (let ((thunk (ruse seed k))) - (let loop ((thunk thunk)) - (when thunk - (loop (thunk)))))) - - (define %unset '(unset)) - - (let ((out %unset)) - (define (escape out*) - (set! out out*) - #f) - (make-trampoline-fold escape) - (if (eq? out %unset) - (error 'json "Is this JSON text") - out))) - -(define json-fold - (case-lambda - ((proc array-start array-end object-start object-end seed) - (json-fold proc array-start array-end object-start object-end seed (current-input-port))) - ((proc array-start array-end object-start object-end seed port-or-generator) - (%json-fold proc array-start array-end object-start object-end seed port-or-generator)))) - -(define (%json-read port-or-generator) - - (define %root '(root)) - - (define (array-start seed) - ;; array will be read as a list, then converted into a vector in - ;; array-end. - '()) - - (define (array-end items) - (list->vector (reverse items))) - - (define (object-start seed) - ;; object will be read as a property list, then converted into an - ;; alist in object-end. - '()) - - (define (plist->alist plist) - ;; PLIST is a list of even items, otherwise json-generator - ;; would have raised a json-error. - (let loop ((plist plist) - (out '())) - (if (null? plist) - out - (loop (cddr plist) (cons (cons (string->symbol (cadr plist)) (car plist)) out))))) - - (define object-end plist->alist) - - (define (proc obj seed) - ;; proc is called when a JSON value or structure was completly - ;; read. The parse result is passed as OBJ. In the case where - ;; what is parsed is a JSON simple json value then OBJ is simply - ;; the token that is read that can be 'null, a number or a string. - ;; In the case where what is parsed is a JSON structure, OBJ is - ;; what is returned by OBJECT-END or ARRAY-END. - (if (eq? seed %root) - ;; It is toplevel, a complete JSON value or structure was read, - ;; return it. - obj - ;; This is not toplevel, hence json-fold is called recursivly, - ;; to parse an array or object. Both ARRAY-START and - ;; OBJECT-START return an empty list as a seed to serve as an - ;; accumulator. Both OBJECT-END and ARRAY-END expect a list - ;; as argument. - (cons obj seed))) - - (let ((out (json-fold proc - array-start - array-end - object-start - object-end - %root - port-or-generator))) - ;; if out is the root object, then the port or generator is empty. - (if (eq? out %root) - (eof-object) - out))) - -(define json-read - (case-lambda - (() (json-read (current-input-port))) - ((port-or-generator) (%json-read port-or-generator)))) - -;; json-lines-read - -(define json-lines-read - (case-lambda - (() (json-lines-read (current-input-port))) - ((port-or-generator) - (lambda () - (json-read port-or-generator))))) - -;; json-sequence-read - -(define json-sequence-read - (case-lambda - (() (json-sequence-read (current-input-port))) - ((port-or-generator) - (lambda () - (let loop () - (guard (ex ((json-error? ex) (loop))) - (json-read port-or-generator))))))) - -;; write procedures - -(define (json-accumulator accumulator) - - (define (write-json-char char accumulator) - (case char - ((#\x00) (accumulator "\\u0000")) - ((#\") (accumulator "\\\"")) - ((#\\) (accumulator "\\\\")) - ((#\/) (accumulator "\\/")) - ((#\return) (accumulator "\\r")) - ((#\newline) (accumulator "\\n")) - ((#\tab) (accumulator "\\t")) - ((#\backspace) (accumulator "\\b")) - ((#\x0c) (accumulator "\\f")) - (else (accumulator char)))) - - (define (write-json-string string accumulator) - (accumulator #\") - (string-for-each - (lambda (char) (write-json-char char accumulator)) - string) - (accumulator #\")) - - (define (write-json-value obj accumulator) - (cond - ((eq? obj 'null) (accumulator "null")) - ((boolean? obj) (if obj - (accumulator "true") - (accumulator "false"))) - ((string? obj) (write-json-string obj accumulator)) - ((number? obj) (accumulator (number->string obj))) - (else (raise (make-json-error "Invalid json value."))))) - - (define (raise-invalid-event event) - (raise event)) - ;;(raise (make-json-error "json-accumulator: invalid event."))) - - (define (object-start k) - (lambda (accumulator event) - (accumulator #\{) - (case (car event) - ((json-value) - (let ((key (cdr event))) - (unless (symbol? key) (raise-invalid-event event)) - (write-json-string (symbol->string key) accumulator) - (object-value k))) - ((json-structure) - (case (cdr event) - ((object-end) - (accumulator #\}) - k) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (object-value k) - (lambda (accumulator event) - (accumulator #\:) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - (object-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-start) - (array-start (object-maybe-continue k))) - ((object-start) - (object-start (object-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (object-maybe-continue k) - (lambda (accumulator event) - (case (car event) - ((json-value) - (accumulator #\,) - (let ((key (cdr event))) - (unless (symbol? key) (raise-invalid-event event)) - (write-json-value (symbol->string key) accumulator) - (object-value k))) - ((json-structure) - (case (cdr event) - ((object-end) - (accumulator #\}) - k) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (array-start k) - (lambda (accumulator event) - (accumulator #\[) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - (array-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-end) - (accumulator #\]) - k) - ((array-start) (array-start (array-maybe-continue k))) - ((object-start) (object-start (array-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (array-maybe-continue k) - (lambda (accumulator event) - (case (car event) - ((json-value) - (accumulator #\,) - (write-json-value (cdr event) accumulator) - (array-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-end) - (accumulator #\]) - k) - ((array-start) - (accumulator #\,) - (array-start (array-maybe-continue k))) - ((object-start) - (accumulator #\,) - (object-start (array-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (start accumulator event) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - raise-invalid-event) - ((json-structure) - (case (cdr event) - ((array-start) - (array-start raise-invalid-event)) - ((object-start) - (object-start raise-invalid-event)) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event)))) - - (assume (procedure? accumulator) - "ACCUMULATOR does look like a valid accumulator.") - - (let ((k start)) - (lambda (event) - (set! k (k accumulator event))))) - -(define (%json-write obj accumulator) - - (define (void) - (if #f #f)) - - (define (raise-unless-valid? obj) - (cond - ((null? obj) (void)) - ((eq? obj 'null) (void)) - ((boolean? obj) (void)) - ((string? obj) (void)) - ((and (number? obj) - (not (infinite? obj)) - (not (nan? obj)) - (real? obj) - (or (and (exact? obj) (= (denominator obj) 1)) - (inexact? obj))) - (void)) - ((vector? obj) - (vector-for-each (lambda (obj) (raise-unless-valid? obj)) obj)) - ;; XXX: use pair? then recursively check the tail. - ((pair? obj) - (for-each (lambda (obj) - (unless (pair? obj) - (raise (make-json-error "Unexpected object, not a pair."))) - (unless (symbol? (car obj)) - (raise (make-json-error "Unexpected object, not a symbol key."))) - (raise-unless-valid? (cdr obj))) - obj)) - (else (raise (make-json-error "Unexpected object"))))) - - (define (write obj accumulator) - (cond - ((or (eq? obj 'null) - (boolean? obj) - (string? obj) - (symbol? obj) - (number? obj)) - (accumulator (cons 'json-value obj))) - ((vector? obj) - (accumulator '(json-structure . array-start)) - (vector-for-each (lambda (obj) (write obj accumulator)) obj) - (accumulator '(json-structure . array-end))) - ((null? obj) - (accumulator '(json-structure . object-start)) - (accumulator '(json-structure . object-end))) - ((pair? obj) - (accumulator '(json-structure . object-start)) - (for-each (lambda (pair) - (write (car pair) accumulator) - (write (cdr pair) accumulator)) - obj) - (accumulator '(json-structure . object-end))) - (else (error "Unexpected error!")))) - - (assume (procedure? accumulator) - "ACCUMULATOR does look like a valid accumulator.") - (raise-unless-valid? obj) - (write obj (json-accumulator accumulator))) - -(define (port->accumulator port) - (lambda (char-or-string) - (cond - ((char? char-or-string) (write-char char-or-string port)) - ((string? char-or-string) (write-string char-or-string port)) - (else (raise (make-json-error "Not a char or string")))))) - -(define json-write - (case-lambda - ((obj) (json-write obj (current-output-port))) - ((obj port-or-accumulator) - (assume (or (procedure? port-or-accumulator) - (and (textual-port? port-or-accumulator) - (output-port? port-or-accumulator))) - "ACCUMULATOR does look like a valid accumulator.") - (if (procedure? port-or-accumulator) - (%json-write obj port-or-accumulator) - (%json-write obj (port->accumulator port-or-accumulator)))))) diff --git a/srfi.180.checks.scm b/srfi.180.checks.scm deleted file mode 100644 index 9270f3f..0000000 --- a/srfi.180.checks.scm +++ /dev/null @@ -1,1646 +0,0 @@ -(define-library (srfi 180 checks) - - (export i_number_double_huge_neg_exp.json - i_number_huge_exp.json - i_number_neg_int_huge_exp.json - i_number_pos_double_huge_exp.json - i_number_real_neg_overflow.json - i_number_real_pos_overflow.json - i_number_real_underflow.json - i_number_too_big_neg_int.json - i_number_too_big_pos_int.json - i_number_very_big_negative_int.json - i_object_key_lone_2nd_surrogate.json - i_string_1st_surrogate_but_2nd_missing.json - i_string_1st_valid_surrogate_2nd_invalid.json - i_string_incomplete_surrogate_and_escape_valid.json - i_string_incomplete_surrogate_pair.json - i_string_incomplete_surrogates_escape_valid.json - i_string_invalid_lonely_surrogate.json - i_string_invalid_surrogate.json - i_string_invalid_utf-8.json - i_string_inverted_surrogates_U+1D11E.json - i_string_iso_latin_1.json - i_string_lone_second_surrogate.json - i_string_lone_utf8_continuation_byte.json - i_string_not_in_unicode_range.json - i_string_overlong_sequence_2_bytes.json - i_string_overlong_sequence_6_bytes.json - i_string_overlong_sequence_6_bytes_null.json - i_string_truncated-utf-8.json - i_string_utf16BE_no_BOM.json - i_string_utf16LE_no_BOM.json - i_string_UTF-16LE_with_BOM.json - i_string_UTF-8_invalid_sequence.json - i_string_UTF8_surrogate_U+D800.json - i_structure_500_nested_arrays.json - i_structure_UTF-8_BOM_empty_object.json - n_boolean_not_true.json - n_boolean_not_false.json - n_not_null.json - n_array_1_true_without_comma.json - n_array_a_invalid_utf8.json - n_array_colon_instead_of_comma.json - n_array_comma_after_close.json - n_array_comma_and_number.json - n_array_double_comma.json - n_array_double_extra_comma.json - n_array_extra_close.json - n_array_extra_comma.json - n_array_incomplete_invalid_value.json - n_array_incomplete.json - n_array_inner_array_no_comma.json - n_array_invalid_utf8.json - n_array_items_separated_by_semicolon.json - n_array_just_comma.json - n_array_just_minus.json - n_array_missing_value.json - n_array_newlines_unclosed.json - n_array_number_and_comma.json - n_array_number_and_several_commas.json - n_array_spaces_vertical_tab_formfeed.json - n_array_star_inside.json - n_array_unclosed.json - n_array_unclosed_trailing_comma.json - n_array_unclosed_with_new_lines.json - n_array_unclosed_with_object_inside.json - n_incomplete_false.json - n_incomplete_null.json - n_incomplete_true.json - n_multidigit_number_then_00.json - n_number_0.1.2.json - n_number_-01.json - n_number_0.3e.json - n_number_0.3e+.json - n_number_0_capital_E.json - n_number_0_capital_E+.json - n_number_0.e1.json - n_number_0e.json - n_number_0e+.json - n_number_1_000.json - n_number_1.0e-.json - n_number_1.0e.json - n_number_1.0e+.json - n_number_-1.0..json - n_number_1eE2.json - n_number_.-1.json - n_number_+1.json - n_number_.2e-3.json - n_number_2.e-3.json - n_number_2.e+3.json - n_number_2.e3.json - n_number_-2..json - n_number_9.e+.json - n_number_expression.json - n_number_hex_1_digit.json - n_number_hex_2_digits.json - n_number_infinity.json - n_number_+Inf.json - n_number_Inf.json - n_number_invalid+-.json - n_number_invalid-negative-real.json - n_number_invalid-utf-8-in-bigger-int.json - n_number_invalid-utf-8-in-exponent.json - n_number_invalid-utf-8-in-int.json - n_number_++.json - n_number_minus_infinity.json - n_number_minus_sign_with_trailing_garbage.json - n_number_minus_space_1.json - n_number_-NaN.json - n_number_NaN.json - n_number_neg_int_starting_with_zero.json - n_number_neg_real_without_int_part.json - n_number_neg_with_garbage_at_end.json - n_number_real_garbage_after_e.json - n_number_real_with_invalid_utf8_after_e.json - n_number_real_without_fractional_part.json - n_number_starting_with_dot.json - n_number_U+FF11_fullwidth_digit_one.json - n_number_with_alpha_char.json - n_number_with_alpha.json - n_number_with_leading_zero.json - n_object_bad_value.json - n_object_bracket_key.json - n_object_comma_instead_of_colon.json - n_object_double_colon.json - n_object_emoji.json - n_object_garbage_at_end.json - n_object_key_with_single_quotes.json - n_object_lone_continuation_byte_in_key_and_trailing_comma.json - n_object_missing_colon.json - n_object_missing_key.json - n_object_missing_semicolon.json - n_object_missing_value.json - n_object_no-colon.json - n_object_non_string_key_but_huge_number_instead.json - n_object_non_string_key.json - n_object_repeated_null_null.json - n_object_several_trailing_commas.json - n_object_single_quote.json - n_object_trailing_comma.json - n_object_trailing_comment.json - n_object_trailing_comment_open.json - n_object_trailing_comment_slash_open_incomplete.json - n_object_trailing_comment_slash_open.json - n_object_two_commas_in_a_row.json - n_object_unquoted_key.json - n_object_unterminated-value.json - n_object_with_single_string.json - n_object_with_trailing_garbage.json - n_single_space.json - n_string_1_surrogate_then_escape.json - n_string_1_surrogate_then_escape_u1.json - n_string_1_surrogate_then_escape_u1x.json - n_string_1_surrogate_then_escape_u.json - n_string_accentuated_char_no_quotes.json - n_string_backslash_00.json - n_string_escaped_backslash_bad.json - n_string_escaped_ctrl_char_tab.json - n_string_escaped_emoji.json - n_string_escape_x.json - n_string_incomplete_escaped_character.json - n_string_incomplete_escape.json - n_string_incomplete_surrogate_escape_invalid.json - n_string_incomplete_surrogate.json - n_string_invalid_backslash_esc.json - n_string_invalid_unicode_escape.json - n_string_invalid_utf8_after_escape.json - n_string_invalid-utf-8-in-escape.json - n_string_leading_uescaped_thinspace.json - n_string_no_quotes_with_bad_escape.json - n_string_single_doublequote.json - n_string_single_quote.json - n_string_single_string_no_double_quotes.json - n_string_start_escape_unclosed.json - n_string_unescaped_crtl_char.json - n_string_unescaped_newline.json - n_string_unescaped_tab.json - n_string_unicode_CapitalU.json - n_string_with_trailing_garbage.json - n_structure_100000_opening_arrays.json - n_structure_angle_bracket_..json - n_structure_angle_bracket_null.json - n_structure_array_trailing_garbage.json - n_structure_array_with_extra_array_close.json - n_structure_array_with_unclosed_string.json - n_structure_ascii-unicode-identifier.json - n_structure_capitalized_True.json - n_structure_close_unopened_array.json - n_structure_comma_instead_of_closing_brace.json - n_structure_double_array.json - n_structure_end_array.json - n_structure_incomplete_UTF8_BOM.json - n_structure_lone-invalid-utf-8.json - n_structure_lone-open-bracket.json - n_structure_no_data.json - n_structure_null-byte-outside-string.json - n_structure_number_with_trailing_garbage.json - n_structure_object_followed_by_closing_object.json - n_structure_object_unclosed_no_value.json - n_structure_object_with_comment.json - n_structure_object_with_trailing_garbage.json - n_structure_open_array_apostrophe.json - n_structure_open_array_comma.json - n_structure_open_array_object.json - n_structure_open_array_open_object.json - n_structure_open_array_open_string.json - n_structure_open_array_string.json - n_structure_open_object_close_array.json - n_structure_open_object_comma.json - n_structure_open_object.json - n_structure_open_object_open_array.json - n_structure_open_object_open_string.json - n_structure_open_object_string_with_apostrophes.json - n_structure_open_open.json - n_structure_single_eacute.json - n_structure_single_star.json - n_structure_trailing_sharp.json - n_structure_U+2060_word_joined.json - n_structure_uescaped_LF_before_string.json - n_structure_unclosed_array.json - n_structure_unclosed_array_partial_null.json - n_structure_unclosed_array_unfinished_false.json - n_structure_unclosed_array_unfinished_true.json - n_structure_unclosed_object.json - n_structure_unicode-identifier.json - n_structure_UTF8_BOM_no_data.json - n_structure_whitespace_formfeed.json - n_structure_whitespace_U+2060_word_joiner.json - y_array_arraysWithSpaces.json - y_array_empty.json - y_array_empty-string.json - y_array_ending_with_newline.json - y_array_false.json - y_array_heterogeneous.json - y_array_null.json - y_array_with_1_and_newline.json - y_array_with_leading_space.json - y_array_with_several_null.json - y_array_with_trailing_space.json - y_number_0e+1.json - y_number_0e1.json - y_number_after_space.json - y_number_double_close_to_zero.json - y_number_int_with_exp.json - y_number.json - y_number_minus_zero.json - y_number_negative_int.json - y_number_negative_one.json - y_number_negative_zero.json - y_number_real_capital_e.json - y_number_real_capital_e_neg_exp.json - y_number_real_capital_e_pos_exp.json - y_number_real_exponent.json - y_number_real_fraction_exponent.json - y_number_real_neg_exp.json - y_number_real_pos_exponent.json - y_number_simple_int.json - y_number_simple_real.json - y_object_basic.json - y_object_duplicated_key_and_value.json - y_object_duplicated_key.json - y_object_empty.json - y_object_empty_key.json - y_object_escaped_null_in_key.json - y_object_extreme_numbers.json - y_object.json - y_object_long_strings.json - y_object_simple.json - y_object_string_unicode.json - y_object_with_newlines.json - y_string_1_2_3_bytes_UTF-8_sequences.json - y_string_accepted_surrogate_pair.json - y_string_accepted_surrogate_pairs.json - y_string_allowed_escapes.json - y_string_backslash_and_u_escaped_zero.json - y_string_backslash_doublequotes.json - y_string_comments.json - y_string_double_escape_a.json - y_string_double_escape_n.json - y_string_escaped_control_character.json - y_string_escaped_noncharacter.json - y_string_in_array.json - y_string_in_array_with_leading_space.json - y_string_last_surrogates_1_and_2.json - y_string_nbsp_uescaped.json - y_string_nonCharacterInUTF-8_U+10FFFF.json - y_string_nonCharacterInUTF-8_U+FFFF.json - y_string_null_escape.json - y_string_one-byte-utf-8.json - y_string_pi.json - y_string_reservedCharacterInUTF-8_U+1BFFF.json - y_string_simple_ascii.json - y_string_space.json - y_string_surrogates_U+1D11E_MUSICAL_SYMBOL_G_CLEF.json - y_string_three-byte-utf-8.json - y_string_two-byte-utf-8.json - y_string_u+2028_line_sep.json - y_string_u+2029_par_sep.json - y_string_uescaped_newline.json - y_string_uEscape.json - y_string_unescaped_char_delete.json - y_string_unicode_2.json - y_string_unicodeEscapedBackslash.json - y_string_unicode_escaped_double_quote.json - y_string_unicode.json - y_string_unicode_U+10FFFE_nonchar.json - y_string_unicode_U+1FFFE_nonchar.json - y_string_unicode_U+200B_ZERO_WIDTH_SPACE.json - y_string_unicode_U+2064_invisible_plus.json - y_string_unicode_U+FDD0_nonchar.json - y_string_unicode_U+FFFE_nonchar.json - y_string_utf8.json - y_string_with_del_character.json - y_structure_lonely_false.json - y_structure_lonely_int.json - y_structure_lonely_negative_real.json - y_structure_lonely_null.json - y_structure_lonely_string.json - y_structure_lonely_true.json - y_structure_string_empty.json - y_structure_trailing_newline.json - y_structure_true_in_array.json - y_structure_whitespace_array.json - ;; other tests - y_object_nested.json - ;; scheme specific - n_+inf.0 - n_-inf.0 - n_complex - n_-nan.0 - n_+nan.0 - n_exact_not_integer - y_json_lines_numbers - y_json_lines_arrays - y_json_lines_objects - character-limit - nesting-limit - parse-into-records - y_foundationdb_status.json - sample-crlf-line-separators.jsonl - sample-no-eol-at-eof.jsonl - sample.jsonl - ;; json-sequence - json-sequence.log - json-sequence-with-one-broken-json.log - ;; others - json-generator-single-top-level-value - json-generator-single-top-level-value-structure - ) - - (import (scheme base)) - (import (scheme read)) - (import (scheme write)) - (import (scheme file)) - (import (srfi 121)) - (import (srfi 180)) - #;(import (scheme generator)) - - (begin - - (define (pk . args) ;; peek stuff, debug helper. - (write args (current-error-port)) - (display #\newline (current-error-port)) - (flush-output-port (current-error-port)) - (car (reverse args))) - - (define-syntax define-syntax-rule - (syntax-rules () - ((define-syntax-rule (keyword args ...) body) - (define-syntax keyword - (syntax-rules () - ((keyword args ...) body)))))) - - (define-syntax-rule (check expected actual) - (lambda () - (let ((expected* expected)) - (guard (ex (else (vector #f 'exception-raised expected* ex))) - (let ((actual* actual)) - (if (equal? expected* actual*) - (vector #t) - (vector #f 'unexpected-result expected* actual*))))))) - - (define-syntax-rule (check-raise predicate? actual) - (lambda () - (let ((predicate?* predicate?)) - (guard (ex ((predicate?* ex) (vector #t)) - (else (vector #f 'unexpected-exception predicate?* ex))) - (let ((actual* actual)) - (vector #f 'no-exception predicate?* actual*)))))) - - (define-syntax-rule (skip test expected actual) - (lambda () - (vector #t))) - - (define (success? v) - (vector-ref v 0)) - - (define (failure? v) - (not (success? v))) - - (define (failure-expected v) - (vector-ref v 1)) - - (define (failure-actual v) - (vector-ref v 2)) - - (define (call-with-input-string string proc) - (call-with-port (open-input-string string) proc)) - - (define (call-with-output-string proc) - (let ((port (open-output-string))) - (proc port) - (let ((string (get-output-string port))) - (close-port port) - string))) - - (define (json->obj->json->obj filepath) - (call-with-input-string - (call-with-output-string - (lambda (port) - (json-write (call-with-input-file filepath json-read) port))) - (lambda (port) - (json-read port)))) - - (define (json-string->obj string) - (call-with-input-string string json-read)) - - (define (obj->json-string obj) - (call-with-output-string (lambda (port) (json-write obj)))) - - (define parse json->obj->json->obj) - - (define i_number_double_huge_neg_exp.json - (check #(0.0) (parse "./files/i_number_double_huge_neg_exp.json"))) - - (define i_number_huge_exp.json - (check #(0.4) (parse "./files/i_number_huge_exp.json"))) - - (define i_number_neg_int_huge_exp.json - (check-raise json-error? (parse "./files/i_number_neg_int_huge_exp.json"))) - - (define i_number_pos_double_huge_exp.json - (check-raise json-error? (parse "./files/i_number_pos_double_huge_exp.json"))) - - (define i_number_real_neg_overflow.json - (check-raise json-error? (parse "./files/i_number_real_neg_overflow.json"))) - - (define i_number_real_pos_overflow.json - (check-raise json-error? (parse "./files/i_number_real_pos_overflow.json"))) - - (define i_number_real_underflow.json - (check #(0.0) (parse "./files/i_number_real_underflow.json"))) - - (define i_number_too_big_neg_int.json - (check #(-123123123123123123123123123123) - (parse "./files/i_number_too_big_neg_int.json"))) - - (define i_number_too_big_pos_int.json - (check #(100000000000000000000) - (parse "./files/i_number_too_big_pos_int.json"))) - - (define i_number_very_big_negative_int.json - (check #(-237462374673276894279832749832423479823246327846) - (parse "./files/i_number_very_big_negative_int.json"))) - - (define i_object_key_lone_2nd_surrogate.json - (skip check '((|���| . 0)) (parse "./files/i_object_key_lone_2nd_surrogate.json"))) - - (define i_string_1st_surrogate_but_2nd_missing.json - (skip check #("���") (parse "./files/i_string_1st_surrogate_but_2nd_missing.json"))) - - (define i_string_1st_valid_surrogate_2nd_invalid.json - (skip check #("���ሴ") (parse "./files/i_string_1st_valid_surrogate_2nd_invalid.json"))) - - (define i_string_incomplete_surrogate_and_escape_valid.json - (skip check #("���\n") (parse "./files/i_string_incomplete_surrogate_and_escape_valid.json"))) - - (define i_string_incomplete_surrogate_pair.json - (skip check #("���a") (parse "./files/i_string_incomplete_surrogate_pair.json"))) - - (define i_string_incomplete_surrogates_escape_valid.json - (skip check #("������\n") (parse "./files/i_string_incomplete_surrogates_escape_valid.json"))) - - (define i_string_invalid_lonely_surrogate.json - (skip check #("���") (parse "./files/i_string_invalid_lonely_surrogate.json"))) - - (define i_string_invalid_surrogate.json - (skip check #("���abc") (parse "./files/i_string_invalid_surrogate.json"))) - - (define i_string_invalid_utf-8.json - (check-raise json-error? (parse "./files/i_string_invalid_utf-8.json"))) - - (define i_string_inverted_surrogates_U+1D11E.json - (skip check #("������") (parse "./files/i_string_inverted_surrogates_U+1D11E.json"))) - - (define i_string_iso_latin_1.json - (check-raise json-error? (parse "./files/i_string_iso_latin_1.json"))) - - (define i_string_lone_second_surrogate.json - (skip check #("���") (parse "./files/i_string_lone_second_surrogate.json"))) - - (define i_string_lone_utf8_continuation_byte.json - (check-raise json-error? (parse "./files/i_string_lone_utf8_continuation_byte.json"))) - - (define i_string_not_in_unicode_range.json - (skip check #("����") (parse "./files/i_string_not_in_unicode_range.json"))) - - (define i_string_overlong_sequence_2_bytes.json - (check #("/") (parse "./files/i_string_overlong_sequence_2_bytes.json"))) - - (define i_string_overlong_sequence_6_bytes.json - (check-raise json-error? (parse "./files/i_string_overlong_sequence_6_bytes.json"))) - - (define i_string_overlong_sequence_6_bytes_null.json - (check-raise json-error? (parse "./files/i_string_overlong_sequence_6_bytes_null.json"))) - - (define i_string_truncated-utf-8.json - (check-raise json-error? (parse "./files/i_string_truncated-utf-8.json"))) - - ;; XXX: json text must be encoded in utf8?! - (define i_string_utf16BE_no_BOM.json - (check-raise json-error? (parse "./files/i_string_utf16BE_no_BOM.json"))) - - ;; XXX: json text must be encoded in utf8?! - (define i_string_utf16LE_no_BOM.json - (check-raise json-error? (parse "./files/i_string_utf16LE_no_BOM.json"))) - - ;; XXX: json text must be encoded in utf8?! - (define i_string_UTF-16LE_with_BOM.json - (check-raise json-error? (parse "./files/i_string_UTF-16LE_with_BOM.json"))) - - (define i_string_UTF-8_invalid_sequence.json - (check-raise json-error? (parse "./files/i_string_UTF-8_invalid_sequence.json"))) - - ;; XXX: accepted but returns garbage - (define i_string_UTF8_surrogate_U+D800.json - (skip check #("���") (parse "./files/i_string_UTF8_surrogate_U+D800.json"))) - - ;; TODO: convert this giant array of array into a let loop - (define i_structure_500_nested_arrays.json - (check #(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#(#()))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) - (parse "./files/i_structure_500_nested_arrays.json"))) - - ;; it seems to me BOM must not be part of JSON text - (define i_structure_UTF-8_BOM_empty_object.json - (check '() (parse "./files/i_structure_UTF-8_BOM_empty_object.json"))) - - (define n_boolean_not_true.json - (check-raise json-error? (parse "./files/n_boolean_not_true.json"))) - - (define n_boolean_not_false.json - (check-raise json-error? (parse "./files/n_boolean_not_false.json"))) - - (define n_not_null.json - (check-raise json-error? (parse "./files/n_not_null.json"))) - - (define n_array_1_true_without_comma.json - (check-raise json-error? (parse "./files/n_array_1_true_without_comma.json"))) - - (define n_array_a_invalid_utf8.json - (check-raise json-error? (parse "./files/n_array_a_invalid_utf8.json"))) - - (define n_array_colon_instead_of_comma.json - (check-raise json-error? (parse "./files/n_array_colon_instead_of_comma.json"))) - - (define n_array_comma_after_close.json - ;; The parser read a single JSON toplevel value, and ignore the - ;; rest. - (skip check-raise json-error? (parse "./files/n_array_comma_after_close.json"))) - - (define n_array_comma_and_number.json - (check-raise json-error? (parse "./files/n_array_comma_and_number.json"))) - - (define n_array_double_comma.json - (check-raise json-error? (parse "./files/n_array_double_comma.json"))) - - (define n_array_double_extra_comma.json - (check-raise json-error? (parse "./files/n_array_double_extra_comma.json"))) - - (define n_array_extra_close.json - ;; XXX: The parser reads a single toplevel JSON value, and - ;; ignore the rest. - (skip check-raise json-error? (parse "./files/n_array_extra_close.json"))) - - (define n_array_extra_comma.json - (check-raise json-error? (parse "./files/n_array_extra_comma.json"))) - - (define n_array_incomplete_invalid_value.json - (check-raise json-error? (parse "./files/n_array_incomplete_invalid_value.json"))) - - (define n_array_incomplete.json - (check-raise json-error? (parse "./files/n_array_incomplete.json"))) - - (define n_array_inner_array_no_comma.json - (check-raise json-error? (parse "./files/n_array_inner_array_no_comma.json"))) - - ;; TODO: investigate - (define n_array_invalid_utf8.json - (check-raise json-error? (parse "./files/n_array_invalid_utf8.json"))) - - (define n_array_items_separated_by_semicolon.json - (check-raise json-error? (parse "./files/n_array_items_separated_by_semicolon.json"))) - - (define n_array_just_comma.json - (check-raise json-error? (parse "./files/n_array_just_comma.json"))) - - (define n_array_just_minus.json - (check-raise json-error? (parse "./files/n_array_just_minus.json"))) - - (define n_array_missing_value.json - (check-raise json-error? (parse "./files/n_array_missing_value.json"))) - - (define n_array_newlines_unclosed.json - (check-raise json-error? (parse "./files/n_array_newlines_unclosed.json"))) - - (define n_array_number_and_comma.json - (check-raise json-error? (parse "./files/n_array_number_and_comma.json"))) - - (define n_array_number_and_several_commas.json - (check-raise json-error? (parse "./files/n_array_number_and_several_commas.json"))) - - (define n_array_spaces_vertical_tab_formfeed.json - (check-raise json-error? (parse "./files/n_array_spaces_vertical_tab_formfeed.json"))) - - (define n_array_star_inside.json - (check-raise json-error? (parse "./files/n_array_star_inside.json"))) - - (define n_array_unclosed.json - (check-raise json-error? (parse "./files/n_array_unclosed.json"))) - - (define n_array_unclosed_trailing_comma.json - (check-raise json-error? (parse "./files/n_array_unclosed_trailing_comma.json"))) - - (define n_array_unclosed_with_new_lines.json - (check-raise json-error? (parse "./files/n_array_unclosed_with_new_lines.json"))) - - (define n_array_unclosed_with_object_inside.json - (check-raise json-error? (parse "./files/n_array_unclosed_with_object_inside.json"))) - - (define n_incomplete_false.json - (check-raise json-error? (parse "./files/n_incomplete_false.json"))) - - (define n_incomplete_null.json - (check-raise json-error? (parse "./files/n_incomplete_null.json"))) - - (define n_incomplete_true.json - (check-raise json-error? (parse "./files/n_incomplete_true.json"))) - - (define n_multidigit_number_then_00.json - (check-raise json-error? (parse "./files/n_multidigit_number_then_00.json"))) - - (define n_number_0.1.2.json - (check-raise json-error? (parse "./files/n_number_0.1.2.json"))) - - ;; XXX: harmless but not standard - (define n_number_-01.json - (check-raise json-error? (parse "./files/n_number_-01.json"))) - - (define n_number_0.3e.json - (check-raise json-error? (parse "./files/n_number_0.3e.json"))) - - (define n_number_0.3e+.json - (check-raise json-error? (parse "./files/n_number_0.3e+.json"))) - - (define n_number_0_capital_E.json - (check-raise json-error? (parse "./files/n_number_0_capital_E.json"))) - - (define n_number_0_capital_E+.json - (check-raise json-error? (parse "./files/n_number_0_capital_E+.json"))) - - ;; XXX: harmless but not standard - (define n_number_0.e1.json - (check-raise json-error? (parse "./files/n_number_0.e1.json"))) - - (define n_number_0e.json - (check-raise json-error? (parse "./files/n_number_0e.json"))) - - (define n_number_0e+.json - (check-raise json-error? (parse "./files/n_number_0e+.json"))) - - (define n_number_1_000.json - (check-raise json-error? (parse "./files/n_number_1_000.json"))) - - (define n_number_1.0e-.json - (check-raise json-error? (parse "./files/n_number_1.0e-.json"))) - - (define n_number_1.0e.json - (check-raise json-error? (parse "./files/n_number_1.0e.json"))) - - (define n_number_1.0e+.json - (check-raise json-error? (parse "./files/n_number_1.0e+.json"))) - - (define n_number_-1.0..json - (check-raise json-error? (parse "./files/n_number_-1.0..json"))) - - ;; XXX: harmless but not standard - (define n_number_1eE2.json - (check-raise json-error? (parse "./files/n_number_1eE2.json"))) - - (define n_number_.-1.json - (check-raise json-error? (parse "./files/n_number_.-1.json"))) - - (define n_number_+1.json - (check-raise json-error? (parse "./files/n_number_+1.json"))) - - ;; XXX: harmless but not standard - (define n_number_.2e-3.json - (check-raise json-error? (parse "./files/n_number_.2e-3.json"))) - - ;; XXX: harmless but not standard - (define n_number_2.e-3.json - (check-raise json-error? (parse "./files/n_number_2.e-3.json"))) - - ;; XXX: harmless but not standard - (define n_number_2.e+3.json - (check-raise json-error? (parse "./files/n_number_2.e+3.json"))) - - ;; XXX: harmless but not standard - (define n_number_2.e3.json - (check-raise json-error? (parse "./files/n_number_2.e3.json"))) - - ;; XXX: harmless but not standard - (define n_number_-2..json - (check-raise json-error? (parse "./files/n_number_-2..json"))) - - (define n_number_9.e+.json - (check-raise json-error? (parse "./files/n_number_9.e+.json"))) - - (define n_number_expression.json - (check-raise json-error? (parse "./files/n_number_expression.json"))) - - (define n_number_hex_1_digit.json - (check-raise json-error? (parse "./files/n_number_hex_1_digit.json"))) - - (define n_number_hex_2_digits.json - (check-raise json-error? (parse "./files/n_number_hex_2_digits.json"))) - - (define n_number_infinity.json - (check-raise json-error? (parse "./files/n_number_infinity.json"))) - - (define n_number_+Inf.json - (check-raise json-error? (parse "./files/n_number_+Inf.json"))) - - (define n_number_Inf.json - (check-raise json-error? (parse "./files/n_number_Inf.json"))) - - ;; XXX: harmless but not standard - (define n_number_invalid+-.json - (check-raise json-error? (parse "./files/n_number_invalid+-.json"))) - - (define n_number_invalid-negative-real.json - (check-raise json-error? (parse "./files/n_number_invalid-negative-real.json"))) - - (define n_number_invalid-utf-8-in-bigger-int.json - (check-raise json-error? (parse "./files/n_number_invalid-utf-8-in-bigger-int.json"))) - - (define n_number_invalid-utf-8-in-exponent.json - (check-raise json-error? (parse "./files/n_number_invalid-utf-8-in-exponent.json"))) - - (define n_number_invalid-utf-8-in-int.json - (check-raise json-error? (parse "./files/n_number_invalid-utf-8-in-int.json"))) - - (define n_number_++.json - (check-raise json-error? (parse "./files/n_number_++.json"))) - - (define n_number_minus_infinity.json - (check-raise json-error? (parse "./files/n_number_minus_infinity.json"))) - - (define n_number_minus_sign_with_trailing_garbage.json - (check-raise json-error? (parse "./files/n_number_minus_sign_with_trailing_garbage.json"))) - - (define n_number_minus_space_1.json - (check-raise json-error? (parse "./files/n_number_minus_space_1.json"))) - - (define n_number_-NaN.json - (check-raise json-error? (parse "./files/n_number_-NaN.json"))) - - (define n_number_NaN.json - (check-raise json-error? (parse "./files/n_number_NaN.json"))) - - ;; XXX: harmless but not standard - (define n_number_neg_int_starting_with_zero.json - (check-raise json-error? (parse "./files/n_number_neg_int_starting_with_zero.json"))) - - (define n_number_neg_real_without_int_part.json - (check-raise json-error? (parse "./files/n_number_neg_real_without_int_part.json"))) - - (define n_number_neg_with_garbage_at_end.json - (check-raise json-error? (parse "./files/n_number_neg_with_garbage_at_end.json"))) - - (define n_number_real_garbage_after_e.json - (check-raise json-error? (parse "./files/n_number_real_garbage_after_e.json"))) - - (define n_number_real_with_invalid_utf8_after_e.json - (check-raise json-error? (parse "./files/n_number_real_with_invalid_utf8_after_e.json"))) - - (define n_number_real_without_fractional_part.json - (check-raise json-error? (parse "./files/n_number_real_without_fractional_part.json"))) - - (define n_number_starting_with_dot.json - (check-raise json-error? (parse "./files/n_number_starting_with_dot.json"))) - - (define n_number_U+FF11_fullwidth_digit_one.json - (check-raise json-error? (parse "./files/n_number_U+FF11_fullwidth_digit_one.json"))) - - (define n_number_with_alpha_char.json - (check-raise json-error? (parse "./files/n_number_with_alpha_char.json"))) - - (define n_number_with_alpha.json - (check-raise json-error? (parse "./files/n_number_with_alpha.json"))) - - (define n_number_with_leading_zero.json - (check-raise json-error? (parse "./files/n_number_with_leading_zero.json"))) - - (define n_object_bad_value.json - (check-raise json-error? (parse "./files/n_object_bad_value.json"))) - - (define n_object_bracket_key.json - (check-raise json-error? (parse "./files/n_object_bracket_key.json"))) - - (define n_object_comma_instead_of_colon.json - (check-raise json-error? (parse "./files/n_object_comma_instead_of_colon.json"))) - - (define n_object_double_colon.json - (check-raise json-error? (parse "./files/n_object_double_colon.json"))) - - (define n_object_emoji.json - (check-raise json-error? (parse "./files/n_object_emoji.json"))) - - (define n_object_garbage_at_end.json - (check-raise json-error? (parse "./files/n_object_garbage_at_end.json"))) - - (define n_object_key_with_single_quotes.json - (check-raise json-error? (parse "./files/n_object_key_with_single_quotes.json"))) - - (define n_object_lone_continuation_byte_in_key_and_trailing_comma.json - (check-raise json-error? (parse "./files/n_object_lone_continuation_byte_in_key_and_trailing_comma.json"))) - - (define n_object_missing_colon.json - (check-raise json-error? (parse "./files/n_object_missing_colon.json"))) - - (define n_object_missing_key.json - (check-raise json-error? (parse "./files/n_object_missing_key.json"))) - - (define n_object_missing_semicolon.json - (check-raise json-error? (parse "./files/n_object_missing_semicolon.json"))) - - (define n_object_missing_value.json - (check-raise json-error? (parse "./files/n_object_missing_value.json"))) - - (define n_object_no-colon.json - (check-raise json-error? (parse "./files/n_object_no-colon.json"))) - - (define n_object_non_string_key_but_huge_number_instead.json - (check-raise json-error? (parse "./files/n_object_non_string_key_but_huge_number_instead.json"))) - - (define n_object_non_string_key.json - (check-raise json-error? (parse "./files/n_object_non_string_key.json"))) - - (define n_object_repeated_null_null.json - (check-raise json-error? (parse "./files/n_object_repeated_null_null.json"))) - - (define n_object_several_trailing_commas.json - (check-raise json-error? (parse "./files/n_object_several_trailing_commas.json"))) - - (define n_object_single_quote.json - (check-raise json-error? (parse "./files/n_object_single_quote.json"))) - - (define n_object_trailing_comma.json - (check-raise json-error? (parse "./files/n_object_trailing_comma.json"))) - - (define n_object_trailing_comment.json - ;; XXX: The parser read a single toplevel JSON value, and ignore - ;; the rest. - (skip check-raise json-error? (parse "./files/n_object_trailing_comment.json"))) - - (define n_object_trailing_comment_open.json - ;; XXX: The parser read a single toplevel JSON value, and ignore - ;; the rest. - (skip check-raise json-error? (parse "./files/n_object_trailing_comment_open.json"))) - - (define n_object_trailing_comment_slash_open_incomplete.json - ;; XXX: The parser read a single toplevel JSON value, and ignore the rest. - (skip check-raise json-error? (parse "./files/n_object_trailing_comment_slash_open_incomplete.json"))) - - (define n_object_trailing_comment_slash_open.json - ;; XXX: The parser read a single toplevel JSON value, and ignore the rest. - (skip check-raise json-error? (parse "./files/n_object_trailing_comment_slash_open.json"))) - - (define n_object_two_commas_in_a_row.json - (check-raise json-error? (parse "./files/n_object_two_commas_in_a_row.json"))) - - (define n_object_unquoted_key.json - (check-raise json-error? (parse "./files/n_object_unquoted_key.json"))) - - (define n_object_unterminated-value.json - (check-raise json-error? (parse "./files/n_object_unterminated-value.json"))) - - (define n_object_with_single_string.json - (check-raise json-error? (parse "./files/n_object_with_single_string.json"))) - - (define n_object_with_trailing_garbage.json - ;; XXX: The parser read a single toplevel value, and ignore the - ;; rest. - (skip check-raise json-error? (parse "./files/n_object_with_trailing_garbage.json"))) - - (define n_single_space.json - (check-raise json-error? (parse "./files/n_single_space.json"))) - - (define n_string_1_surrogate_then_escape.json - (check-raise json-error? (parse "./files/n_string_1_surrogate_then_escape.json"))) - - (define n_string_1_surrogate_then_escape_u1.json - (check-raise json-error? (parse "./files/n_string_1_surrogate_then_escape_u1.json"))) - - (define n_string_1_surrogate_then_escape_u1x.json - (check-raise json-error? (parse "./files/n_string_1_surrogate_then_escape_u1x.json"))) - - (define n_string_1_surrogate_then_escape_u.json - (check-raise json-error? (parse "./files/n_string_1_surrogate_then_escape_u.json"))) - - (define n_string_accentuated_char_no_quotes.json - (check-raise json-error? (parse "./files/n_string_accentuated_char_no_quotes.json"))) - - (define n_string_backslash_00.json - (check-raise json-error? (parse "./files/n_string_backslash_00.json"))) - - (define n_string_escaped_backslash_bad.json - (check-raise json-error? (parse "./files/n_string_escaped_backslash_bad.json"))) - - (define n_string_escaped_ctrl_char_tab.json - (check-raise json-error? (parse "./files/n_string_escaped_ctrl_char_tab.json"))) - - (define n_string_escaped_emoji.json - (check-raise json-error? (parse "./files/n_string_escaped_emoji.json"))) - - (define n_string_escape_x.json - (check-raise json-error? (parse "./files/n_string_escape_x.json"))) - - (define n_string_incomplete_escaped_character.json - (check-raise json-error? (parse "./files/n_string_incomplete_escaped_character.json"))) - - (define n_string_incomplete_escape.json - (check-raise json-error? (parse "./files/n_string_incomplete_escape.json"))) - - (define n_string_incomplete_surrogate_escape_invalid.json - (check-raise json-error? (parse "./files/n_string_incomplete_surrogate_escape_invalid.json"))) - - (define n_string_incomplete_surrogate.json - (check-raise json-error? (parse "./files/n_string_incomplete_surrogate.json"))) - - (define n_string_invalid_backslash_esc.json - (check-raise json-error? (parse "./files/n_string_invalid_backslash_esc.json"))) - - (define n_string_invalid_unicode_escape.json - (check-raise json-error? (parse "./files/n_string_invalid_unicode_escape.json"))) - - (define n_string_invalid_utf8_after_escape.json - (check-raise json-error? (parse "./files/n_string_invalid_utf8_after_escape.json"))) - - (define n_string_invalid-utf-8-in-escape.json - (check-raise json-error? (parse "./files/n_string_invalid-utf-8-in-escape.json"))) - - (define n_string_leading_uescaped_thinspace.json - (check-raise json-error? (parse "./files/n_string_leading_uescaped_thinspace.json"))) - - (define n_string_no_quotes_with_bad_escape.json - (check-raise json-error? (parse "./files/n_string_no_quotes_with_bad_escape.json"))) - - (define n_string_single_doublequote.json - (check-raise json-error? (parse "./files/n_string_single_doublequote.json"))) - - (define n_string_single_quote.json - (check-raise json-error? (parse "./files/n_string_single_quote.json"))) - - (define n_string_single_string_no_double_quotes.json - (check-raise json-error? (parse "./files/n_string_single_string_no_double_quotes.json"))) - - (define n_string_start_escape_unclosed.json - (check-raise json-error? (parse "./files/n_string_start_escape_unclosed.json"))) - - (define n_string_unescaped_crtl_char.json - (check-raise json-error? (parse "./files/n_string_unescaped_crtl_char.json"))) - - (define n_string_unescaped_newline.json - (check-raise json-error? (parse "./files/n_string_unescaped_newline.json"))) - - (define n_string_unescaped_tab.json - (check-raise json-error? (parse "./files/n_string_unescaped_tab.json"))) - - (define n_string_unicode_CapitalU.json - (check-raise json-error? (parse "./files/n_string_unicode_CapitalU.json"))) - - (define n_string_with_trailing_garbage.json - ;; The parser read a single toplevel value, and ignore the rest. - (skip check-raise json-error? (parse "./files/n_string_with_trailing_garbage.json"))) - - (define n_structure_100000_opening_arrays.json - ;; TODO: unskip when limit is here - (skip check-raise json-error? (parse "./files/n_structure_100000_opening_arrays.json"))) - - (define n_structure_angle_bracket_..json - (check-raise json-error? (parse "./files/n_structure_angle_bracket_..json"))) - - (define n_structure_angle_bracket_null.json - (check-raise json-error? (parse "./files/n_structure_angle_bracket_null.json"))) - - (define n_structure_array_trailing_garbage.json - ;; XXX: The parser reads a single JSON toplevel value and ignore - ;; the rest. - (skip check-raise json-error? (parse "./files/n_structure_array_trailing_garbage.json"))) - - (define n_structure_array_with_extra_array_close.json - ;; XXX: The parser consider a single toplevel value. - (skip check-raise json-error? (parse "./files/n_structure_array_with_extra_array_close.json"))) - - (define n_structure_array_with_unclosed_string.json - (check-raise json-error? (parse "./files/n_structure_array_with_unclosed_string.json"))) - - (define n_structure_ascii-unicode-identifier.json - (check-raise json-error? (parse "./files/n_structure_ascii-unicode-identifier.json"))) - - (define n_structure_capitalized_True.json - (check-raise json-error? (parse "./files/n_structure_capitalized_True.json"))) - - (define n_structure_close_unopened_array.json - ;; XXX: The parser reads a single toplevel value, and ignore the - ;; rest. - (skip check-raise json-error? (parse "./files/n_structure_close_unopened_array.json"))) - - (define n_structure_comma_instead_of_closing_brace.json - (check-raise json-error? (parse "./files/n_structure_comma_instead_of_closing_brace.json"))) - - (define n_structure_double_array.json - ;; XXX: The parser considers a single JSON toplevel value - (skip check-raise json-error? (parse "./files/n_structure_double_array.json"))) - - (define n_structure_end_array.json - (check-raise json-error? (parse "./files/n_structure_end_array.json"))) - - (define n_structure_incomplete_UTF8_BOM.json - (check-raise json-error? (parse "./files/n_structure_incomplete_UTF8_BOM.json"))) - - (define n_structure_lone-invalid-utf-8.json - (check-raise json-error? (parse "./files/n_structure_lone-invalid-utf-8.json"))) - - (define n_structure_lone-open-bracket.json - (check-raise json-error? (parse "./files/n_structure_lone-open-bracket.json"))) - - (define n_structure_no_data.json - (check-raise json-error? (parse "./files/n_structure_no_data.json"))) - - (define n_structure_null-byte-outside-string.json - (check-raise json-error? (parse "./files/n_structure_null-byte-outside-string.json"))) - - (define n_structure_number_with_trailing_garbage.json - ;; XXX: The parser read a single toplevel value. - (skip check-raise json-error? (parse "./files/n_structure_number_with_trailing_garbage.json"))) - - (define n_structure_object_followed_by_closing_object.json - ;; XXX: The parser reads a single toplevel value, and will not - ;; consider the rest of the text, until another json-read is - ;; done. - (skip check-raise json-error? (parse "./files/n_structure_object_followed_by_closing_object.json"))) - - (define n_structure_object_unclosed_no_value.json - (check-raise json-error? (parse "./files/n_structure_object_unclosed_no_value.json"))) - - (define n_structure_object_with_comment.json - (check-raise json-error? (parse "./files/n_structure_object_with_comment.json"))) - - (define n_structure_object_with_trailing_garbage.json - ;; XXX: The parser will read a single top level JSON value and - ;; return it. It will not consider the whole string. - (skip check-raise json-error? (parse "./files/n_structure_object_with_trailing_garbage.json"))) - - (define n_structure_open_array_apostrophe.json - (check-raise json-error? (parse "./files/n_structure_open_array_apostrophe.json"))) - - (define n_structure_open_array_comma.json - (check-raise json-error? (parse "./files/n_structure_open_array_comma.json"))) - - (define n_structure_open_array_object.json - ;; TODO: unskip once there is a paramter json-max-nesting-level - (skip check-raise json-error? (parse "./files/n_structure_open_array_object.json"))) - - (define n_structure_open_array_open_object.json - (check-raise json-error? (parse "./files/n_structure_open_array_open_object.json"))) - - (define n_structure_open_array_open_string.json - (check-raise json-error? (parse "./files/n_structure_open_array_open_string.json"))) - - (define n_structure_open_array_string.json - (check-raise json-error? (parse "./files/n_structure_open_array_string.json"))) - - (define n_structure_open_object_close_array.json - (check-raise json-error? (parse "./files/n_structure_open_object_close_array.json"))) - - (define n_structure_open_object_comma.json - (check-raise json-error? (parse "./files/n_structure_open_object_comma.json"))) - - (define n_structure_open_object.json - (check-raise json-error? (parse "./files/n_structure_open_object.json"))) - - (define n_structure_open_object_open_array.json - (check-raise json-error? (parse "./files/n_structure_open_object_open_array.json"))) - - (define n_structure_open_object_open_string.json - (check-raise json-error? (parse "./files/n_structure_open_object_open_string.json"))) - - (define n_structure_open_object_string_with_apostrophes.json - (check-raise json-error? (parse "./files/n_structure_open_object_string_with_apostrophes.json"))) - - (define n_structure_open_open.json - (check-raise json-error? (parse "./files/n_structure_open_open.json"))) - - (define n_structure_single_eacute.json - (check-raise json-error? (parse "./files/n_structure_single_eacute.json"))) - - (define n_structure_single_star.json - (check-raise json-error? (parse "./files/n_structure_single_star.json"))) - - (define n_structure_trailing_sharp.json - ;; XXX: the parser will read the first JSON and stop there, if - ;; there is more characters after a JSON sequence, it will not - ;; be taken in to account. That is, what follows a JSON text - ;; does matter, as long as there is proper object / array that - ;; open / close and string double quotes and escapes. - (skip check-raise json-error? (parse "./files/n_structure_trailing_#.json"))) - - (define n_structure_U+2060_word_joined.json - (check-raise json-error? (parse "./files/n_structure_U+2060_word_joined.json"))) - - (define n_structure_uescaped_LF_before_string.json - (check-raise json-error? (parse "./files/n_structure_uescaped_LF_before_string.json"))) - - (define n_structure_unclosed_array.json - (check-raise json-error? (parse "./files/n_structure_unclosed_array.json"))) - - (define n_structure_unclosed_array_partial_null.json - (check-raise json-error? (parse "./files/n_structure_unclosed_array_partial_null.json"))) - - (define n_structure_unclosed_array_unfinished_false.json - (check-raise json-error? (parse "./files/n_structure_unclosed_array_unfinished_false.json"))) - - (define n_structure_unclosed_array_unfinished_true.json - (check-raise json-error? (parse "./files/n_structure_unclosed_array_unfinished_true.json"))) - - (define n_structure_unclosed_object.json - (check-raise json-error? (parse "./files/n_structure_unclosed_object.json"))) - - (define n_structure_unicode-identifier.json - (check-raise json-error? (parse "./files/n_structure_unicode-identifier.json"))) - - (define n_structure_UTF8_BOM_no_data.json - (check-raise json-error? (parse "./files/n_structure_UTF8_BOM_no_data.json"))) - - (define n_structure_whitespace_formfeed.json - (check-raise json-error? (parse "./files/n_structure_whitespace_formfeed.json"))) - - ;; TODO: FIXME - (define n_structure_whitespace_U+2060_word_joiner.json - (check-raise json-error? (parse "./files/n_structure_whitespace_U+2060_word_joiner.json"))) - - (define y_array_arraysWithSpaces.json - (check #(#()) (parse "./files/y_array_arraysWithSpaces.json"))) - - (define y_array_empty.json - (check #() (parse "./files/y_array_empty.json"))) - - (define y_array_empty-string.json - (check #("") (parse "./files/y_array_empty-string.json"))) - - (define y_array_ending_with_newline.json - (check #("a") (parse "./files/y_array_ending_with_newline.json"))) - - (define y_array_false.json - (check #(#f) (parse "./files/y_array_false.json"))) - - (define y_array_heterogeneous.json - (check #(null 1 "1" ()) (parse "./files/y_array_heterogeneous.json"))) - - (define y_array_null.json - (check #(null) (parse "./files/y_array_null.json"))) - - (define y_array_with_1_and_newline.json - (check #(1) (parse "./files/y_array_with_1_and_newline.json"))) - - (define y_array_with_leading_space.json - (check #(1) (parse "./files/y_array_with_leading_space.json"))) - - (define y_array_with_several_null.json - (check #(1 null null null 2) (parse "./files/y_array_with_several_null.json"))) - - (define y_array_with_trailing_space.json - (check #(2) (parse "./files/y_array_with_trailing_space.json"))) - - (define y_number_0e+1.json - (check #(0.0) (parse "./files/y_number_0e+1.json"))) - - (define y_number_0e1.json - (check #(0.0) (parse "./files/y_number_0e1.json"))) - - (define y_number_after_space.json - (check #(4) (parse "./files/y_number_after_space.json"))) - - (define y_number_double_close_to_zero.json - (check #(-1e-78) (parse "./files/y_number_double_close_to_zero.json"))) - - (define y_number_int_with_exp.json - (check #(200.0) (parse "./files/y_number_int_with_exp.json"))) - - ;; XXX: not determinist - (define y_number.json - (skip check #(1.23e+67) (parse "./files/y_number.json"))) - - (define y_number_minus_zero.json - (check #(0) (parse "./files/y_number_minus_zero.json"))) - - (define y_number_negative_int.json - (check #(-123) (parse "./files/y_number_negative_int.json"))) - - (define y_number_negative_one.json - (check #(-1) (parse "./files/y_number_negative_one.json"))) - - (define y_number_negative_zero.json - (check #(0) (parse "./files/y_number_negative_zero.json"))) - - (define y_number_real_capital_e.json - (check #(1e+22) (parse "./files/y_number_real_capital_e.json"))) - - (define y_number_real_capital_e_neg_exp.json - (check #(0.01) (parse "./files/y_number_real_capital_e_neg_exp.json"))) - - (define y_number_real_capital_e_pos_exp.json - (check #(100.0) (parse "./files/y_number_real_capital_e_pos_exp.json"))) - - ;; XXX: not determinist. - (define y_number_real_exponent.json - (skip check #(1.23e+47) (parse "./files/y_number_real_exponent.json"))) - - (define y_number_real_fraction_exponent.json - (check #(1.23456e+80) (parse "./files/y_number_real_fraction_exponent.json"))) - - (define y_number_real_neg_exp.json - (check #(0.01) (parse "./files/y_number_real_neg_exp.json"))) - - (define y_number_real_pos_exponent.json - (check #(100.0) (parse "./files/y_number_real_pos_exponent.json"))) - - (define y_number_simple_int.json - (check #(123) (parse "./files/y_number_simple_int.json"))) - - (define y_number_simple_real.json - (check #(123.456789) (parse "./files/y_number_simple_real.json"))) - - (define y_object_basic.json - (check '((asd . "sdf")) (parse "./files/y_object_basic.json"))) - - (define y_object_duplicated_key_and_value.json - (check '((a . "b") (a . "b")) (parse "./files/y_object_duplicated_key_and_value.json"))) - - (define y_object_duplicated_key.json - (check '((a . "b") (a . "c")) (parse "./files/y_object_duplicated_key.json"))) - - (define y_object_empty.json - (check '() (parse "./files/y_object_empty.json"))) - - (define y_object_empty_key.json - (check '((|| . 0)) (parse "./files/y_object_empty_key.json"))) - - ;; TODO: add escaped null char - (define y_object_escaped_null_in_key.json - (skip check '((|foobar| . 42)) (parse "./files/y_object_escaped_null_in_key.json"))) - - (define y_object_extreme_numbers.json - (check '((min . -1e+28) (max . 1e+28)) - (parse "./files/y_object_extreme_numbers.json"))) - - (define y_object.json - (check '((asd . "sdf") (dfg . "fgh")) (parse "./files/y_object.json"))) - - (define y_object_long_strings.json - (check '((abc . #(((def . "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")))) - (ijk . "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy")) - (parse "./files/y_object_long_strings.json"))) - - (define y_object_simple.json - (check '((a . #())) (parse "./files/y_object_simple.json"))) - - (define y_object_string_unicode.json - (check '((title . "Полтора Землекопа")) (parse "./files/y_object_string_unicode.json"))) - - (define y_object_with_newlines.json - (check '((a . "b")) (parse "./files/y_object_with_newlines.json"))) - - (define y_string_1_2_3_bytes_UTF-8_sequences.json - (check #("`Īካ") (parse "./files/y_string_1_2_3_bytes_UTF-8_sequences.json"))) - - ;; XXX: dubious - (define y_string_accepted_surrogate_pair.json - (skip check #("������") (parse "./files/y_string_accepted_surrogate_pair.json"))) - - ;; XXX: dubious result check - (define y_string_accepted_surrogate_pairs.json - (skip check #("������������") (parse "./files/y_string_accepted_surrogate_pairs.json"))) - - (define y_string_allowed_escapes.json - (check #("\"\\/\b\x0c;\n\r\t") (parse "./files/y_string_allowed_escapes.json"))) - - (define y_string_backslash_and_u_escaped_zero.json - (check #("\\u0000") (parse "./files/y_string_backslash_and_u_escaped_zero.json"))) - - (define y_string_backslash_doublequotes.json - (check #("\"") (parse "./files/y_string_backslash_doublequotes.json"))) - - (define y_string_comments.json - (check #("a/*b*/c/*d//e") (parse "./files/y_string_comments.json"))) - - (define y_string_double_escape_a.json - (check #("\\a") (parse "./files/y_string_double_escape_a.json"))) - - (define y_string_double_escape_n.json - (check #("\\n") (parse "./files/y_string_double_escape_n.json"))) - - (define y_string_escaped_control_character.json - (check #("\x12;") (parse "./files/y_string_escaped_control_character.json"))) - - (define y_string_escaped_noncharacter.json - (check #("￿") (parse "./files/y_string_escaped_noncharacter.json"))) - - (define y_string_in_array.json - (check #("asd") (parse "./files/y_string_in_array.json"))) - - (define y_string_in_array_with_leading_space.json - (check #("asd") (parse "./files/y_string_in_array_with_leading_space.json"))) - - ;; XXX: result is suspect - (define y_string_last_surrogates_1_and_2.json - (skip check #("������") (parse "./files/y_string_last_surrogates_1_and_2.json"))) - - (define y_string_nbsp_uescaped.json - (check #("new line") (parse "./files/y_string_nbsp_uescaped.json"))) - - (define y_string_nonCharacterInUTF-8_U+10FFFF.json - (check #("􏿿") (parse "./files/y_string_nonCharacterInUTF-8_U+10FFFF.json"))) - - (define y_string_nonCharacterInUTF-8_U+FFFF.json - (check #("￿") (parse "./files/y_string_nonCharacterInUTF-8_U+FFFF.json"))) - - (define y_string_null_escape.json - (check #("\x00;") (parse "./files/y_string_null_escape.json"))) - - (define y_string_one-byte-utf-8.json - (check #(",") (parse "./files/y_string_one-byte-utf-8.json"))) - - (define y_string_pi.json - (check #("π") (parse "./files/y_string_pi.json"))) - - (define y_string_reservedCharacterInUTF-8_U+1BFFF.json - (check #("𛿿") (parse "./files/y_string_reservedCharacterInUTF-8_U+1BFFF.json"))) - - (define y_string_simple_ascii.json - (check #("asd ") (parse "./files/y_string_simple_ascii.json"))) - - (define y_string_space.json - (check " " (parse "./files/y_string_space.json"))) - - ;; XXX: result is suspect - (define y_string_surrogates_U+1D11E_MUSICAL_SYMBOL_G_CLEF.json - (skip check #("������") (parse "./files/y_string_surrogates_U+1D11E_MUSICAL_SYMBOL_G_CLEF.json"))) - - (define y_string_three-byte-utf-8.json - (check #("ࠡ") (parse "./files/y_string_three-byte-utf-8.json"))) - - (define y_string_two-byte-utf-8.json - (check #("ģ") (parse "./files/y_string_two-byte-utf-8.json"))) - - (define y_string_u+2028_line_sep.json - (check #("
") (parse "./files/y_string_u+2028_line_sep.json"))) - - (define y_string_u+2029_par_sep.json - (check #("
") (parse "./files/y_string_u+2029_par_sep.json"))) - - (define y_string_uescaped_newline.json - (check #("new\nline") (parse "./files/y_string_uescaped_newline.json"))) - - (define y_string_uEscape.json - (check #("aクリス") (parse "./files/y_string_uEscape.json"))) - - ;; XXX: copy pasting from the terminal does not work - (define y_string_unescaped_char_delete.json - (skip check #("") (parse "./files/y_string_unescaped_char_delete.json"))) - - (define y_string_unicode_2.json - (check #("⍂㈴⍂") (parse "./files/y_string_unicode_2.json"))) - - (define y_string_unicodeEscapedBackslash.json - (check #("\\") (parse "./files/y_string_unicodeEscapedBackslash.json"))) - - (define y_string_unicode_escaped_double_quote.json - (check #("\"") (parse "./files/y_string_unicode_escaped_double_quote.json"))) - - (define y_string_unicode.json - (check #("ꙭ") (parse "./files/y_string_unicode.json"))) - - ;; XXX: expected value is dubious - (define y_string_unicode_U+10FFFE_nonchar.json - (skip check #("������") (parse "./files/y_string_unicode_U+10FFFE_nonchar.json"))) - - ;; XXX: expected value is dubious - (define y_string_unicode_U+1FFFE_nonchar.json - (skip check #("������") (parse "./files/y_string_unicode_U+1FFFE_nonchar.json"))) - - (define y_string_unicode_U+200B_ZERO_WIDTH_SPACE.json - (check #("​") (parse "./files/y_string_unicode_U+200B_ZERO_WIDTH_SPACE.json"))) - - (define y_string_unicode_U+2064_invisible_plus.json - (check #("⁤") (parse "./files/y_string_unicode_U+2064_invisible_plus.json"))) - - (define y_string_unicode_U+FDD0_nonchar.json - (check #("﷐") (parse "./files/y_string_unicode_U+FDD0_nonchar.json"))) - - ;; XXX: This is different fron CPython 3.6 - (define y_string_unicode_U+FFFE_nonchar.json - (check #("￾") (parse "./files/y_string_unicode_U+FFFE_nonchar.json"))) - - (define y_string_utf8.json - (check #("€𝄞") (parse "./files/y_string_utf8.json"))) - - (define y_string_with_del_character.json - (check #("aa") (parse "./files/y_string_with_del_character.json"))) - - (define y_structure_lonely_false.json - (check #f (parse "./files/y_structure_lonely_false.json"))) - - (define y_structure_lonely_int.json - (check 42 (parse "./files/y_structure_lonely_int.json"))) - - (define y_structure_lonely_negative_real.json - (check -0.1 (parse "./files/y_structure_lonely_negative_real.json"))) - - (define y_structure_lonely_null.json - (check 'null (parse "./files/y_structure_lonely_null.json"))) - - (define y_structure_lonely_string.json - (check "asd" (parse "./files/y_structure_lonely_string.json"))) - - (define y_structure_lonely_true.json - (check #t (parse "./files/y_structure_lonely_true.json"))) - - (define y_structure_string_empty.json - (check "" (parse "./files/y_structure_string_empty.json"))) - - (define y_structure_trailing_newline.json - (check #("a") (parse "./files/y_structure_trailing_newline.json"))) - - (define y_structure_true_in_array.json - (check #(#t) (parse "./files/y_structure_true_in_array.json"))) - - (define y_structure_whitespace_array.json - (check #() (parse "./files/y_structure_whitespace_array.json"))) - - ;; Other tests - - (define y_object_nested.json - (check '((outer (inner . 1))) (parse "./files/y_object_nested.json"))) - - ;; Scheme specific tests - - (define n_+inf.0 - (check-raise json-error? (obj->json-string +inf.0))) - - (define n_-inf.0 - (check-raise json-error? (obj->json-string -inf.0))) - - (define n_complex - (check-raise json-error? (obj->json-string 3+14i))) - - (define n_-nan.0 - (check-raise json-error? (obj->json-string +nan.0))) - - (define n_+nan.0 - (check-raise json-error? (obj->json-string -nan.0))) - - (define n_exact_not_integer - (check-raise json-error? (obj->json-string 314/100))) - - (define y_json_lines_numbers - (check '(1 2 3) (call-with-input-string "1\n2\n3\n" - (lambda (port) - (let loop ((obj (json-read port)) - (out '())) - (if (eof-object? obj) - (reverse out) - (loop (json-read port) (cons obj out)))))))) - - (define y_json_lines_arrays - (check '(#(1) #(2) #(3)) - (call-with-input-string "[1]\n[2]\n[3]\n" - (lambda (port) - (let loop ((obj (json-read port)) - (out '())) - (if (eof-object? obj) - (reverse out) - (loop (json-read port) (cons obj out)))))))) - - (define y_json_lines_objects - (check '(((hello . "world")) ((true . #t)) ((magic . 42))) - (call-with-input-string "{\"hello\": \"world\"}\n{\"true\": true}\n{\"magic\": 42}" - (lambda (port) - (let loop ((obj (json-read port)) - (out '())) - (if (eof-object? obj) - (reverse out) - (loop (json-read port) (cons obj out)))))))) - - (define character-limit - (check-raise json-error? - (parameterize ((json-number-of-character-limit 1)) - (json-string->obj "3.14159")))) - - (define nesting-limit - (check-raise json-error? - (parameterize ((json-nesting-depth-limit 1)) - (json-string->obj "[[3.14159]]")))) - - ;; parse json into records - - (define-record-type - (make-magic number) - magic? - (number magic-number)) - - (define (json-magic port) - (define %root '(root)) - - (define (array-start seed) '()) - - (define (array-end items) - (list->vector (reverse items))) - - (define (object-start seed) '()) - - (define (plist->record plist) - (make-magic (car plist))) - - (define object-end plist->record) - - (define (proc obj seed) - (if (eq? seed %root) - obj - (cons obj seed))) - - (let ((out (json-fold proc - array-start - array-end - object-start - object-end - %root - port))) - ;; if out is the root object, then the port or generator is empty. - (if (eq? out %root) - (eof-object) - out))) - - (define parse-into-records - (check #(42 101 1337 2006) - (vector-map magic-number (call-with-input-string "[ -{\"magic\": 42}, -{\"magic\": 101}, -{\"magic\": 1337}, -{\"magic\": 2006} -]" json-magic)))) - - (define y_foundationdb_status.scm - (call-with-input-file "./files/y_foundationdb_status.scm" read)) - - (define y_foundationdb_status.json - (check y_foundationdb_status.scm (parse "./files/y_foundationdb_status.json"))) - - ;; sample .jsonl extracted from python-jsonlines that is Copyright - ;; © 2016, Wouter Bolsterlee, 3-clause "New BSD License" see: - ;; - ;; https://github.com/wbolster/jsonlines/ - ;; - (define sample-crlf-line-separators.jsonl - (check '(((a . 1)) ((b . 2))) - (call-with-input-file "./files/sample-crlf-line-separators.jsonl" - (lambda (port) (generator->list (json-lines-read port)))))) - - (define sample.jsonl - (check '(((a . 1)) ((b . 2))) - (call-with-input-file "./files/sample.jsonl" - (lambda (port) (generator->list (json-lines-read port)))))) - - (define sample-no-eol-at-eof.jsonl - (check '(((a . 1)) ((b . 2))) - (call-with-input-file "./files/sample-no-eol-at-eof.jsonl" - (lambda (port) (generator->list (json-lines-read port)))))) - - ;; json-sequence.log was taken from: - ;; - ;; https://raw.githubusercontent.com/hildjj/json-text-sequence/ - ;; - ;; License is MIT: Copyright (c) 2014 Joe Hildebrand - ;; - (define json-sequence.log - (check '(((d . "2014-09-22T22:11:26.315Z") (count . 0)) - ((d . "2014-09-22T22:11:26.317Z") (count . 1)) - ((d . "2014-09-22T22:11:26.317Z") (count . 2)) - ((d . "2014-09-22T22:11:26.317Z") (count . 3)) - ((d . "2014-09-22T22:11:26.317Z") (count . 4)) - ((d . "2014-09-22T22:11:26.317Z") (count . 5)) - ((d . "2014-09-22T22:11:26.317Z") (count . 6)) - ((d . "2014-09-22T22:11:26.317Z") (count . 7)) - ((d . "2014-09-22T22:11:26.317Z") (count . 8)) - ((d . "2014-09-22T22:11:26.317Z") (count . 9))) - (call-with-input-file "./files/json-sequence.log" - (lambda (port) (generator->list (json-sequence-read port)))))) - - (define json-sequence-with-one-broken-json.log - (check '(((d . "2014-09-22T22:11:26.315Z") (count . 0)) - ((d . "2014-09-22T22:11:26.317Z") (count . 1)) - ((d . "2014-09-22T22:11:26.317Z") (count . 2)) - ((d . "2014-09-22T22:11:26.317Z") (count . 3)) - ((d . "2014-09-22T22:11:26.317Z") (count . 4)) - ((d . "2014-09-22T22:11:26.317Z") (count . 5)) - ((d . "2014-09-22T22:11:26.317Z") (count . 6)) - ((d . "2014-09-22T22:11:26.317Z") (count . 7)) - ;; ((d . "2014-09-22T22:11:26.317Z") (count . 8)) - ((d . "2014-09-22T22:11:26.317Z") (count . 9))) - (call-with-input-file "./files/json-sequence-with-one-broken-json.log" - (lambda (port) (generator->list (json-sequence-read port)))))) - - (define json-generator-single-top-level-value - (check - (call-with-input-string "42 101 1337" (lambda (port) (generator->list (json-generator port)))) - '(42))) - - (define json-generator-single-top-level-value-structure - (check - (call-with-input-string "[42] 101 1337" (lambda (port) (generator->list (json-generator port)))) - '(array-start 42 array-end))) - - )) diff --git a/srfi.180.helpers.scm b/srfi.180.helpers.scm deleted file mode 100644 index 4a0a4b9..0000000 --- a/srfi.180.helpers.scm +++ /dev/null @@ -1,22 +0,0 @@ -(import (r7rs)) - -(define-library (srfi 180 helpers) - - (export valid-number?) - - (import (scheme base) - (chicken irregex)) - - (begin - - (define (valid-number? string) - (irregex-match? - `(seq - (? #\-) - (or #\0 (seq (- numeric #\0) - (* numeric))) - (? (seq #\. (+ numeric))) - (? (seq (or #\e #\E) - (? (or #\- #\+)) - (+ numeric)))) - string)))) diff --git a/tests/run.scm b/tests/run.scm index 9ac5f66..b16c597 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,90 +1,142 @@ -(import (scheme base)) -(import (scheme cxr)) -(import (scheme eval)) -(import (scheme write)) -(import (scheme read)) -(import (scheme file)) -(import (scheme process-context)) +(import (chicken string)) +(import test + (chicken base) + (chicken format) + (chicken port) + (chicken string) + (chicken io) + (srfi-34) ;;Exception Handling + (srfi-35) ;;Exception Types + (srfi-158) ;;Generators +) - (define (pk . args) ;; peek stuff, debug helper. - (write args (current-error-port)) - (display #\newline (current-error-port)) - (flush-output-port (current-error-port)) - (car (reverse args))) +(include-relative "../srfi-180.impl.scm") -(define filename "../srfi.180.checks.scm") +(test-group "Whitespace predicate" + (test "#\\space" + #t (is-whitespace? #\space))) - (define-syntax define-syntax-rule - (syntax-rules () - ((define-syntax-rule (keyword args ...) body) - (define-syntax keyword - (syntax-rules () - ((keyword args ...) body)))))) +(test-group "JSON Generator" + (test "Basic test" + '(array-start 1 2 3 "Hello" object-start "a" 1 object-end array-end) + (with-input-from-string "[1, 2, 3, \"Hello\", {\"a\", 1}] true [5 4 3 2]" + (lambda () + (let ((generator (json-generator))) + (let loop ((accu '())) + (let ((token (generator))) + (if (not (eof-object? token)) + (loop (cons token accu)) + (reverse accu))))))))) - (define-syntax-rule (check expected actual) - (lambda () - (let ((expected* expected)) - (guard (ex (else (vector #f 'exception-raised expected* ex))) - (let ((actual* actual)) - (if (equal? expected* actual*) - (vector #t) - (vector #f 'unexpected-result expected* actual*))))))) +(test-group "Array delimiter reading" + (test "Start delimiter" + '(array-start " " 1) + (let-values (((val input charcount nesting-delta) (read-array-start 0 "[" (lambda () " ")))) + (list val input charcount))) + (test "End delimiter" + '(array-end " " 9) + (let-values (((val input charcount nesting-delta) (read-array-end 8 "]" (lambda () " ")))) + (list val input charcount)))) - (define-syntax-rule (check-raise predicate? actual) - (lambda () - (let ((predicate?* predicate?)) - (guard (ex ((predicate?* ex) (vector #t)) - (else (vector #f 'unexpected-exception predicate?* ex))) - (let ((actual* actual)) - (vector #f 'no-exception predicate?* actual*)))))) +(test-group "Object delimiter reading" + (test "Start delimiter" + '(object-start " " 1) + (let-values (((val input charcount nesting-delta) (read-object-start 0 "{" (lambda () " ")))) + (list val input charcount))) + (test "End delimiter" + '(object-end " " 5) + (let-values (((val input charcount nesting-delta) (read-object-end 4 "}" (lambda () " ")))) + (list val input charcount)))) - (define-syntax-rule (skip test expected actual) - (lambda () - (vector #t))) +(test-group "Null reading" + (let ((input '(#\u #\l #\l #\space))) + (test "Null reading" + '(null #\space 4) + (let-values (((val input charcount nesting-delta) + (read-null-sym 0 #\n (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) - (define (success? v) - (vector-ref v 0)) +(test-group "Boolean reading" + (let ((input '(#\r #\u #\e #\space))) + (test "True values" + '(#t #\space 4) + (let-values (((val input charcount nesting-delta) + (read-boolean 0 #\t (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) - (define (failure? v) - (not (success? v))) +(test-group "Number reading" + (let ((input '(#\2 #\3 #\4 #\space))) + (test "Integer" + '(1234 #\space 4) + (let-values (((val input charcount nesting-delta) + (read-number 0 #\1 (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) - (define (failure-expected v) - (vector-ref v 1)) +(test-group "String reading" + (let ((input '(#\T #\e #\s #\t #\space #\T #\e #\\ #\s #\\ #\" #\t #\" #\space))) + (test "String" + '("Test Te\\s\\\"t" #\space 14) + (let-values (((val input charcount nesting-delta) + (read-string 0 #\" (lambda () (let ((next (car input))) + (set! input (cdr input)) + next))))) + (list val input charcount))))) - (define (failure-actual v) - (vector-ref v 2)) +(test-group "JSON folding" + (test "Single value" + 42 + (with-input-from-string "42 25" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Simple array" + #(24 42 43) + (with-input-from-string "[24 42 43]" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Nested array" + #(24 #(42 24) 42) + (with-input-from-string "[24 [42 24] 42]" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '())))) + (test "Nested object" + '(("a" . 1) ("b" . 2) ("c" . (("d" . 4)))) + (with-input-from-string "{\"a\": 1, \"b\": 2, \"c\": {\"d\": 4}}" + (lambda () + (json-fold json-proc array-start array-end object-start object-end '()))))) -(define (filename->library-name filename) - ;; TODO: try to guess ;) - '(srfi 180 checks)) +(test-group "JSON Accumulator" + (test "Accumulate a number" + "1234" + (with-output-to-string + (lambda () + ((json-accumulator) 1234)))) + (test "Accumulate a string" + "\"Accumulator\"" + (with-output-to-string + (lambda () + ((json-accumulator) "Accumulator")))) + (test "Accumulate a boolean" + "true" + (with-output-to-string + (lambda () + ((json-accumulator) #t)))) + (test "Accumulate an array" + "[1, 2, 3, true, null, \"Test\"]" + (with-output-to-string + (lambda () + ((json-accumulator) + #(1 2 3 #t null "Test"))))) + (test "Accumulate an alist" + "{\"a\": 1, \"b\": 2}" + (with-output-to-string + (lambda () + ((json-accumulator) + '((a . 1) (b . 2))))))) -(define (filename->library-exports filename) - (define library (call-with-input-file filename read)) - (let loop ((forms (cddr library)) - (out '())) - (if (null? forms) - out - (if (and (pair? (car forms)) - (eq? (caar forms) 'export)) - (loop (cdr forms) (append out (cdar forms))) - (loop (cdr forms) out))))) - -(define library-name (filename->library-name filename)) - -(define (check-one? library-name symbol) - (pk library-name symbol) - (let* ((proc (eval `,symbol (environment library-name))) - (out (proc))) - (if (failure? out) - (begin (pk out) #f) - #t))) - -(if (null? (cddr (command-line))) - (let loop ((symbols (filename->library-exports filename)) - (errors? #f)) - (if (null? symbols) - (exit (if errors? 1 0)) - (if (check-one? library-name (car symbols)) - (begin (loop (cdr symbols) #f)) - (loop (cdr symbols) #t)))) - (check-one? library-name (string->symbol (caddr (command-line))))) +(test-exit)