From 5376b17faf8789b38028e032eb8c300dcf39b05f Mon Sep 17 00:00:00 2001 From: Daniel Ziltener Date: Sun, 29 Sep 2024 23:49:37 +0200 Subject: [PATCH] Port to Chicken 6 --- .envrc | 3 +- README.org | 214 +-------- nix/chicken.nix | 126 ++++++ nix/tinycc.nix | 129 ++++++ shell.nix | 34 ++ srfi-180.egg | 2 +- srfi-180.impl.scm | 3 +- srfi-180.org | 1057 --------------------------------------------- srfi-180.scm | 2 +- 9 files changed, 296 insertions(+), 1274 deletions(-) create mode 100644 nix/chicken.nix create mode 100644 nix/tinycc.nix create mode 100644 shell.nix delete mode 100644 srfi-180.org diff --git a/.envrc b/.envrc index 2143b46..04d94ef 100644 --- a/.envrc +++ b/.envrc @@ -1 +1,2 @@ -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.lsp-server 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.lsp-server chickenPackages_5.chickenEggs.test +export NIXPKGS_ALLOW_BROKEN=1 +use nix diff --git a/README.org b/README.org index f341a96..0ea7e20 100644 --- a/README.org +++ b/README.org @@ -1,217 +1,5 @@ # Created 2024-09-14 Sat 14:52 #+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://forgejo.lyrion.ch/Chicken/srfi-180]]. - -** Author - -Daniel Ziltener - -** Version History - -#+name: version-history -| 1.5.1 | Escape sequences | -| 1.5.0 | Reimplementation | -| 1.0.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 +This is a port of SRFI-180 to Chicken Scheme. For documentation, see [[https://wiki.call-cc.org/eggref/5/srfi-180][the Chicken wiki]]. diff --git a/nix/chicken.nix b/nix/chicken.nix new file mode 100644 index 0000000..578c8f5 --- /dev/null +++ b/nix/chicken.nix @@ -0,0 +1,126 @@ +{ + pkgs, + lib, + stdenv, + fetchgit, + fetchurl, + makeWrapper, + darwin, + tcc-mob, + version ? "git", + testers +}: +let + platform = with stdenv; + if isDarwin then "macosx" + else if isCygwin then "cygwin" + else if (isFreeBSD || isOpenBSD) then "bsd" + else if isSunOS then "solaris" + else "linux"; # Should be a sane default +in +stdenv.mkDerivation (finalAttrs: { + pname = "chicken"; + inherit version; + + binaryVersion = 12; + + srcs = [ + (fetchgit { + url = "git://code.call-cc.org/chicken-core"; + rev = "8c16ffb605a89d2f1580e01696d673e71fa1f6c4"; + sha256 = "sha256-y7vFeglKJYyTyW91bvp0ZrcQF18S0SGCZ1rNCx36W4w="; + }) + (fetchurl { + url = "https://code.call-cc.org/dev-snapshots/2024/07/01/chicken-6.0.0-bootstrap.tar.gz"; + sha256 = "sha256-qkcyWzsaN9+HbMBolmv7zeaPrtbaCTGa9HoF2g/3//o="; + }) + ]; + + unpackPhase = '' + cp -r `echo $srcs | awk '{print $1}'`/* . + cp -r `echo $srcs | awk '{print $1}'`/.* . + chmod -R 777 . + mkdir -p boot/snapshot + cd boot + tar xzf `echo $srcs | awk '{print $2}'` + cd .. + echo ${version} > buildid + + cd boot/chicken-6.0.0 + case "${platform}" in + bsd) + mkcmd=gmake;; + *) + mkcmd=make;; + esac + export CC="${tcc-mob}/bin/tcc" + $mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot + $mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot install + cd ../.. + ./configure --chicken "$(pwd)"/boot/snapshot/bin/chicken --c-compiler "${tcc-mob}/bin/tcc" + $mkcmd boot-chicken + ''; + + # Disable two broken tests: "static link" and "linking tests" + postPatch = '' + sed -i tests/runtests.sh -e "/static link/,+4 { s/^/# / }" + sed -i tests/runtests.sh -e "/linking tests/,+11 { s/^/# / }" + ''; + + # -fno-strict-overflow is not a supported argument in clang + hardeningDisable = lib.optionals stdenv.cc.isClang [ "strictoverflow" ]; + + makeFlags = [ + "PLATFORM=${platform}" + "PREFIX=$(out)" + "C_COMPILER=${tcc-mob}/bin/tcc" + "CXX_COMPILER=$(CXX)" + ] ++ (lib.optionals stdenv.isDarwin [ + "XCODE_TOOL_PATH=${darwin.binutils.bintools}/bin" + "LINKER_OPTIONS=-headerpad_max_install_names" + "POSTINSTALL_PROGRAM=install_name_tool" + ]) ++ (lib.optionals (stdenv.hostPlatform != stdenv.buildPlatform) [ + "HOSTSYSTEM=${stdenv.hostPlatform.config}" + "TARGET_C_COMPILER=${tcc-mob}/bin/${stdenv.cc.targetPrefix}tcc" + "TARGET_CXX_COMPILER=${stdenv.cc}/bin/${stdenv.cc.targetPrefix}c++" + ]); + + nativeBuildInputs = [ + makeWrapper + pkgs.hostname + tcc-mob + ] ++ lib.optionals (stdenv.isDarwin && stdenv.isAarch64) [ + darwin.autoSignDarwinBinariesHook + ]; + + configurePhase = '' + ./configure --chicken ./chicken-boot --prefix $PREFIX --platform=$PLATFORM --c-compiler "${tcc-mob}/bin/tcc" + ''; + + doCheck = !stdenv.isDarwin; + postCheck = '' + ./csi -R chicken.pathname -R chicken.platform \ + -p "(assert (equal? \"${toString finalAttrs.binaryVersion}\" (pathname-file (car (repository-path)))))" + ''; + + passthru.tests.version = testers.testVersion { + package = finalAttrs.finalPackage; + command = "csi -version"; + }; + + meta = { + homepage = "https://call-cc.org/"; + license = lib.licenses.bsd3; + maintainers = with lib.maintainers; [ corngood nagy konst-aa ]; + platforms = lib.platforms.unix; + description = "Portable compiler for the Scheme programming language"; + longDescription = '' + CHICKEN is a compiler for the Scheme programming language. + CHICKEN produces portable and efficient C, supports almost all + of the R5RS Scheme language standard, and includes many + enhancements and extensions. CHICKEN runs on Linux, macOS, + Windows, and many Unix flavours. + ''; + }; + +}) diff --git a/nix/tinycc.nix b/nix/tinycc.nix new file mode 100644 index 0000000..603f1a9 --- /dev/null +++ b/nix/tinycc.nix @@ -0,0 +1,129 @@ +{ lib +, copyPkgconfigItems +, fetchFromRepoOrCz +, makePkgconfigItem +, perl +, stdenv +, texinfo +, which +}: + +stdenv.mkDerivation (finalAttrs: { + pname = "tcc-mob"; + version = "0.9.29-unstable-2024-09-16"; + + src = fetchFromRepoOrCz { + repo = "tinycc"; + rev = "b8b6a5fd7b4e8cab8e5a5d01064cf5bf2b5eed95"; + hash = "sha256-jY0P2GErmo//YBaz6u4/jj/voOE3C2JaIDRmo0orXN8="; + }; + + outputs = [ "out" "info" "man" ]; + + nativeBuildInputs = [ + copyPkgconfigItems + perl + texinfo + which + ]; + + strictDeps = true; + + pkgconfigItems = let + libtcc-pcitem = { + name = "libtcc"; + inherit (finalAttrs) version; + cflags = [ "-I${libtcc-pcitem.variables.includedir}" ]; + libs = [ + "-L${libtcc-pcitem.variables.libdir}" + "-Wl,--rpath ${libtcc-pcitem.variables.libdir}" + "-ltcc" + ]; + variables = { + prefix = "${placeholder "out"}"; + includedir = "${placeholder "dev"}/include"; + libdir = "${placeholder "lib"}/lib"; + }; + description = "Tiny C compiler backend"; + }; + in [ + (makePkgconfigItem libtcc-pcitem) + ]; + + postPatch = '' + patchShebangs texi2pod.pl + ''; + + configureFlags = [ + "--cc=$CC" + "--ar=$AR" + "--crtprefix=${lib.getLib stdenv.cc.libc}/lib" + "--sysincludepaths=${lib.getDev stdenv.cc.libc}/include:{B}/include" + "--libpaths=${lib.getLib stdenv.cc.libc}/lib" + # build cross compilers + "--enable-cross" + ] ++ lib.optionals stdenv.hostPlatform.isMusl [ + "--config-musl" + ]; + + preConfigure = let + # To avoid "malformed 32-bit x.y.z" error on mac when using clang + versionIsClean = version: + builtins.match "^[0-9]\\.+[0-9]+\\.[0-9]+" version != null; + in '' + ${ + if stdenv.isDarwin && ! versionIsClean finalAttrs.version + then "echo 'not overwriting VERSION since it would upset ld'" + else "echo ${finalAttrs.version} > VERSION" + } + configureFlagsArray+=("--elfinterp=$(< $NIX_CC/nix-support/dynamic-linker)") + ''; + + env.NIX_CFLAGS_COMPILE = toString (lib.optionals stdenv.cc.isClang [ + "-Wno-error=implicit-int" + "-Wno-error=int-conversion" + ]); + + # Test segfault for static build + doCheck = !stdenv.hostPlatform.isStatic; + + checkTarget = "test"; + # https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10142.html + preCheck = lib.optionalString (stdenv.isDarwin && stdenv.isx86_64) '' + rm tests/tests2/{108,114}* + ''; + + meta = { + homepage = "https://repo.or.cz/tinycc.git"; + description = "Small, fast, and embeddable C compiler and interpreter"; + longDescription = '' + TinyCC (aka TCC) is a small but hyper fast C compiler. Unlike other C + compilers, it is meant to be self-sufficient: you do not need an external + assembler or linker because TCC does that for you. + + TCC compiles so fast that even for big projects Makefiles may not be + necessary. + + TCC not only supports ANSI C, but also most of the new ISO C99 standard + and many GNU C extensions. + + TCC can also be used to make C scripts, i.e. pieces of C source that you + run as a Perl or Python script. Compilation is so fast that your script + will be as fast as if it was an executable. + + TCC can also automatically generate memory and bound checks while allowing + all C pointers operations. TCC can do these checks even if non patched + libraries are used. + + With libtcc, you can use TCC as a backend for dynamic code generation. + ''; + license = with lib.licenses; [ lgpl21Only ]; + mainProgram = "tcc"; + maintainers = with lib.maintainers; [ joachifm AndersonTorres ]; + platforms = lib.platforms.unix; + # https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10199.html + broken = stdenv.isDarwin && stdenv.isAarch64; + }; +}) +# TODO: more multiple outputs +# TODO: self-compilation diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..14068cd --- /dev/null +++ b/shell.nix @@ -0,0 +1,34 @@ +with import { + overlays = [ + (final: prev: { + tcc-mob = final.callPackage ./nix/tinycc.nix { stdenv = final.gcc13Stdenv; }; + chicken = final.callPackage ./nix/chicken.nix { + stdenv = final.gcc13Stdenv; + version = "6.0.0-8c16ffb"; + }; + }) + ]; +}; +mkShell { + packages = with pkgs; [ + tcc-mob + chicken + ] + # ++ (with pkgs.chickenPackages_5.chickenEggs; [ + # apropos + # chicken-doc + # srfi-1 + # srfi-18 + # lsp-server + # srfi-152 + # ]) + ; + shellHook = '' + export CC="${pkgs.tcc-mob}/bin/tcc" + export CHICKEN_INSTALL_PREFIX="$HOME/.chicken" + export CHICKEN_INSTALL_REPOSITORY="$HOME/.chicken/eggs" + export CHICKEN_REPOSITORY_PATH="${pkgs.chicken}/lib/chicken/12:$HOME/.chicken/eggs" + export PATH="$PATH:$CHICKEN_PREFIX" + export CHICKEN_INSTALL_PREFIX="${pkgs.chicken}" + ''; +} diff --git a/srfi-180.egg b/srfi-180.egg index f8d72c8..785a432 100644 --- a/srfi-180.egg +++ b/srfi-180.egg @@ -3,7 +3,7 @@ (synopsis "A JSON parser and printer that supports JSON bigger than memory.") (category parsing) (license "BSD") - (version "1.5.2") + (version "1.5.3") (dependencies srfi-34 srfi-35 srfi-158) (test-dependencies test) (components diff --git a/srfi-180.impl.scm b/srfi-180.impl.scm index 0034d74..a47d4f1 100644 --- a/srfi-180.impl.scm +++ b/srfi-180.impl.scm @@ -1,8 +1,9 @@ (import (scheme) + (only (scheme base) make-parameter) (chicken format) (chicken port) - (chicken string) + (only (chicken string) reverse-list->string) (srfi-34) ;;Exception Handling (srfi-35) ;;Exception Types (srfi-158) ;;Generators diff --git a/srfi-180.org b/srfi-180.org deleted file mode 100644 index 2234aa6..0000000 --- a/srfi-180.org +++ /dev/null @@ -1,1057 +0,0 @@ -#+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 chickenPackages_5.chickenEggs.lsp-server " - (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 (scheme) - (chicken base) - (chicken platform)) - (register-feature! 'srfi-180) - (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))) - (unless (null? 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 (translate-escape char input-proc) - (case char - ((#\") #\") - ((#\') #\') - ((#\\) #\\) - ((#\n) #\newline) - ((#\t) #\tab) - ((#\u) (read-unicode-escape input-proc)) - ((#\x) (read-hex-escape input-proc)) - ((#\O) #\null) - ((#\r) #\return) - ((#\|) #\|) - ((#\v) #\vtab) - ((#\a) #\alarm) - ((#\b) #\backspace))) - - (define (read-hex-escape input-proc) - (let ((pos1 (input-proc)) - (pos2 (input-proc))) - (integer->char - (string->number (list->string (list pos1 pos2)) 16)))) - - (define (read-unicode-escape input-proc) - (let ((pos1 (input-proc)) - (pos2 (input-proc)) - (pos3 (input-proc)) - (pos4 (input-proc))) - (integer->char - (string->number (list->string (list pos1 pos2 pos3 pos4)) 16)))) - - (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)) - ((and (not esc?) (char=? next-char #\\)) - (read-string (+ charcount 1) (input-proc) input-proc #f accu #t)) - (else (let ((current-char (if esc? - (translate-escape next-char input-proc) - next-char))) - (read-string (+ charcount 1) - (input-proc) input-proc - #f - (cons current-char accu) - #f))))) -#+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 Tes\"t" #\space 13) - (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 (null? (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://forgejo.lyrion.ch/Chicken/srfi-180]]. - -** Author - -Daniel Ziltener - -** Version History - -#+name: version-history -| 1.5.2 | Register srfi-180 as a feature | -| 1.5.1 | Escape sequences | -| 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://forgejo.lyrion.ch/Chicken/srfi-180.git") -(uri targz "https://forgejo.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.scm b/srfi-180.scm index a70efbb..ea0b4cd 100644 --- a/srfi-180.scm +++ b/srfi-180.scm @@ -14,7 +14,7 @@ json-accumulator json-write) (import (scheme) - (chicken base) + (chicken base) (chicken platform)) (register-feature! 'srfi-180) (include-relative "srfi-180.impl.scm"))