diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 9da53800..38dcbca1 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -35,16 +35,14 @@ jobs: sudo apt-get update sudo apt-get install libsystemd-dev libx11-dev uuid-dev cd ChezScheme - git checkout v9.6.4 + git checkout v10.3.0 ./configure -m=a6le - cd a6le/c - make -j 4 - cd ../.. - mkdir -p ../build/bin ../build/lib/csv9.6.4/a6le + make kernel + mkdir -p ../build/bin ../build/lib/csv10.3.0/a6le cp a6le/bin/a6le/* ../build/bin - cp boot/a6le/* ../build/lib/csv9.6.4/a6le + cp boot/a6le/* ../build/lib/csv10.3.0/a6le export PATH=$(realpath ../build/bin):${PATH} - export SCHEMEHEAPDIRS=$(realpath ../build/lib/csv9.6.4/a6le): + export SCHEMEHEAPDIRS=$(realpath ../build/lib/csv10.3.0/a6le): git checkout "${RELEASED}" git clean -dxf . ./configure --force -m=a6le @@ -76,9 +74,6 @@ jobs: - machine: i3le os: ubuntu-24.04 chez: main - - machine: a6le - os: ubuntu-24.04 - chez: v9.6.4 - machine: a6le os: ubuntu-24.04 chez: released @@ -147,22 +142,7 @@ jobs: V="${RELEASED}" fi echo "chez=$V" >> "$GITHUB_OUTPUT" - - name: Build Chez Scheme v9.6.4 - if: ${{ matrix.config.chez == 'v9.6.4' && matrix.config.machine == 'a6le' }} - run: | - M=${{ matrix.config.machine }} - cd ChezScheme - git checkout -q -f v9.6.4 - git reset --hard v9.6.4 - ./configure -m=$M - cd $M/c - make - cd ../.. - echo "$(realpath "$PWD/$M/bin/$M")" >> $GITHUB_PATH - echo "SCHEMEHEAPDIRS=$(realpath $PWD/$M/boot/$M)" >> $GITHUB_ENV - echo "done building in $PWD" - name: Build Chez Scheme ${{ steps.resolve.version.chez }} - if: ${{ matrix.config.chez != 'v9.6.4' }} run: | M=${{ matrix.config.machine }} cd ChezScheme diff --git a/README.md b/README.md index 65704502..50f56dfd 100644 --- a/README.md +++ b/README.md @@ -51,7 +51,7 @@ scheme, starting with 2.0.0 to avoid confusion with internal projects. ## Linux -- Chez Scheme 9.6.4 or later +- Chez Scheme 10.3.0 or later - GCC, the GNU Compiler Collection - GNU make 4.4 or later - GNU C++ compiler for libuv @@ -61,7 +61,7 @@ scheme, starting with 2.0.0 to avoid confusion with internal projects. ## Mac -- Chez Scheme 9.6.4 or later +- Chez Scheme 10.3.0 or later - coreutils (install via [Homebrew](https://brew.sh): `brew install coreutils`) - cmake for libuv (install via [Homebrew](https://brew.sh): `brew install cmake`) - XCode Command Line Tools @@ -71,7 +71,7 @@ scheme, starting with 2.0.0 to avoid confusion with internal projects. ## Windows -- Chez Scheme 9.6.4 or later +- Chez Scheme 10.3.0 or later - Cygwin or MinGW/MSYS with bash, git, graphviz, grep, perl, texlive, GNU make, etc. - cmake for libuv (https://cmake.org/) diff --git a/doc/reference.bib b/doc/reference.bib index 69900660..f635deae 100644 --- a/doc/reference.bib +++ b/doc/reference.bib @@ -83,6 +83,14 @@ @misc{html5 note={\url{http://www.w3.org/TR/2014/REC-html5-20141028/}} } +@misc{json5, + author={Aseem Kishore and Jordan Tucker}, + title = {{The JSON 5 Data Interchange Format}}, + year = {2018}, + month = {March}, + note={\url{https://spec.json5.org/}} +} + @misc{libuv, title = {{libuv}}, key = {libuv}, diff --git a/doc/swish.tex b/doc/swish.tex index fb1081ec..03badb58 100644 --- a/doc/swish.tex +++ b/doc/swish.tex @@ -31,7 +31,7 @@ \begin{document} \begin{sagianbook}{The Swish Concurrency Engine\\ Version \input{../src/swish/swish-version.include}}{Bob Burger, - editor}{\copyright\ 2018-2025 Beckman Coulter, Inc. + editor}{\copyright\ 2018-2026 Beckman Coulter, Inc. Licensed under the \href{https://opensource.org/licenses/MIT}{MIT License}.} \input{swish/chapters} diff --git a/doc/swish/chapters.tex b/doc/swish/chapters.tex index e0f88310..96dcab40 100644 --- a/doc/swish/chapters.tex +++ b/doc/swish/chapters.tex @@ -12,6 +12,7 @@ \input{swish/log-db} \input{swish/statistics} \input{swish/http} +\input{swish/json} \input{swish/cli} \input{swish/parallel} \input{swish/options} diff --git a/doc/swish/erlang.tex b/doc/swish/erlang.tex index 7d971307..4add29df 100644 --- a/doc/swish/erlang.tex +++ b/doc/swish/erlang.tex @@ -263,12 +263,11 @@ size is set to 1024 with \code{custom-port-buffer-size}.\footnote{1024 was chosen because prior versions of Chez Scheme use 1024 for the buffer size of buffered transcoded ports.} -When compiled with Chez Scheme versions 9.6.2 and later, Swish uses -\code{file-buffer-size} as the buffer size for custom file ports. -The custom binary port read and write -procedures call \code{osi\_read\_port} and \code{osi\_write\_port} -with callbacks that send a message to the calling process, which waits -until it receives the message. +Swish uses \code{file-buffer-size} as the buffer size for custom file +ports. The custom binary port read and write procedures call +\code{osi\_read\_port} and \code{osi\_write\_port} with callbacks that +send a message to the calling process, which waits until it receives +the message. \concern{Using a port from more than one process at the same time may cause errors including buffer corruption.} \mitigation The code is diff --git a/doc/swish/http.tex b/doc/swish/http.tex index 32dd47a8..d3f7c4d7 100644 --- a/doc/swish/http.tex +++ b/doc/swish/http.tex @@ -38,8 +38,7 @@ The HTTP interface provides a basic implementation of the Hypertext Transfer Protocol~\cite{RFC7230} and the WebSocket Protocol~\cite{RFC6455}. The programming interface includes procedures -for the HyperText Markup Language (HTML) version 5~\cite{html5} and -JavaScript Object Notation (JSON)~\cite{RFC7159}. +for the HyperText Markup Language (HTML) version 5~\cite{html5}. \section {Theory of Operation} @@ -918,351 +917,6 @@ \subsection{WebSocket Protocol}\label{sec:websocket-protocol} \var{x} using a bytevector output port transcoded using \code{(make-utf8-transcoder)} and returns the resulting bytevector. -\subsection {JavaScript Object Notation} - -This implementation translates JavaScript types into the following -Scheme types: - -\begin{tabular}{ll} - JavaScript & Scheme \\ \hline - - \code{true} & \code{\#t} \\ - \code{false} & \code{\#f} \\ - \code{null} & \code{\#\textbackslash nul} \\ - \var{string} & \var{string} \\ - \var{number} & \var{number} \\ - \var{array} & \var{list} \\ - \var{object} & hashtable mapping symbols to values \\ - - \hline -\end{tabular} - -This implementation does not range check values to ensure that a -JavaScript implementation can interpret the data. - -\defineentry{json:extend-object} -\begin{syntax} - \code{(json:extend-object \var{ht} [\var{key} \var{value}] \etc)} -\end{syntax} - -The \code{json:extend-object} construct adds the \var{key} / -\var{value} pairs to the hashtable \var{ht} using -\code{hashtable-set!}. Each \var{key} is a literal identifier -or an unquoted expression \code{,\var{e}} that evaluates to a -symbol. The resulting expression returns \var{ht}. - -\defineentry{json:make-object} -\begin{syntax} - \code{(json:make-object [\var{key} \var{value}] \etc)} -\end{syntax} - -The \code{json:make-object} construct expands into a call to -\code{json:extend-object} with a new hashtable. - -\defineentry{json:object?} -\begin{procedure} - \code{(json:object? \var{x})} -\end{procedure} -\returns{} a boolean - -The \code{json:object?} procedure determines whether or not the datum -\var{x} is an object created by \code{json:make-object}. - -\defineentry{json:cells} -\begin{procedure} - \code{(json:cells \var{ht})} -\end{procedure} -\returns{} a vector - -The \code{json:cells} procedure returns a vector containing the -cells of the underlying hashtable. - -\defineentry{json:size} -\begin{procedure} - \code{(json:size \var{ht})} -\end{procedure} -\returns{} an integer - -The \code{json:size} procedure returns the number of cells -in the underlying hashtable. - -\defineentry{json:delete"!} -\begin{procedure} - \code{(json:delete! \var{ht} \var{path})} -\end{procedure} -\returns{} unspecified - -The \code{json:delete!} procedure expects \var{path} to be a symbol or -a non-empty list of symbols. -If \var{path} is a symbol, then \code{json:delete!} is equivalent -to \code{hashtable-delete!}. -Otherwise, \code{json:delete!} follows \var{path} as it descends into -the nested hashtable \var{ht}, treating each element as a key into -the hashtable reached by traversing the preceding elements. -When \code{json:delete!} reaches the final key in \var{path}, -it calls \code{hashtable-delete!} to remove the association for -that key in the hashtable reached at that point. -If any key along the way does not map to a hashtable, -\code{json:delete!} has no effect. - -\defineentry{json:ref} -\begin{procedure} - \code{(json:ref \var{ht} \var{path} \var{default})} -\end{procedure} -\returns{} the value found by traversing \var{path} in \var{ht}, -\var{default} if none - -The \code{json:ref} procedure expects \var{path} to be a symbol or -a non-empty list of symbols. -If \var{path} is a symbol, then \code{json:ref} is equivalent -to \code{hashtable-ref}. -Otherwise, \code{json:ref} follows \var{path} as it descends into -the nested hashtable \var{ht}, treating each element as a key into -the hashtable reached by traversing the preceding elements. -When \code{json:ref} reaches the final key in \var{path}, -it calls \code{hashtable-ref} to retrieve the value of that key -in the hashtable reached at that point. -If any key along the way does not map to a hashtable, -or if the final hashtable does not contain the final key, -\code{json:ref} returns \var{default}. - -\defineentry{json:set"!} -\begin{procedure} - \code{(json:set! \var{ht} \var{path} \var{value})} -\end{procedure} -\returns{} unspecified - -The \code{json:set!} procedure expects \var{path} to be a symbol or -a non-empty list of symbols. -If \var{path} is a symbol, then \code{json:set!} is equivalent -to \code{hashtable-set!}. -Otherwise, \code{json:set!} follows \var{path} as it descends into -the nested hashtable \var{ht}, treating each element as a key into -the hashtable reached by traversing the preceding elements. -When \code{json:set!} reaches the final key in \var{path}, -it calls \code{hashtable-set!} to set that key in the -hashtable reached at that point. -If any key along the way does not map to a hashtable, -\code{json:set!} installs an empty hashtable at that key -before proceding. -If \var{path} is malformed at some point, \code{json:set!} may -still mutate hashtables along the valid portion of the path -before reporting an error. - -\defineentry{json:update"!} -\begin{procedure} - \code{(json:update! \var{ht} \var{path} \var{procedure} \var{default})} -\end{procedure} -\returns{} unspecified - -The \code{json:update!} procedure expects \var{path} to be a symbol or -a non-empty list of symbols. -If \var{path} is a symbol, then \code{json:update!} is equivalent -to \code{hashtable-update!}. -Otherwise, \code{json:update!} follows \var{path} as it descends into -the nested hashtable \var{ht}, treating each element as a key into -the hashtable reached by traversing the preceding elements. -When \code{json:update!} reaches the final key in \var{path}, -it calls \code{hashtable-update!} to update that key in the -hashtable reached at that point. -If any key along the way does not map to a hashtable, -\code{json:update!} installs an empty hashtable at that key -before proceding. -If \var{path} is malformed at some point, \code{json:update!} may -still mutate hashtables along the valid portion of the path -before reporting an error. - -\defineentry{json:read} -\begin{procedure} - \code{(json:read \var{ip} \opt{\var{custom-inflate}})} -\end{procedure} -\returns{} a Scheme object or the eof object - -The \code{json:read} procedure reads characters from the textual -input port \var{ip} and returns an appropriate Scheme object. -When \code{json:read} encounters a JSON object, it builds -the corresponding hashtable and calls \var{custom-inflate} -to perform application-specific conversion. -By default, \var{custom-inflate} is the identity function. - -The following exceptions may be raised: -\begin{itemize} -\item \code{invalid-surrogate-pair} -\item \code{unexpected-eof} -\item \code{\#(unexpected-input \var{data} \var{input-position})} -\end{itemize} - -\defineentry{json:write} -\begin{procedure} - \code{(json:write \var{op} \var{x} \opt{\var{indent}} \opt{\var{custom-write}})} -\end{procedure} -\returns{} unspecified - -The \code{json:write} procedure writes the object \var{x} to the -textual output port \var{op} in JSON format. By default, \code{json:write} -sorts the keys of JSON objects using \code{stringstring} and comparing those strings using the predicate -specified by \code{json:keybytevector} -\begin{procedure} - \code{(json:object->bytevector \var{x} \opt{\var{indent}} \opt{\var{custom-write}})} -\end{procedure} -\returns{} a bytevector - -The \code{json:object->bytevector} procedure calls \code{json:write} -on \var{x} with the optional \var{indent} and \var{custom-write}, if -any, using a bytevector output port transcoded using -\code{(make-utf8-transcoder)} and returns the resulting bytevector. - -\defineentry{json:bytevector->object} -\begin{procedure} - \code{(json:bytevector->object \var{x} \opt{\var{custom-inflate}})} -\end{procedure} -\returns{} a Scheme object - -The \code{json:bytevector->object} procedure creates a bytevector input port -on \var{x}, calls \code{json:read} with the optional \var{custom-inflate}, -if any, and returns the resulting Scheme object after making sure the rest -of the bytevector is only whitespace. - -\defineentry{json:object->string} -\begin{procedure} - \code{(json:object->string \var{x} \opt{\var{indent}} \opt{\var{custom-write}})} -\end{procedure} -\returns{} a JSON formatted string - -The \code{json:object->string} procedure creates a string output port, -calls \code{json:write} on \var{x} with the optional \var{indent} and -\var{custom-write}, if any, and returns the resulting string. - -\defineentry{json:string->object} -\begin{procedure} - \code{(json:string->object \var{x} \opt{\var{custom-inflate}})} -\end{procedure} -\returns{} a Scheme object - -The \code{json:string->object} procedure creates a string input port -on \var{x}, calls \code{json:read} with the optional \var{custom-inflate}, -if any, and returns the resulting Scheme object after making sure the rest -of the string is only whitespace. - -\defineentry{json:write-structural-char} -\begin{procedure} - \code{(json:write-structural-char \var{x} \var{indent} \var{op})} -\end{procedure} -\returns{} the new indent level - -The \code{json:write-structural-char} procedure writes the character -\var{x} at an appropriate \var{indent} level to the textual output -port \var{op}. The character should be one of the following JSON -structural characters: \code{[ ] \{ \} : ,} - -This procedure is intended for use within custom writers passed in to -\code{json:write} and, for performance, it does not check its input arguments. - \section {Published Events} \begin{pubevent}{} diff --git a/doc/swish/json.tex b/doc/swish/json.tex new file mode 100644 index 00000000..7c2a9c05 --- /dev/null +++ b/doc/swish/json.tex @@ -0,0 +1,535 @@ +% Copyright 2018 Beckman Coulter, Inc. +% +% Permission is hereby granted, free of charge, to any person +% obtaining a copy of this software and associated documentation files +% (the "Software"), to deal in the Software without restriction, +% including without limitation the rights to use, copy, modify, merge, +% publish, distribute, sublicense, and/or sell copies of the Software, +% and to permit persons to whom the Software is furnished to do so, +% subject to the following conditions: +% +% The above copyright notice and this permission notice shall be +% included in all copies or substantial portions of the Software. +% +% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +% EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +% MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +% NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +% BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +% ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +% CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +% SOFTWARE. + +\lstdefinelanguage{json}{ + basicstyle=\upshape\mdseries\frenchspacing\ttfamily, + columns=flexible, + string=[s]{"}{"}, + stringstyle=\color{blue}, + comment=[l]{:}, + commentstyle=\color{black}, + escapeinside={|}{|}, + frame=single +} + +\chapter {JSON Interface} + +\section {Introduction} + +The programming interface provides support for JavaScript Object +Notation (JSON)~\cite{RFC7159}. + +This implementation defines a mapping between JSON values and Scheme +values as follows: + +\begin{center} +\begin{tabular}{ll} + JSON & Scheme \\ \hline + + \code{true} & \code{\#t} \\ + \code{false} & \code{\#f} \\ + \code{null} & symbol \code{null} \\ + string & string \\ + number & number \\ + array & list \\ + object & hashtable mapping symbols to values \\ + + \hline +\end{tabular} +\end{center} + +JSON objects are represented as hashtables whose keys are symbols +derived from the corresponding JSON object member names. + +No validation is performed to ensure that numeric values fall within +the range supported by typical JavaScript implementations. As a result, +some values produced by this implementation may not be portable to all +JSON consumers. + +By default, this implementation accepts input conforming to +JSON5~\cite{JSON5}, a superset of JSON. This allows additional syntax +not permitted by standard JSON, including comments, single-quoted +strings, and numeric values such as \code{Infinity}, \code{-Infinity}, +and \code{NaN}. + +Output is, by default, written in standard JSON format. However, the +implementation permits the non-standard numeric values +\code{Infinity}, \code{-Infinity}, and \code{NaN} to be written as +well. This behavior is controlled by an option that is enabled by +default. + +\section {Programming Interface} + +\defineentry{json:extend-object} +\begin{syntax} + \code{(json:extend-object \var{ht} [\var{key} \var{value}] \etc)} +\end{syntax} + +The \code{json:extend-object} construct adds the \var{key} / +\var{value} pairs to the hashtable \var{ht} using +\code{hashtable-set!}. Each \var{key} is a literal identifier +or an unquoted expression \code{,\var{e}} that evaluates to a +symbol. The resulting expression returns \var{ht}. + +\defineentry{json:make-object} +\begin{syntax} + \code{(json:make-object [\var{key} \var{value}] \etc)} +\end{syntax} + +The \code{json:make-object} construct expands into a call to +\code{json:extend-object} with a new hashtable. + +\defineentry{json:object?} +\begin{procedure} + \code{(json:object? \var{x})} +\end{procedure} +\returns{} a boolean + +The \code{json:object?} procedure determines whether or not the datum +\var{x} is an object created by \code{json:make-object}. + +\defineentry{json:cells} +\begin{procedure} + \code{(json:cells \var{ht})} +\end{procedure} +\returns{} a vector + +The \code{json:cells} procedure returns a vector containing the +cells of the underlying hashtable. + +\defineentry{json:size} +\begin{procedure} + \code{(json:size \var{ht})} +\end{procedure} +\returns{} an integer + +The \code{json:size} procedure returns the number of cells +in the underlying hashtable. + +\defineentry{json:delete"!} +\begin{procedure} + \code{(json:delete! \var{ht} \var{path})} +\end{procedure} +\returns{} unspecified + +The \code{json:delete!} procedure expects \var{path} to be a symbol or +a non-empty list of symbols. +If \var{path} is a symbol, then \code{json:delete!} is equivalent +to \code{hashtable-delete!}. +Otherwise, \code{json:delete!} follows \var{path} as it descends into +the nested hashtable \var{ht}, treating each element as a key into +the hashtable reached by traversing the preceding elements. +When \code{json:delete!} reaches the final key in \var{path}, +it calls \code{hashtable-delete!} to remove the association for +that key in the hashtable reached at that point. +If any key along the way does not map to a hashtable, +\code{json:delete!} has no effect. + +\defineentry{json:ref} +\begin{procedure} + \code{(json:ref \var{ht} \var{path} \var{default})} +\end{procedure} +\returns{} the value found by traversing \var{path} in \var{ht}, +\var{default} if none + +The \code{json:ref} procedure expects \var{path} to be a symbol or +a non-empty list of symbols. +If \var{path} is a symbol, then \code{json:ref} is equivalent +to \code{hashtable-ref}. +Otherwise, \code{json:ref} follows \var{path} as it descends into +the nested hashtable \var{ht}, treating each element as a key into +the hashtable reached by traversing the preceding elements. +When \code{json:ref} reaches the final key in \var{path}, +it calls \code{hashtable-ref} to retrieve the value of that key +in the hashtable reached at that point. +If any key along the way does not map to a hashtable, +or if the final hashtable does not contain the final key, +\code{json:ref} returns \var{default}. + +\defineentry{json:set"!} +\begin{procedure} + \code{(json:set! \var{ht} \var{path} \var{value})} +\end{procedure} +\returns{} unspecified + +The \code{json:set!} procedure expects \var{path} to be a symbol or +a non-empty list of symbols. +If \var{path} is a symbol, then \code{json:set!} is equivalent +to \code{hashtable-set!}. +Otherwise, \code{json:set!} follows \var{path} as it descends into +the nested hashtable \var{ht}, treating each element as a key into +the hashtable reached by traversing the preceding elements. +When \code{json:set!} reaches the final key in \var{path}, +it calls \code{hashtable-set!} to set that key in the +hashtable reached at that point. +If any key along the way does not map to a hashtable, +\code{json:set!} installs an empty hashtable at that key +before proceding. +If \var{path} is malformed at some point, \code{json:set!} may +still mutate hashtables along the valid portion of the path +before reporting an error. + +\defineentry{json:update"!} +\begin{procedure} + \code{(json:update! \var{ht} \var{path} \var{procedure} \var{default})} +\end{procedure} +\returns{} unspecified + +The \code{json:update!} procedure expects \var{path} to be a symbol or +a non-empty list of symbols. +If \var{path} is a symbol, then \code{json:update!} is equivalent +to \code{hashtable-update!}. +Otherwise, \code{json:update!} follows \var{path} as it descends into +the nested hashtable \var{ht}, treating each element as a key into +the hashtable reached by traversing the preceding elements. +When \code{json:update!} reaches the final key in \var{path}, +it calls \code{hashtable-update!} to update that key in the +hashtable reached at that point. +If any key along the way does not map to a hashtable, +\code{json:update!} installs an empty hashtable at that key +before proceding. +If \var{path} is malformed at some point, \code{json:update!} may +still mutate hashtables along the valid portion of the path +before reporting an error. + +\defineentry{json:read} +\defineentry{json:read-options} +\phantomsection % make pageref go to correct page for this label +\label{json:read-options} +\begin{procedure} + \code{(json:read \var{ip} \opt{\var{options}})} +\end{procedure} +\returns{} a Scheme object or the eof object + +The \code{json:read} procedure reads characters from the textual input +port \var{ip} and returns an appropriate Scheme object. If no more +input is available, the end-of-file object is returned. + +The optional \var{options} argument is constructed using +\code{(json:read-options (\var{option} \var{value}) \dots)}. The +following options are supported: + +\begin{tabular}{lrp{.5\textwidth}} + option & default & description \\ \hline + + \code{extended-identifiers?} & \code{\#f} & + If true, enables more permissive reading of unquoted symbols. In + value position, this applies to both JSON and JSON5 input. If + \code{json5?} is enabled, it also applies to object member + names. When enabled, unquoted symbols may include characters not + permitted by the JSON5 identifier syntax (for example, hyphenated + identifiers in the style of Scheme). If false, unquoted symbols must + conform to the JSON5 identifier syntax. \\ + + \code{inflate-object} & \code{\#f} & + When a JSON object is read, it is first converted into a hashtable. + If \code{inflate-object} is provided, it is then applied to the + hashtable to perform application-specific transformation. By + default, no transformation is performed. \\ + + \code{inflate-symbol} & \code{\#f} & + Specifies a procedure of one argument for interpreting unquoted + symbols in value position. The procedure is called with the symbol + as its argument and may return any Scheme object. If + \code{inflate-symbol} is \code{\#f}, the occurrence of an unquoted + symbol in value position is an error. This behavior does not apply + to object member names. \\ + + \code{json5?} & \code{\#t} & If \code{\#t}, input is parsed according + to JSON5. If \code{\#f}, only standard JSON syntax is accepted. + +\end{tabular} + +The following exceptions may be raised: +\begin{itemize} +\item \code{invalid-surrogate-pair} +\item \code{\#(json:unexpected-input \var{context} \var{data} \var{input-position} \var{name})} +\end{itemize} + +\defineentry{json:write} +\defineentry{json:write-options} +\phantomsection % make pageref go to correct page for this label +\label{json:write-options} +\begin{procedure} + \code{(json:write \var{op} \var{x} \opt{\var{indent}} \opt{\var{options}})} +\end{procedure} +\returns{} unspecified + +The \code{json:write} procedure writes the object \var{x} to the +textual output port \var{op} in JSON format. By default, \code{json:write} +sorts the keys of JSON objects using \code{stringstring} and comparing those strings using the predicate +specified by \code{json:keybytevector} +\begin{procedure} + \code{(json:object->bytevector \var{x} \opt{\var{indent}} \opt{\var{options}})} +\end{procedure} +\returns{} a bytevector + +The \code{json:object->bytevector} procedure calls \code{json:write} +on \var{x} with the optional \var{indent} and \var{options}, if +any, using a bytevector output port transcoded using +\code{(make-utf8-transcoder)} and returns the resulting bytevector. + +The optional \var{options} argument is defined using +\code{json:write-options} described in +Section~\ref{json:write-options}. + +\defineentry{json:bytevector->object} +\begin{procedure} + \code{(json:bytevector->object \var{x} \opt{\var{options}})} +\end{procedure} +\returns{} a Scheme object + +The \code{json:bytevector->object} procedure creates a bytevector input port +on \var{x}, calls \code{json:read} with the optional \var{options}, +if any, and returns the resulting Scheme object after making sure the rest +of the bytevector is only whitespace. + +The optional \var{options} argument is defined using +\code{json:read-options} described in Section~\ref{json:read-options}. + +\defineentry{json:object->string} +\begin{procedure} + \code{(json:object->string \var{x} \opt{\var{indent}} \opt{\var{options}})} +\end{procedure} +\returns{} a JSON formatted string + +The \code{json:object->string} procedure creates a string output port, +calls \code{json:write} on \var{x} with the optional \var{indent} and +\var{options}, if any, and returns the resulting string. + +The optional \var{options} argument is defined using +\code{json:write-options} described in +Section~\ref{json:write-options}. + +\defineentry{json:string->object} +\begin{procedure} + \code{(json:string->object \var{x} \opt{\var{options}})} +\end{procedure} +\returns{} a Scheme object + +The \code{json:string->object} procedure creates a string input port +on \var{x}, calls \code{json:read} with the optional \var{options}, +if any, and returns the resulting Scheme object after making sure the rest +of the string is only whitespace. + +The optional \var{options} argument is defined using +\code{json:read-options} described in Section~\ref{json:read-options}. + +\defineentry{json:write-structural-char} +\begin{procedure} + \code{(json:write-structural-char \var{x} \var{indent} \var{op})} +\end{procedure} +\returns{} the new indent level + +The \code{json:write-structural-char} procedure writes the character +\var{x} at an appropriate \var{indent} level to the textual output +port \var{op}. The character should be one of the following JSON +structural characters: \code{[ ] \{ \} : ,} + +This procedure is intended for use within custom writers passed in to +\code{json:write} and, for performance, it does not check its input arguments. + +\defineentry{stack->json} +\begin{procedure} + \code{(stack->json \var{k} \opt{\var{max-depth}})} +\end{procedure} +\returns{} a JSON object + +The \code{stack->json} procedure renders the stack of continuation \var{k} +as a JSON object by calling \hyperlink{walk-stack}{\code{walk-stack}}. +The return value may contain the following keys: + +\begin{tabular}{lp{4.6in}} + \code{type} & \code{"stack"} \\ + \code{depth} & the depth of the stack \\ + \code{truncated} & if present, the \var{max-depth} at which the stack dump was truncated \\ + \code{frames} & if present, a list of JSON objects representing stack frames +\end{tabular} + +A stack frame may contain the following keys: + +\begin{tabular}{lp{4.6in}} + \code{type} & \code{"stack-frame"} \\ + \code{depth} & the depth of this frame \\ + \code{source} & if present, a source object for the return point \\ + \code{procedure-source} & if present, a source object for the procedure containing the return point \\ + \code{free} & if present, a list of JSON objects representing free variables +\end{tabular} + +A source object \var{x} with source file descriptor \var{sfd} is +represented by a JSON object containing the following keys: + +\begin{tabular}{lp{4.6in}} + \code{bfp} & \code{(source-object-bfp \var{x})} \\ + \code{efp} & \code{(source-object-efp \var{x})} \\ + \code{path} & \code{(source-file-descriptor-path \var{sfd})} \\ + \code{checksum} & \code{(source-file-descriptor-checksum \var{sfd})} +\end{tabular} + +A free variable with value \var{val} is represented by a JSON object +containing the following keys: + +\begin{tabular}{lp{4.6in}} + \code{name} & a string containing the variable name or its index \\ + \code{value} & the result of \code{\fixtilde(format "~s" \var{val})} \\ +\end{tabular} + +\defineentry{json-stack->string} +\begin{procedure} + \code{(json-stack->string \opt{\var{op}} \var{x})} +\end{procedure} +\returns{} see below + +The two argument form of \code{json-stack->string} prints the +stack represented by JSON object \var{x} to the textual output port \var{op}. +The single argument form of \code{json-stack->string} prints the stack +represented by JSON object \var{x} to a string output port and returns +the resulting string. +In either case, the printed form resembles that generated by \code{dump-stack} +except that source locations are given as file offsets rather than line and character +numbers. diff --git a/doc/swish/log-db.tex b/doc/swish/log-db.tex index 7d8bd916..ead9ce4c 100644 --- a/doc/swish/log-db.tex +++ b/doc/swish/log-db.tex @@ -326,66 +326,6 @@ \var{limit} must be a positive fixnum. To keep insert operations fast, \var{column} should be indexed. -\defineentry{stack->json} -\begin{procedure} - \code{(stack->json \var{k} \opt{\var{max-depth}})} -\end{procedure} -\returns{} a JSON object - -The \code{stack->json} procedure renders the stack of continuation \var{k} -as a JSON object by calling \hyperlink{walk-stack}{\code{walk-stack}}. -The return value may contain the following keys: - -\begin{tabular}{lp{4.6in}} - \code{type} & \code{"stack"} \\ - \code{depth} & the depth of the stack \\ - \code{truncated} & if present, the \var{max-depth} at which the stack dump was truncated \\ - \code{frames} & if present, a list of JSON objects representing stack frames -\end{tabular} - -A stack frame may contain the following keys: - -\begin{tabular}{lp{4.6in}} - \code{type} & \code{"stack-frame"} \\ - \code{depth} & the depth of this frame \\ - \code{source} & if present, a source object for the return point \\ - \code{procedure-source} & if present, a source object for the procedure containing the return point \\ - \code{free} & if present, a list of JSON objects representing free variables -\end{tabular} - -A source object \var{x} with source file descriptor \var{sfd} is -represented by a JSON object containing the following keys: - -\begin{tabular}{lp{4.6in}} - \code{bfp} & \code{(source-object-bfp \var{x})} \\ - \code{efp} & \code{(source-object-efp \var{x})} \\ - \code{path} & \code{(source-file-descriptor-path \var{sfd})} \\ - \code{checksum} & \code{(source-file-descriptor-checksum \var{sfd})} -\end{tabular} - -A free variable with value \var{val} is represented by a JSON object -containing the following keys: - -\begin{tabular}{lp{4.6in}} - \code{name} & a string containing the variable name or its index \\ - \code{value} & the result of \code{\fixtilde(format "~s" \var{val})} \\ -\end{tabular} - -\defineentry{json-stack->string} -\begin{procedure} - \code{(json-stack->string \opt{\var{op}} \var{x})} -\end{procedure} -\returns{} see below - -The two argument form of \code{json-stack->string} prints the -stack represented by JSON object \var{x} to the textual output port \var{op}. -The single argument form of \code{json-stack->string} prints the stack -represented by JSON object \var{x} to a string output port and returns -the resulting string. -In either case, the printed form resembles that generated by \code{dump-stack} -except that source locations are given as file offsets rather than line and character -numbers. - \section {Published Events} \begin{pubevent}{} diff --git a/src/swish/app.ms b/src/swish/app.ms index 323385bd..23e3a996 100644 --- a/src/swish/app.ms +++ b/src/swish/app.ms @@ -125,8 +125,8 @@ ["bummer: foo.\n" ;; when app:name is set, we get app-exception-handler (go "bummer" 'foo)] - ["oops: Invalid datum: \"flobble\".\n" - (go "oops" '#(invalid-datum "flobble"))] + ["oops: Invalid datum while writing JSON: \"flobble\".\n" + (go "oops" '#(json:invalid-datum "flobble"))] ["dang: HTTP handler failed: Exception in cdr: 2 is not a pair.\n" ;; nested exit-reason->english with native exception (go "dang" `#(http-handler-failed ,(guard (c [else c]) (cdr 2))))] @@ -610,20 +610,19 @@ (lambda () (json:object->string (app:config))))] ;; malformed config file [,expected (fake-path "usr" "local" "lib" "zorp" "config")] - [#(EXIT #(invalid-config-file ,expected unexpected-eof)) + [#(EXIT #(invalid-config-file ,@expected #(json:unexpected ,_ #!eof ,_ ,_))) (catch (with-fake-config `("usr" "local" "bin" ,(fix-exe "zorp")) (lambda (op) (display "{" op)) ;; incomplete app:config))] ;; config file contains non-dictionary at top level [,expected (fake-path "usr" "local" "lib" "zorp" "config")] - [#(EXIT #(invalid-config-file ,expected expected-dictionary)) + [#(EXIT #(invalid-config-file ,@expected expected-dictionary)) (catch (with-fake-config `("usr" "local" "bin" ,(fix-exe "zorp")) (lambda (op) (json:write op '("apple" "pear" "banana") 0)) app:config))] ;; config file deleted before we reload, so config is empty - [,expected (fake-path "Applications" "zap.config")] ["got default" (with-fake-config `("Applications" ,(fix-exe "zap")) (lambda (op) diff --git a/src/swish/erlang.ss b/src/swish/erlang.ss index 20ab022d..bba395a5 100644 --- a/src/swish/erlang.ss +++ b/src/swish/erlang.ss @@ -1950,6 +1950,7 @@ (bad-arg 'print-radix x)) x))) (redefine print-record (make-process-parameter #t (lambda (x) (and x #t)))) + (redefine print-subnormal-precision (make-process-parameter #t (lambda (x) (and x #t)))) (redefine print-unicode (make-process-parameter #t (lambda (x) (and x #t)))) (redefine print-vector-length (make-process-parameter #f (lambda (x) (and x #t)))) diff --git a/src/swish/errors.ss b/src/swish/errors.ss index 88b0c10d..83acbeb6 100644 --- a/src/swish/errors.ss +++ b/src/swish/errors.ss @@ -74,14 +74,20 @@ [#(http-unhandled-input ,x) (format "Unhandled HTTP input: ~s." x)] [#(invalid-config-file ,config-file ,reason) (format #f "invalid config file ~s: ~a" config-file (exit-reason->english reason))] [#(invalid-context ,who) (format "Invalid context for ~a." who)] - [#(invalid-datum ,x) (format "Invalid datum: ~s." x)] [#(invalid-intensity ,x) (format "Invalid intensity: ~s." x)] - [#(invalid-number ,x) (format "Invalid number: ~s." x)] [#(invalid-owner ,owner) (format "Invalid owner: ~s." owner)] [#(invalid-period ,period) (format "Invalid period: ~s." period)] [#(invalid-procedure ,proc) (format "Invalid procedure: ~s." proc)] [#(invalid-strategy ,x) (format "Invalid strategy: ~s." x)] [#(io-error ,name ,who ,errno) (format "I/O error ~d from ~a on ~a: ~a." errno who name (errno->english errno))] + [#(json:unexpected ,context ,what ,position ,name) + (let ([eof? (eof-object? what)]) + (format "Unexpected ~:[input~;end-of-file~]~a~@[ while parsing a JSON ~a~]~@[: ~s~]." + eof? + (file-offset->english name position) + context + (and (not eof?) what)))] + [#(json:invalid-datum ,what) (format "Invalid datum while writing JSON: ~s." what)] [#(listen-tcp-failed ,address ,port-number ,who ,errno) (format "Error ~d from ~a when listening on TCP port ~d: ~a." errno who port-number (errno->english errno))] [#(name-already-registered ,pid) (format "Name is already registered to ~s." pid)] [#(osi-error ,name ,who ,errno) (format "Error ~d from ~a during ~a: ~a." errno who name (errno->english errno))] @@ -96,7 +102,6 @@ [#(start-specs #(invalid-type ,x)) (format "Invalid type in start-specs: ~s." x)] [#(timeout-value ,x ,src) (format "Invalid timeout value~a: ~s." (src->english src) x)] [#(type-already-registered ,name) (format "Type ~s is already registered." name)] - [#(unexpected-input ,x ,position) (format "Unexpected input at position ~d: ~s." position x)] [#(unknown-shared-object ,so-name) (format "Unknown shared object ~s." so-name)] [#(unowned-resource ,resource) (format "Unowned resource: ~s." resource)] [#(unsupported-db-version ,name ,version) (format "The database ~s schema version (~a) is unsupported by this software." name version)] @@ -140,6 +145,13 @@ (get-output-string op))] [else (format "~s" x)])])) + (define (file-offset->english file offset) + (cond + [(and file offset) (format " at offset ~a of ~a" offset file)] + [offset (format " at offset ~a" offset)] + [file (format " in ~a" file)] + [else ""])) + (define (src->english x) (match x [#(,at ,offset ,file) (format " ~a offset ~a of ~a" at offset file)] diff --git a/src/swish/foreign.ms b/src/swish/foreign.ms index f0b37d2c..0ef462a6 100644 --- a/src/swish/foreign.ms +++ b/src/swish/foreign.ms @@ -176,7 +176,7 @@ (define (malformed-config-file app-name) (let* ([config-file (path-combine (output-dir) (config-file-name app-name))] - [reason `#(invalid-config-file ,config-file unexpected-eof)]) + [reason `#(invalid-config-file ,config-file #(json:unexpected "object value" #!eof 13 "bytevector"))]) (app-exception app-name (exit-reason->english reason)))) (define (bad-shared-object app-name caught) diff --git a/src/swish/json.ms b/src/swish/json.ms index abb0608f..320cefd7 100644 --- a/src/swish/json.ms +++ b/src/swish/json.ms @@ -29,6 +29,11 @@ (swish testing) ) +(define (fault-reason x) + (match x + [`(catch ,reason) reason] + [,_ #f])) + (define (key->string x) (if (gensym? x) (parameterize ([print-gensym #t]) (format "~s" x)) @@ -39,6 +44,7 @@ (define (dump x) (cond + [(fault-reason x)] [(json:object? x) (vector-map (lambda (cell) (cons (car cell) (dump (cdr cell)))) @@ -46,48 +52,123 @@ [(pair? x) (map dump x)] [else x])) -(define round-trip - (case-lambda - [(x) (round-trip x #f #f)] - [(x custom-write custom-inflate) - (define (->string x) - (if custom-write - (json:object->string x #f custom-write) - (json:object->string x))) - (define (->bytevector x) - (if custom-write - (json:object->bytevector x #f custom-write) - (json:object->bytevector x))) - (define (string-> x) - (if custom-inflate - (json:string->object x custom-inflate) - (json:string->object x))) - (define (bytevector-> x) - (if custom-inflate - (json:bytevector->object x custom-inflate) - (json:bytevector->object x))) - (let ([y (string-> (->string x))]) - (assert (equal? (dump x) (dump y)))) - (let ([y (bytevector-> (->bytevector x))]) - (assert (equal? (dump x) (dump y)))) - 'ok])) +;; Multi-byte characters can cause differences between string and +;; bytevector port-position in errors. In those cases, we use the +;; match pattern to ignore the position. +(define-syntax err + (syntax-rules () + [(_ pat) + (case-lambda + [() 'pat] + [(x) + (match x + [`(catch pat) #t] + [,_ #f])])])) + +(define test-specs + `(;; null + ("null" null) + ("n" ,(err #(json:unexpected "value" #\n 0 ,_))) + ("nully" ,(err #(json:unexpected "value" nully 0 ,_))) + + ;; booleans + ("true" #t) + ("t" ,(err #(json:unexpected "value" #\t 0 ,_))) + ("truey" ,(err #(json:unexpected "value" truey 0 ,_))) + ("false" #f) + ("f" ,(err #(json:unexpected "value" #\f 0 ,_))) + ("falsey" ,(err #(json:unexpected "value" falsey 0 ,_))) -(define test-objs - `(#(#\nul "null") - #(#t "true") - #(#f "false") - #(1 "1") - #(3.1415 "3.1415") - #(-1 "-1") - #(-3.1415 "-3.1415") - #(0.1 "0.1") - #(-0.1 "-0.1") - #(1.2e11 "12.0e10") - #(1.234e10 "1.234e+10") - #(-1.234e-10 "-1.234e-10") - #((1.0 2) "[1.0e0,2]") - #("" "\"\"") - ,@(map (lambda (n) `#(,n ,(format "~d" n))) + ;; numbers + ("0" 0) ; zero integer + ("+0" [json ,(err #(json:unexpected "value" |+0| 0 ,_))] [json5 0]) ; positive zero integer + ("-0" 0) ; negative zero integer + ("0.0" 0.0) ; zero float + ("+0.0" [json ,(err #(json:unexpected "value" |+0.0| 0 ,_))] [json5 0.0]) ; positive zero float + ("-0.0" -0.0) ; negative zero float + ("0e00" 0.0) ; zero integer with zero exponent + ("0e12" 0.0) ; zero integer with integer exponent + ("0e12.3" ,(err #(json:unexpected "number" #\. 4 ,_))) ; zero integer with float exponent + ("0e" ,(err #(json:unexpected "exponent" #!eof 2 ,_))) ; zero integer with incomplete exponent + ("0a" ,(err #(json:unexpected "number" #\a 1 ,_))) ; zero integer with non-number + (".0" [json ,(err #(json:unexpected "value" |.0| 0 ,_))] [json5 0.0]) ; zero leading decimal point + ("+.0" [json ,(err #(json:unexpected "value" |+.0| 0 ,_))] [json5 0.0]) ; positive zero leading decimal point + ("-.0" [json ,(err #(json:unexpected "value" |-.0| 0 ,_))] [json5 -0.0]) ; negative zero leading decimal point + ("0." [json ,(err #(json:unexpected "number" #!eof 2 ,_))] [json5 0.0]) ; zero trailing decimal point + ("+0." [json ,(err #(json:unexpected "value" |+0.| 0 ,_))] [json5 0.0]) ; positive zero trailing decimal point + ("-0." [json ,(err #(json:unexpected "number" #!eof 3 ,_))] [json5 -0.0]) ; negative zero trailing decimal point + ("0x0" [json ,(err #(json:unexpected "number" #\x 1 ,_))] [json5 0]) ; zero hexadecimal + ("-0x0" [json ,(err #(json:unexpected "number" #\x 2 ,_))] [json5 0]) ; negative zero hexadecimal + ("00" ,(err #(json:unexpected "number" #\0 1 ,_))) ; leading zero not allowed + ("-00" ,(err #(json:unexpected "number" #\0 2 ,_))) ; negative leading zero not allowed + ("0x0" [json ,(err #(json:unexpected "number" #\x 1 ,_))] [json5 0]) ; zero hexadecimal + + ("123" 123) ; integer + ("+123" [json ,(err #(json:unexpected "value" |+123| 0 ,_))] [json5 123]) ; positive integer + ("-123" -123) ; negative integer + ("1e23.4" ,(err #(json:unexpected "number" #\. 4 ,_))) ; integer with float exponent + ("1e+23.4" ,(err #(json:unexpected "number" #\. 5 ,_))) ; integer with positive float exponent + ("1e-23.4" ,(err #(json:unexpected "number" #\. 5 ,_))) ; integer with negative float exponent + ("1e0x4" ,(err #(json:unexpected "number" #\x 3 ,_))) ; integer with hexadecimal exponent + ("1e+0x4" ,(err #(json:unexpected "number" #\x 4 ,_))) ; integer with positive hexadecimal exponent + ("1e-0x4" ,(err #(json:unexpected "number" #\x 4 ,_))) ; integer with negative hexadecimal exponent + ("1e23" 1e23) ; integer with integer exponent + ("1e+23" 1e23) ; integer with integer exponent + ("1e-23" 1e-23) ; integer with negative integer exponent + ("1e-0" 1.0) ; integer with negative zero exponent + ("1e+308" 1e308) ; integer with large positive exponent + ("1e-308" 1e-308) ; integer with large negative exponent + ("1e" ,(err #(json:unexpected "exponent" #!eof 2 ,_))) ; integer with non-exponent + ("1e+" ,(err #(json:unexpected "exponent" #!eof 3 ,_))) ; integer with signed non-exponent + + ("3.1415" 3.1415) ; float + ("+3.1415" [json ,(err #(json:unexpected "value" |+3.1415| 0 ,_))] [json5 3.1415]) ; positive float + ("-3.1415" -3.1415) ; negative float + ("0.2" 0.2) ; float leading zero + ("+0.2" [json ,(err #(json:unexpected "value" |+0.2| 0 ,_))] [json5 0.2]) ; positive float leading zero + ("-0.2" -0.2) ; negative float leading zero + ("2." [json ,(err #(json:unexpected "number" #!eof 2 ,_))] [json5 2.0]) ; float with trailing decimal point + ("+2." [json ,(err #(json:unexpected "value" |+2.| 0 ,_))] [json5 2.0]) ; positive float with trailing decimal point + ("-2." [json ,(err #(json:unexpected "number" #!eof 3 ,_))] [json5 -2.0]) ; negative float with trailing decimal point + (".2" [json ,(err #(json:unexpected "value" |.2| 0 ,_))] [json5 0.2]) ; float leading decimal point + ("+.2" [json ,(err #(json:unexpected "value" |+.2| 0 ,_))] [json5 0.2]) ; positive float leading decimal point + ("-.2" [json ,(err #(json:unexpected "value" |-.2| 0 ,_))] [json5 -0.2]) ; negative float leading decimal point + ("12.0e10" 1.2e11) ; float with integer exponent + ("1.234e+10" 1.234e10) ; float with positive integer exponent + ("1.234e-10" 1.234e-10) ; float with negative integer exponent + ("-1.234e-10" -1.234e-10) ; negative float with negative exponent + ("1.e4" [json ,(err #(json:unexpected "number" #\e 2 ,_))] [json5 10000.0]) ; float with trailing decimal point and integer exponent + ("1.234e+308" 1.234e308) ; float with large positive exponent + ("1.234e-308" 1.234e-308) ; float with large negative exponent + + ("0xd00dad" [json ,(err #(json:unexpected "number" #\x 1 ,_))] [json5 #xd00dad]) ; hexadecimal + ("-0xCAB00D1E" [json ,(err #(json:unexpected "number" #\x 2 ,_))] [json5 #x-cab00d1e]) ; leading minus, hexadecimal + ("0xdecafz" ; non-hexadecimal + [json ,(err #(json:unexpected "number" #\x 1 ,_))] + [json5 ,(err #(json:unexpected "hexadecimal number" #\z 7 ,_))]) + ("0x" ; empty hexadecimal + [json ,(err #(json:unexpected "number" #\x 1 ,_))] + [json5 ,(err #(json:unexpected "hexadecimal number" #!eof 2 ,_))]) + + ("Infinity" [json ,(err #(json:unexpected "value" |Infinity| 0 ,_))] [json5 +inf.0]) + ("+Infinity" [json ,(err #(json:unexpected "value" |+Infinity| 0 ,_))] [json5 +inf.0]) + ("-Infinity" [json ,(err #(json:unexpected "value" |-Infinity| 0 ,_))] [json5 -inf.0]) + ("NaN" [json ,(err #(json:unexpected "value" |NaN| 0 ,_))] [json5 +nan.0]) + ("+NaN" [json ,(err #(json:unexpected "value" |+NaN| 0 ,_))] [json5 +nan.0]) + ("-NaN" [json ,(err #(json:unexpected "value" |-NaN| 0 ,_))] [json5 -nan.0]) + + ;; Misc cases + ("." ,(err #(json:unexpected "value" #\. 0 ,_))) ; decimal only + ("-" ,(err #(json:unexpected "value" #\- 0 ,_))) ; minus only + ("+" ,(err #(json:unexpected "value" #\+ 0 ,_))) ; plus only + (".a" ,(err #(json:unexpected "value" |.a| 0 ,_))) ; decimal folloed by non-digit + ("1a" ,(err #(json:unexpected "number" #\a 1 ,_))) ; digit followed by non-digit + ("1.a" ,(err #(json:unexpected "number" #\a 2 ,_))) ; non-digit in float + ("1.2.3" ,(err #(json:unexpected "number" #\. 3 ,_))) ; multiple decimal points + ("1ea" ,(err #(json:unexpected "exponent" #\a 2 ,_))) ; non-digit in exponent + ("1/2" ,(err #(json:unexpected "number" #\/ 1 ,_))) ; Scheme rational is not valid + ("1+2i" ,(err #(json:unexpected "number" #\+ 1 ,_))) ; Scheme complex is not valid + ,@(map (lambda (n) `(,(format "~d" n) ,n)) ; fixnum/bignum border cases (list (most-negative-fixnum) (+ (most-negative-fixnum) 1) @@ -95,48 +176,320 @@ (most-positive-fixnum) (+ (most-positive-fixnum) 1) (fx/ (most-positive-fixnum) 2))) - #(,(list->string (map integer->char (iota #xD800))) - ,(let ([op (open-output-string)]) - (write-char #\" op) - (do ([i 0 (+ i 1)]) [(= i #xD800)] - (let ([c (integer->char i)]) - (cond - [(eqv? c #\x08) (write-char #\\ op) (write-char #\b op)] - [(eqv? c #\x09) (write-char #\\ op) (write-char #\t op)] - [(eqv? c #\x0C) (write-char #\\ op) (write-char #\f op)] - [(eqv? c #\x0A) (write-char #\\ op) (write-char #\n op)] - [(eqv? c #\x0D) (write-char #\\ op) (write-char #\r op)] - [(char<=? c #\x1F) (fprintf op "\\u~4,'0x" i)] - [(memv c '(#\\ #\")) (write-char #\\ op) (write-char c op)] - [else (write-char c op)]))) - (write-char #\" op) - (get-output-string op))) - #("\x1D11E;\x1d11f;\x1d120;" "\"\\uD834\\uDD1E\x1D11F;\\ud834\\udd20\"") - #(,(json:make-object) "{}") - #(,(json:make-object [foo "bar"]) "{\"foo\":\"bar\"}") - #(,(json:make-object [foo "bar"] [baz 123]) - "{\"foo\":\"bar\",\"baz\":123}") - #(() "[]") - #((()) "[[]]") - #((1 "foo") "[1,\"foo\"]") - - #(,(json:make-object [foo '(123)]) "{\"foo\":[123]}") - #(,(json:make-object [,'foo (json:make-object [bar #t])]) - "{\"foo\":{\"bar\":true}}") - - #((-123 "foo" ,(json:make-object [bar '()]) #\nul) - "[-123,\"foo\",{\"bar\":[]},null]") - #(,(json:make-object [,(gensym "bar" "unique-name") 456] [#{foo lish} 789]) - "{\"#{foo lish}\":789,\"#{bar unique-name}\":456}") - #(,(json:make-object [,(string->symbol "#{foo not-gensym") 123]) - "{\"#{foo not-gensym\":123}") - #(,(json:make-object [,(string->symbol "#{looks more like gensym}") 123]) - "{\"#{looks more like gensym}\":123}") + + ;; strings + ("\"\"" "") ; double quoted empty string + ("\"" ,(err #(json:unexpected "string" #!eof 1 ,_))) ; double quoted, no data, no close + ("\"abc\"" "abc") ; double quoted string + ("\"\\\"\"" "\"") ; double quoted, escape double quote + ("\"'\"" "'") ; double quoted, raw single quote + (,(let ([op (open-output-string)]) ; double quoted Unicode and JSON escapes + (write-char #\" op) + (do ([i 0 (+ i 1)]) [(= i #xD800)] + (let ([c (integer->char i)]) + (cond + [(eqv? c #\x08) (write-char #\\ op) (write-char #\b op)] + [(eqv? c #\x09) (write-char #\\ op) (write-char #\t op)] + [(eqv? c #\x0C) (write-char #\\ op) (write-char #\f op)] + [(eqv? c #\x0A) (write-char #\\ op) (write-char #\n op)] + [(eqv? c #\x0D) (write-char #\\ op) (write-char #\r op)] + [(char<=? c #\x1F) (fprintf op "\\u~4,'0x" i)] + [(memv c '(#\\ #\/ #\")) (write-char #\\ op) (write-char c op)] + [else (write-char c op)]))) + (write-char #\" op) + (get-output-string op)) + ,(list->string (map integer->char (iota #xD800)))) + ("\"\\uD834\\uDD1E\x1D11F;\\ud834\\udd20\"" "\x1D11E;\x1d11f;\x1d120;") ; Unicode escapes + ("\"\\u.\"" ; Unicode escape followed by non-hexadecimal digits + ,(err #(json:unexpected "hexadecimal number" #\. 3 ,_))) + + ("''" [json ,(err #(json:unexpected "value" |''| 0 ,_))] [json5 ""]) ; single quoted empty string + ("'" ; single quoted, no data, no close + [json ,(err #(json:unexpected "value" #\' 0 ,_))] + [json5 ,(err #(json:unexpected "string" #!eof 1 ,_))]) + ("'abc'" [json ,(err #(json:unexpected "value" |'abc'| 0 ,_))] [json5 "abc"]) ; single quoted string + ("'\"'" [json ,(err #(json:unexpected "value" |'"'| 0 ,_))] [json5 "\""]) ; single quoted, raw double quote + ("'\\''" [json ,(err #(json:unexpected "value" #\' 2 ,_))] [json5 "'"]) ; single quoted, escape single quote + (,(let ([op (open-output-string)]) ; single quoted Unicode and JSON5 escapes + (write-char #\' op) + (do ([i 0 (+ i 1)]) [(= i #xD800)] + (let ([c (integer->char i)]) + (cond + [(eqv? c #\x08) (write-char #\\ op) (write-char #\b op)] + [(eqv? c #\x09) (write-char #\\ op) (write-char #\t op)] + [(eqv? c #\x0C) (write-char #\\ op) (write-char #\f op)] + [(eqv? c #\x0A) (write-char #\\ op) (write-char #\n op)] + [(eqv? c #\x0B) (write-char #\\ op) (write-char #\v op)] + [(eqv? c #\x0D) (write-char #\\ op) (write-char #\r op)] + [(char<=? c #\x1F) (fprintf op "\\u~4,'0x" i)] + [(memv c '(#\\ #\/ #\')) (write-char #\\ op) (write-char c op)] + [else (write-char c op)]))) + (write-char #\' op) + (get-output-string op)) + [json ,(err ,_)] ; any error is acceptable + [json5 ,(list->string (map integer->char (iota #xD800)))]) + + ("'\\0'" [json ,(err #(json:unexpected "value" #\0 2 ,_))] [json5 "\x0;"]) ; escaped null + ("'\\0a'" ; escaped null followed by non-digit + [json ,(err #(json:unexpected "value" #\0 2 ,_))] + [json5 "\x0;a"]) + ,@(map ; digits cannot follow an escaped null + (lambda (n) + (let ([c (integer->char (+ n (char->integer #\0)))]) + `(,(format "'\\0~a'" c) + ;; These are different positions because JSON doesn't + ;; interpret the single quote as a string, so it fails + ;; when it encounters the first #\0. JSON5 doesn't fail + ;; until it detects a digit after the #\0. + [json ,(err #(json:unexpected "value" #\0 2 ,_))] + [json5 ,(err #(json:unexpected "string" ,c 3 ,_))]))) + (iota 10)) + ,@(map ; reverse solidus cannot be followed by digits [1-9] + (lambda (n) + (let ([c (integer->char (+ n (char->integer #\1)))]) + `(,(format "'\\~a'" c) + [json ,(err #(json:unexpected "value" ,c 2 ,_))] + [json5 ,(err #(json:unexpected "string" ,c 2 ,_))]))) + (iota 9)) + ,@(map ; reverse solidus followed by non-escape characters + (lambda (c) + `(,(format "'\\~a'" c) + [json ,(err #(json:unexpected "value" ,c 2 ,_))] + [json5 ,(format "~a" c)])) + (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + + (,(let ([op (open-output-string)]) ; hexadecimal escapes + (write-char #\' op) + (do ([i 0 (+ i 1)]) [(= i #xFF)] + (let ([c (integer->char i)]) + (fprintf op "\\x~2,'0x" i))) + (write-char #\' op) + (get-output-string op)) + [json ,(err ,_)] ; any error is acceptable + [json5 ,(list->string (map integer->char (iota #xFF)))]) + + ;; string continuations + ("'hello\\\n world'" [json ,(err #(json:unexpected "value" #\newline 7 ,_))] [json5 "hello world"]) + ("'hello\\\r world'" [json ,(err #(json:unexpected "value" #\return 7 ,_))] [json5 "hello world"]) + ("'hello\\\r\n world'" [json ,(err #(json:unexpected "value" #\return 7 ,_))] [json5 "hello world"]) + ("'hello\\\x2028; world'" [json ,(err #(json:unexpected "value" #\x2028 ,_ ,_))] [json5 "hello world"]) + ("'hello\\\x2029; world'" [json ,(err #(json:unexpected "value" #\x2029 ,_ ,_))] [json5 "hello world"]) + + ,@(map ; unescaped control characters + (lambda (n) + (let ([c (integer->char n)]) + `(,(format "\"~a\"" c) + ,(err #(json:unexpected "string" ,c 1 ,_))))) + (iota #x20)) + + ;; arrays + ("[]" ()) ; empty + ("[[1]]" ((1))) ; nested + ("[1," ,(err #(json:unexpected "array" #!eof 3 ,_))) ; no close bracket + ("[" ,(err #(json:unexpected "array" #!eof 1 ,_))) ; no value, no close bracket + ("[," ,(err #(json:unexpected "value" #\, 1 ,_))) ; no value with comma + ("[}" ,(err #(json:unexpected "value" #\} 1 ,_))) ; mismatched bracket + ("[true,false,null,1,\"two\",3.0]" (#t #f null 1 "two" 3.0)) ; list of values + ("[true,false,null,1,\"two\",3.0,]" ; trailing comma + [json ,(err #(json:unexpected "value" #\] 29 ,_))] + [json5 (#t #f null 1 "two" 3.0)]) + ("[,]" ,(err #(json:unexpected "value" #\, 1 ,_))) ; lone trailing comma + ("[,true,false,null,1,\"two\",3.0,]" ; leading comma + ,(err #(json:unexpected "value" #\, 1 ,_))) + ("[true false]" ,(err #(json:unexpected "array" #\f 6 ,_))) ; no comma + + ;; objects + ("{}" ,(json:make-object)) ; empty + ("{,}" ,(err #(json:unexpected "object key" #\, 1 ,_))) ; lone comma + ("{\"foo\":\"bar\"}" ,(json:make-object [foo "bar"])) ; single key/val + ("{\"foo\":\"bar\",}" ; trailing comma + [json ,(err #(json:unexpected "object key" #\} 13 ,_))] + [json5 ,(json:make-object [foo "bar"])]) + ("{\"foo\":\"bar\" \"foo2\":\"bar2\",}" ,(err #(json:unexpected "object" #\" 13 ,_))) ; no comma + ("{,\"foo\":\"bar\",}" ,(err #(json:unexpected "object key" #\, 1 ,_))) ; leading comma + ("{\"foo\":\"bar\" - }" ,(err #(json:unexpected "object" #\- 13 ,_))) ; trailing other character + ("{\"foo\":\"bar\",\"baz\":123}" ; multiple key/vals + ,(json:make-object [foo "bar"] [baz 123])) + ("{\"hex\":0xdeadbeef,\"other\":123}" ; multiple key/vals with hex value to start + [json ,(err #(json:unexpected "number" #\x 8 ,_))] + [json5 ,(json:make-object [hex #xdeadbeef] [other 123])]) + ("{\"foo\":[123]}" ,(json:make-object [foo '(123)])) ; nested array + ("{\"foo\":{\"bar\":true}}" ; nested object + ,(json:make-object [,'foo (json:make-object [bar #t])])) + ("{\"a\": true, \"a\": false}" ; duplicate keys + ;; JSON specs do not specify behavior. Current behavior is last key wins. + ,(json:make-object [a #f])) + ("{" ,(err #(json:unexpected "object key" #!eof 1 ,_))) ; no value, no close brace + ("{]" ,(err #(json:unexpected "object key" #\] 1 ,_))) ; mismatched bracket + ("{ \"a" ,(err #(json:unexpected "string" #!eof 4 ,_))) ; no close brace, incomplete key + ("{\"a\"" ,(err #(json:unexpected "object value" #!eof 4 ,_))) ; no close brace, no colon + ("{\"a\"_" ,(err #(json:unexpected "object value" #\_ 4 ,_))) ; no close brace, non-colon + ("{\"a\":" ,(err #(json:unexpected "object" #!eof 5 ,_))) ; no close brace, no value + ("{\"a\"}" ,(err #(json:unexpected "object value" #\} 4 ,_))) ; key, no value + ("{1}" ,(err #(json:unexpected "object key" #\1 1 ,_))) ; invalid numeric key, no value + + ("{'foo':\"bar\"}" ; single quoted keys + [json ,(err #(json:unexpected "object key" #\' 1 ,_))] + [json5 ,(json:make-object [foo "bar"])]) + + (,(ct:join #\newline ; unquoted keys + "{" + " hello: \"world\"," + " _: 'underscore'," + " $: 'dollar sign'," + " one1: 'numerals'," + " _$_: 'multiple symbols'," + " $_$hello123world_$_: 'mixed'," + "}") + [json ,(err #(json:unexpected "object key" #\h 4 ,_))] + [json5 ,(json:make-object + [hello "world"] + [_ "underscore"] + [$ "dollar sign"] + [one1 "numerals"] + [_$_ "multiple symbols"] + [$_$hello123world_$_ "mixed"])]) + ("{ true : 1 }" ; unquoted key, cannot be true + [json ,(err #(json:unexpected "object key" #\t 2 ,_))] + [json5 ,(err #(json:unexpected "object key" true 2 ,_))]) + ("{ false : 2 }" ; unquoted key, cannot be false + [json ,(err #(json:unexpected "object key" #\f 2 ,_))] + [json5 ,(err #(json:unexpected "object key" false 2 ,_))]) + ("{ null : 3 }" ; unquoted key, cannot be null + [json ,(err #(json:unexpected "object key" #\n 2 ,_))] + [json5 ,(err #(json:unexpected "object key" null 2 ,_))]) + + ("{ sig\\u03A3ma : 'sum' }" ; Unicode escaped key + [json ,(err #(json:unexpected "object key" #\s 2 ,_))] + [json5 ,(json:make-object [sigΣma "sum"])]) + ("{ sig\x03A3;ma : 'sum' }" ; Unicode non-escaped key + [json ,(err #(json:unexpected "object key" #\s 2 ,_))] + [json5 ,(json:make-object [sigΣma "sum"])]) + ("{ a\x200C;b : 'joined' }" ; Unicode non-escaped ZWNJ + [json ,(err #(json:unexpected "object key" #\a 2 ,_))] + [json5 ,(json:make-object [a\x200C;b "joined"])]) + + ("{ in\\valid : 'invalid' }" ; invalid escaped key + [json ,(err #(json:unexpected "object key" #\i 2 ,_))] + [json5 ,(err #(json:unexpected "object key" #\v 5 ,_))]) + + ;; gensym keys + ("{\"#{foo lish}\":789,\"#{bar unique-name}\":456}" + ,(json:make-object [,(gensym "bar" "unique-name") 456] [#{foo lish} 789])) + ("{\"#{foo not-gensym\":123}" + ,(json:make-object [,(string->symbol "#{foo not-gensym") 123])) + ("{\"#{looks more like gensym}\":123}" + ,(json:make-object [,(string->symbol "#{looks more like gensym}") 123])) + + ;; comments + (,(ct:join #\newline ; block comment + "/* Top-level" + "** multi-line" + "** with tricky stars" + "** block comment */" + "true") + [json ,(err #(json:unexpected "value" |/*| 0 ,_))] + [json5 #t]) + (,(ct:join #\newline ; line comment + "[1, // one" + " 2, // two" + " 3 // three" + "]") + [json ,(err #(json:unexpected "value" |//| 4 ,_))] + [json5 (1 2 3)]) + ("[1, /* one" ; eof while reading block comment + [json ,(err #(json:unexpected "value" |/*| 4 ,_))] + [json5 ,(err #(json:unexpected "comment" #!eof 10 ,_))]) + ("[1, // one" ; eof while reading line comment + [json ,(err #(json:unexpected "value" |//| 4 ,_))] + [json5 ,(err #(json:unexpected "array" #!eof 10 ,_))]) + ("/- this is not a comment -/ false" ; solidus followed by non-comment mark + ,(err #(json:unexpected "value" |/-| 0 ,_))) + ("/" ,(err #(json:unexpected "value" #\/ 0 ,_))) + + ;; whitespace + ;; All 4 JSON whitespace characters before and after other tokens + (" \t\r\n[ \t\r\n1 \t\r\n, \t\r\n2 \t\r\n, \t\r\n3 \t\r\n] \t\r\n" (1 2 3)) + + ;; Most whitespace is outside the JSON spec + ("{ \f a: true }" ; page break + [json ,(err #(json:unexpected "object key" #\page 2 ,_))] + [json5 ,(json:make-object [a #t])]) + ("{ \x205F; a: true }" ; Unicode Medium Mathematical Space (MMSP) + [json ,(err #(json:unexpected "object key" #\x205F ,_ ,_))] + [json5 ,(json:make-object [a #t])]) + ("{ \xFEFF; a: true }" ; Byte order mark + [json ,(err #(json:unexpected "object key" #\xFEFF ,_ ,_))] + [json5 ,(json:make-object [a #t])]) + )) + +;; These specific specs work when reading, but do not round trip. +(define test-specs-read-only + `(("1e+1000" +inf.0) ; integer with excessive positive exponent + ("1e-1000" 0.0) ; integer with excessive negative exponent )) +(define (test-objects json5?) + (fold-right + (lambda (spec acc) + (match spec + [(,input ,expected) + (if (procedure? expected) acc (cons expected acc))] + [(,input [json ,expected] [json5 ,expected5]) + (let* ([acc (if (procedure? expected) acc (cons expected acc))] + [acc (if (or (not json5?) (procedure? expected5)) + acc + (cons expected5 acc))]) + acc)])) + '() + test-specs)) + +(define test-objs (test-objects #f)) +(define test-objs5 (test-objects #t)) + +(define (check-reader ls f) + (define (mismatch input expected result json5?) + `#(mismatch (input ,input) + [,(if json5? 'JSON5 'JSON) + (expected => ,(dump expected)) + (result => ,(dump result))])) + (define (one-read input expected json5? acc) + (let ([result (try (f input (json:read-options [json5? json5?])))]) + (cond + [(equal? result expected) acc] + [(and (hashtable? result) + (hashtable? expected) + (equal? (dump result) (dump expected))) + acc] + [(procedure? expected) + (if (expected result) + acc + (cons (mismatch input (expected) result json5?) acc))] + [else + (cons (mismatch input expected result json5?) acc)]))) + (define (do-read input expected expected5 acc) + (one-read input expected5 #t + (one-read input expected #f acc))) + (let lp ([ls ls] [acc '()]) + (match ls + [() + (unless (null? acc) + (for-each pretty-print (reverse acc)) + (throw `#(FAILED ,(length acc))))] + [(,first . ,rest) + (match first + [(,input ,expected) + (lp rest + (do-read input expected expected acc))] + [(,input [json ,expected] [json5 ,expected5]) + (lp rest + (do-read input expected expected5 acc))])]))) + (mat read () - (assert (eof-object? (json:read (open-input-string "")))) - (assert (eof-object? (json:read (open-input-string " \t \n ")))) + (check-reader (append test-specs test-specs-read-only) + (lambda (str opts) (json:read (open-input-string str) opts))) + ;; json:read should return each value each time its called, allowing + ;; for a sequence of values. (match-let* ([,ip (open-input-string "1 \t \n 2")] [1 (json:read ip)] @@ -145,35 +498,153 @@ 'ok)) (mat string->object () - (for-each - (lambda (obj) - (match-let* ([#(,x ,y) obj]) - (assert (equal? (dump x) (dump (json:string->object y)))))) - test-objs)) + (check-reader (append test-specs test-specs-read-only) + json:string->object) + ;; json:string->object should fail if there is more than one value + ;; in the input. Comments are allowed. + (match-let* + ([`(catch #(json:unexpected #f #\2 9 ,_)) + (try (json:string->object "1 \t \n 2"))] + [1 (json:string->object "1 // line comment" + (json:read-options [json5? #t]))] + [2 (json:string->object "2\n/* one final comment */" + (json:read-options [json5? #t]))]) + 'ok)) (mat bytevector->object () - (for-each - (lambda (obj) - (match-let* ([#(,x ,y) obj]) - (assert (equal? (dump x) (dump (json:bytevector->object (string->utf8 y))))))) - test-objs)) - -(mat round-trip () - (for-each - (lambda (obj) - (match-let* ([#(,x ,_) obj]) - (round-trip x) - ;; show that json:write is immune to print-radix - (parameterize ([print-radix 2]) - (round-trip x)))) - test-objs)) - -(mat whitespace () + ;; There are a few cases where multi-byte characters shift the + ;; port-position in the error message. In those cases, we mark the + ;; expected error as "any" so that any error is acceptable. + (check-reader (append test-specs test-specs-read-only) + (lambda (str opts) + (json:bytevector->object (string->utf8 str) opts))) + ;; json:bytevector->object should fail if there is more than one value + ;; in the input. Comments are allowed. (match-let* - ([(1 2 3) (json:string->object " \t\r\n[ \t\r\n1 \t\r\n, \t\r\n2 \t\r\n, \t\r\n3 \t\r\n] \t\r\n")]) + ([`(catch #(json:unexpected #f #\2 9 ,_)) + (try (json:bytevector->object (string->utf8 "1 \t \n 2")))] + [1 (json:bytevector->object (string->utf8 "1 // line comment") + (json:read-options [json5? #t]))] + [2 (json:bytevector->object (string->utf8 "2\n/* one final comment */") + (json:read-options [json5? #t]))]) 'ok)) +(mat no-lookahead () + ;; unread-char allows only one character of lookahead. String and + ;; bytevector ports may appear to support multiple unread-char + ;; calls, but that behavior is incidental and not guaranteed. This + ;; custom port wrapper causes unread-char to raise an error when + ;; used incorrectly, emulating file and network stream behavior. We + ;; do not use custom-textual-input-port because we cannot correctly + ;; compute port-position. See Chez Scheme's io.ss comments for + ;; details. + (define (make-wrapped-port ip) + (define unread #f) + (define handler + (lambda args + (match args + [(port-name ,_) "wrapped port"] + [(file-position ,_) + (let ([pos (port-position ip)]) + (if unread + (- pos 1) + pos))] + [(read-char ,_) + (if unread + (let ([c unread]) + (set! unread #f) + c) + (read-char ip))] + [(peek-char ,_) + (if unread + unread + (peek-char ip))] + [(unread-char ,c ,_) + (when unread + (errorf 'wrapped-port "cannot call unread-char twice!")) + (set! unread c)]))) + (make-input-port handler "")) + (check-reader test-specs + (lambda (str opts) (json:read (make-wrapped-port (open-input-string str)) opts)))) + +(define (check-round-trip ls f) + (define (one-round-trip obj acc) + (let* ([result (try (f obj))] + [rd (dump result)] + [od (dump obj)]) + (if (equal? od rd) + acc + (cons `#(mismatch (expected => ,od) (result => ,rd)) acc)))) + (let lp ([ls ls] [acc '()]) + (match ls + [() + (unless (null? acc) + (for-each pretty-print (reverse acc)) + (throw `#(FAILED ,(length acc))))] + [(,obj . ,rest) + (lp rest (one-round-trip obj acc))]))) + +(define round-trip + (case-lambda + [(objs json5?) (round-trip objs json5? #f #f)] + [(objs json5? custom-write inflate-object) + (define (->string x) + (cond + [(or json5? custom-write) + (json:object->string x #f + (json:write-options + [json5? json5?] + [custom-write custom-write]))] + [else (json:object->string x)])) + (define (->bytevector x) + (cond + [(or json5? custom-write) + (json:object->bytevector x #f + (json:write-options + [json5? json5?] + [custom-write custom-write]))] + [else (json:object->bytevector x)])) + (define (string-> x) + (cond + [(or json5? inflate-object) + (json:string->object x + (json:read-options + [json5? json5?] + [inflate-object inflate-object]))] + [else (json:string->object x)])) + (define (bytevector-> x) + (cond + [(or json5? inflate-object) + (json:bytevector->object x + (json:read-options + [json5? json5?] + [inflate-object inflate-object]))] + [else (json:bytevector->object x)])) + (check-round-trip objs + (lambda (obj) (string-> (->string obj)))) + (check-round-trip objs + (lambda (obj) (bytevector-> (->bytevector obj)))) + 'ok])) + +(mat round-trip () + (round-trip test-objs #f) + (round-trip test-objs5 #t) + ;; show that json:write is immune to print-radix + (parameterize ([print-radix 2]) + (round-trip test-objs #f) + (round-trip test-objs5 #t))) + (mat write-object () + ;; verify syntax error is associated with the bad clause + (assert-syntax-error + (json:write-object op #f json:write + [good "stuff"] + [key 123 write-field-value nonsense]) + "invalid syntax" + (lambda (input violation-form) + (match (syntax->datum violation-form) + [(key 123 write-field-value nonsense) 'ok]))) + (let-values ([(op get) (open-string-output-port)]) (match-let* ([,by-write @@ -232,17 +703,21 @@ (begin (json:write-object op #f json:write [pi 3.14] - [zip #\nul]) + [zip 'null]) (get))] [,fail (guard (procedure? fail)) (lambda () ;; no error at expand time - (json:write-object op #f json:write + (json:write-object op #f + (lambda (op x indent) + (json:write op x indent + (json:write-options + [json5? #f]))) [abc 123456] [bad +nan.0]) (get))] - [`(catch #(invalid-datum +nan.0)) (on-exit (get) (try (fail)))] + [`(catch #(json:invalid-datum +nan.0)) (on-exit (get) (try (fail)))] [,write-field-value (lambda (op v indent wr) (if (vector? v) @@ -283,7 +758,7 @@ [abc 123] [n0 (box 0)] [n1 (list (box 1) (box 2))])]) - (json:write op obj 0 custom-write) + (json:write op obj 0 (json:write-options [custom-write custom-write])) (get))] [,@expected (parameterize ([json:custom-write custom-write]) @@ -331,12 +806,14 @@ [abc '#(4 5 6)] [def '(7 8 9)]) 0 - (lambda (op x indent wr) - (cond - [(vector? x) - (wr op (map (lambda (x) (format "~r" x)) (vector->list x)) indent) - #t] - [else #f]))) + (json:write-options + [custom-write + (lambda (op x indent wr) + (cond + [(vector? x) + (wr op (map (lambda (x) (format "~r" x)) (vector->list x)) indent) + #t] + [else #f]))])) (get))] ["{\n \"abc\": [\"four\",\"five\",\"six\"],\n \"def\": [\n 7,\n 8,\n 9\n ],\n \"ghi\": 3\n}\n" (begin @@ -346,13 +823,15 @@ [abc '#(4 5 6)] [def '(7 8 9)]) 0 - (lambda (op x indent wr) - (cond - [(vector? x) - ;; Explicitly bypasses pretty mechanisms. - (fprintf op "[~{\"~r\"~^,~}]" (vector->list x)) - #t] - [else #f]))) + (json:write-options + [custom-write + (lambda (op x indent wr) + (cond + [(vector? x) + ;; Explicitly bypasses pretty mechanisms. + (fprintf op "[~{\"~r\"~^,~}]" (vector->list x)) + #t] + [else #f]))])) (get))] [,goodbye (lambda (op x indent wr) (wr op "goodbye" indent))] ["{\n \"list\": [\n 1,\n 2,\n {\n \"tiki\": \"torch\",\n \"wiki\": \"goodbye\"\n }\n ]\n}\n" @@ -361,14 +840,16 @@ (json:make-object [list (list 1 2 'flubber)]) 0 - (lambda (op x indent wr) - (match x - [flubber - (json:write-object op indent wr - [tiki "torch"] - [wiki "hello" goodbye]) - #t] - [,_ #f]))) + (json:write-options + [custom-write + (lambda (op x indent wr) + (match x + [flubber + (json:write-object op indent wr + [tiki "torch"] + [wiki "hello" goodbye]) + #t] + [,_ #f]))])) (get))] ;; ensure that json:write-object matches json:write ["{}" (compare-output #f)] @@ -383,6 +864,19 @@ ) 'ok))) +(mat pretty-output-port () + ;; Verify json:pretty writes to current-output-port + (let ([op (open-output-string)]) + (parameterize ([current-output-port op]) + (json:pretty #t)) + (match (get-output-string op) + ["true\n" 'ok])) + (let ([op (open-output-string)]) + (parameterize ([current-output-port op]) + (json:pretty #t (json:write-options [custom-write #f]))) + (match (get-output-string op) + ["true\n" 'ok]))) + (mat custom () (define-tuple a b c) (define dne (box #t)) @@ -391,7 +885,7 @@ (if (eq? hit dne) (errorf 'must-ref "did not find ~s" key) hit))) - (define (custom-inflate x) + (define (inflate-object x) (match (json:ref x '_type_ #f) ["" ( make @@ -440,14 +934,11 @@ (and (json:object? y) (compare (hashtable->alist x) (hashtable->alist y)))] [else #f])) - (define (nop-custom-inflate x) x) + (define (nop-inflate-object x) x) (define (nop-custom-write op x indent wr) #f) - ;; test inert custom-write / custom-inflate - (for-each - (lambda (obj) - (match-let* ([#(,x ,_) obj]) - (round-trip x nop-custom-write nop-custom-inflate))) - test-objs) + ;; test inert custom-write / inflate-object + (round-trip test-objs #f nop-custom-write nop-inflate-object) + (round-trip test-objs5 #t nop-custom-write nop-inflate-object) (match-let* ([,x ( make [a "quick"] @@ -464,15 +955,15 @@ [c (json:make-object [take "cake"])]))])] ;; use custom-write ;; first without indentation: - [,string (json:object->string x #f custom-write)] - [ok (compare x (json:string->object string custom-inflate))] - [,bv (json:object->bytevector x #f custom-write)] - [ok (compare x (json:bytevector->object bv custom-inflate))] + [,string (json:object->string x #f (json:write-options [custom-write custom-write]))] + [ok (compare x (json:string->object string (json:read-options [inflate-object inflate-object])))] + [,bv (json:object->bytevector x #f (json:write-options [custom-write custom-write]))] + [ok (compare x (json:bytevector->object bv (json:read-options [inflate-object inflate-object])))] ;; now indent: - [,string (json:object->string x 0 custom-write)] - [ok (compare x (json:string->object string custom-inflate))] - [,bv (json:object->bytevector x 0 custom-write)] - [ok (compare x (json:bytevector->object bv custom-inflate))]) + [,string (json:object->string x 0 (json:write-options [custom-write custom-write]))] + [ok (compare x (json:string->object string (json:read-options [inflate-object inflate-object])))] + [,bv (json:object->bytevector x 0 (json:write-options [custom-write custom-write]))] + [ok (compare x (json:bytevector->object bv (json:read-options [inflate-object inflate-object])))]) 'ok) (match-let* ([,x (vector @@ -480,12 +971,12 @@ ( make [a '#(x y z)] [b 4] [c 7]))] ;; now use custom-write2 ;; without indentation - [,string1 (json:object->string x #f custom-write2)] - [,string2 (json:object->string x 0 custom-write2)] + [,string1 (json:object->string x #f (json:write-options [custom-write custom-write2]))] + [,string2 (json:object->string x 0 (json:write-options [custom-write custom-write2]))] [#f (string=? string1 string2)] [,@string1 (pregexp-replace* "\\s" string2 "")] ;; By design, some vectors in the input are lists in the output. - [,y (json:string->object string1 custom-inflate)] + [,y (json:string->object string1 (json:read-options [inflate-object inflate-object]))] [,@y (let f ([x x]) ;; rebuild x suitable for comparison with y (match x [`( ,a ,b ,c) @@ -540,37 +1031,17 @@ [#(EXIT #(bad-arg json:read ,@ip)) (catch (json:read ip))] [#(EXIT #(bad-arg json:pretty 9)) (catch (json:pretty #t 9))] - [#(EXIT #(invalid-datum 1/2)) (catch (json:object->string 1/2))] - [#(EXIT #(invalid-datum +inf.0)) (catch (json:object->string +inf.0))] - [#(EXIT #(invalid-datum -inf.0)) (catch (json:object->string -inf.0))] - [#(EXIT #(invalid-datum +nan.0)) (catch (json:object->string +nan.0))] - [#(EXIT unexpected-eof) (catch (json:string->object "t"))] - [#(EXIT unexpected-eof) (catch (json:string->object "f"))] - [#(EXIT unexpected-eof) (catch (json:string->object "n"))] - [#(EXIT #(unexpected-input #\, 6)) + [#(EXIT #(json:invalid-datum 1/2)) (catch (json:object->string 1/2))] + [,json-opts (json:write-options [json5? #f])] + [#(EXIT #(json:invalid-datum +inf.0)) (catch (json:object->string +inf.0 #f json-opts))] + [#(EXIT #(json:invalid-datum -inf.0)) (catch (json:object->string -inf.0 #f json-opts))] + [#(EXIT #(json:invalid-datum +nan.0)) (catch (json:object->string +nan.0 #f json-opts))] + [#(EXIT #(json:unexpected "object value" #\, 6 ,_)) (catch (json:string->object "{\"foo\",12}"))] - [#(EXIT unexpected-eof) (catch (json:string->object "\""))] - [#(EXIT unexpected-eof) (catch (json:string->object "["))] - [#(EXIT unexpected-eof) (catch (json:string->object "{"))] - [#(EXIT unexpected-eof) (catch (json:string->object "{\"foo\""))] - [#(EXIT #(unexpected-input #\1 1)) (catch (json:string->object "{1}"))] - [#(EXIT #(unexpected-input #\: 6)) + [#(EXIT #(json:unexpected "object" #\: 6 ,_)) (catch (json:string->object "{\"a\":1:}"))] - [#(EXIT #(unexpected-input #\} 7)) - (catch (json:string->object "{\"a\":1,}"))] - [#(EXIT #(unexpected-input #\} 1)) (catch (json:string->object "[}"))] - [#(EXIT unexpected-eof) (catch (json:string->object "-"))] - [#(EXIT unexpected-eof) (catch (json:string->object "1."))] - [#(EXIT unexpected-eof) (catch (json:string->object "1e"))] - [#(EXIT unexpected-eof) (catch (json:string->object "1e+"))] - [#(EXIT #(unexpected-input #\. 3)) (catch (json:string->object "1.2.3"))] - [#(EXIT #(unexpected-input #\, 1)) (catch (json:string->object "[,"))] - [#(EXIT #(unexpected-input #\] 3)) (catch (json:string->object "[1,]"))] - [#(EXIT #(unexpected-input #\2 3)) (catch (json:string->object "[1 2]"))] - [#(EXIT #(unexpected-input #\. 3)) (catch (json:string->object "\"\\u.\""))] - [#(EXIT #(unexpected-input #\g 2)) (catch (json:string->object "\"\\g\""))] [#(EXIT invalid-surrogate-pair) (catch (json:string->object "\"\\udc00\""))] - [#(EXIT #(unexpected-input #\" 7)) + [#(EXIT #(json:unexpected "string" #\" 7 ,_)) (catch (json:string->object "\"\\ud800\""))] [#(EXIT invalid-surrogate-pair) (catch (json:string->object "\"\\ud800\\ud801\""))]) @@ -626,7 +1097,20 @@ [,proc3 (lambda (a b c) "bad")] [#(EXIT #(bad-arg json:custom-write ,@proc3)) (catch (json:custom-write proc3))] - ) + [`(catch #(bad-arg stack->json 234)) (try (stack->json 234))] + [,empty-stack (json:make-object [type "stack"])] + [`(catch #(bad-arg stack->json port)) + (try (stack->json 'port empty-stack))] + [`(catch #(bad-arg json-stack->string deck)) + (try (json-stack->string 'deck))] + [,ip (open-input-string "")] + [`(catch #(bad-arg json-stack->string ,@ip)) + (try (json-stack->string ip empty-stack))] + [,op (let-values ([(op get) (open-bytevector-output-port)]) op)] + [`(catch #(bad-arg json-stack->string ,@op)) + (try (json-stack->string op empty-stack))] + [`(catch #(bad-arg json-stack->string 123)) + (try (json-stack->string (open-output-string) 123))]) 'ok)) ;; default canonical ordering for JSON serialization @@ -798,3 +1282,72 @@ ;; such as (foo . bar) ;; in particular, we'll smash everything along that path ) + +(mat print-parameters () + (parameterize ([print-radix 16] [print-precision 3] [print-subnormal-precision #t]) + (match-let* + (["123456" (json:object->string 123456)] + ["3141592653589793238462643" (json:object->string 3141592653589793238462643)] + ["10.0" (json:object->string 10.0)] + ["1e-315" (json:object->string 1e-315)]) + 'ok))) + +(mat internal-buffer () + ;; Verify that the internal buffer does not hold state after a + ;; failure. + (match-let* + ([,opts (json:read-options [json5? #f])] + [`(catch ,_) (try (json:string->object "\"foo\\xbar\"" opts))] + ["baz" (json:string->object "\"baz\"" opts)]) + 'ok) + ) + +(mat extended-identifiers () + ;; JSON5 read syntax for identifiers limits to a ECMAScript subset + ;; of characters, yet with Unicode escaping, it can encode almost + ;; any character. By setting extended-identifiers? we can + ;; Scheme-like identifiers when desired. + (define specs + `(("{kebab-case-identifier: 'kebab'}" + [json ,(err #(json:unexpected "object key" #\k 1 ,_))] + [json5 ,(json:make-object [kebab-case-identifier "kebab"])]) + )) + (check-reader specs + (lambda (str opts) + (json:string->object str + (json:read-options copy opts [extended-identifiers? #t])))) + + ;; Options + (match-let* + ([#t (begin (json:read-options [extended-identifiers? #f]) #t)] + [#t (begin (json:read-options [extended-identifiers? #t]) #t)] + [,nonsense (lambda (a) #t)] + [`(catch #(bad-arg extended-identifiers? ,@nonsense)) + (try (json:read-options [extended-identifiers? nonsense]))]) + 'ok)) + +(mat inflate-symbol () + ;; Setting inflate-symbol to values allows unquoted symbols as + ;; values. + (define specs + `(("bare" bare) + ("[a1,a2,a3]" (a1 a2 a3)) + ("{\"quoted_key\": unquoted_value}" ,(json:make-object [quoted_key 'unquoted_value])) + ("{unquoted_key: unquoted_value}" + [json ,(err #(json:unexpected "object key" #\u 1 ,_))] + [json5 ,(json:make-object [unquoted_key 'unquoted_value])]) + )) + + (check-reader specs + (lambda (str opts) + (json:string->object str + (json:read-options copy opts [inflate-symbol values])))) + + ;; Options + (match-let* + ([#t (begin (json:read-options [inflate-symbol #f]) #t)] + [#t (begin (json:read-options [inflate-symbol (lambda (a) #t)]) #t)] + [,proc2 (lambda (a b) #t)] + [`(catch #(bad-arg inflate-symbol ,@proc2)) + (try (json:read-options [inflate-symbol proc2]))]) + 'ok)) diff --git a/src/swish/json.ss b/src/swish/json.ss index 93157a6a..87f66fac 100644 --- a/src/swish/json.ss +++ b/src/swish/json.ss @@ -23,18 +23,21 @@ #!chezscheme (library (swish json) (export + json-stack->string json:bytevector->object json:cells json:custom-write json:delete! json:extend-object json:keybytevector json:object->string json:object? json:pretty json:read + json:read-options json:ref json:set! json:size @@ -42,7 +45,9 @@ json:update! json:write json:write-object + json:write-options json:write-structural-char + stack->json ) (import (chezscheme) @@ -54,6 +59,32 @@ (swish string-utils) ) + (define-options json:read-options + (optional + [extended-identifiers? + (default #f) + (must-be boolean?)] + [inflate-object + (default #f) + (must-be valid-inflate-object?)] + [inflate-symbol + (default #f) + (must-be (lambda (x) (or (not x) (procedure/arity? #b10 x))))] + [json5? + (default #t) + (must-be boolean?)] + )) + + (define-options json:write-options + (optional + [custom-write + (default #f) + (must-be valid-custom-write?)] + [json5? + (default #t) + (must-be boolean?)] + )) + (define-syntax extend-object-internal (syntax-rules () [(_ x $ht (key val) ...) @@ -139,74 +170,249 @@ (unless (json:object? obj) (bad-arg 'json:size obj)) (#3%hashtable-size obj)) - (define (unexpected-input c ip) - (if (eof-object? c) - (throw 'unexpected-eof) - (throw `#(unexpected-input ,c - ,(and (port-has-port-position? ip) - (- (port-position ip) 1)))))) + (define (json:unexpected context what pos name) + (throw `#(json:unexpected ,context ,what ,pos ,name))) + + (define (unexpected-input context what ip) + (json:unexpected context what + (and (port-has-port-position? ip) + ;; read-char advanced the port-position if it returned a + ;; character. + (let ([pos (port-position ip)]) + (if (eof-object? what) + pos + (- pos 1)))) + (port-name ip))) + + (define (unexpected-str context str ip) + (let ([len (string-length str)]) + (json:unexpected context + (if (= len 1) + (string-ref str 0) + (string->symbol str)) + (and (port-has-port-position? ip) (- (port-position ip) len)) + (port-name ip)))) (include "unsafe.ss") - (define (next-char ip) + (define (next-char context ip) (declare-unsafe-primitives read-char) (let ([x (read-char ip)]) (if (eof-object? x) - (throw 'unexpected-eof) + (unexpected-input context x ip) x))) - (define (ws? x) - (memv x '(#\x20 #\x09 #\x0A #\x0D))) + (define (structural? c) + (memv c '(#\{ #\} #\: #\, #\[ #\]))) - (define (next-non-ws ip) - (declare-unsafe-primitives read-char) - (let ([c (read-char ip)]) - (if (ws? c) - (next-non-ws ip) - c))) + (define (ws? x json5?) + (cond + [(not json5?) + (memv x '(#\x20 #\x09 #\x0A #\x0D))] + [(char-whitespace? x)] + [(eqv? x #\xFEFF)] ; Byte order mark + [else #f])) - (define (seek-non-ws ip) + (define (next-non-ws ip json5?) (declare-unsafe-primitives read-char) + (define (read-line-comment) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) c] + [(memv c '(#\newline #\return #\x2028 #\x2029)) + (next-non-ws ip json5?)] + [else (read-line-comment)]))) + (define (read-block-comment) + (let ([c (next-char "comment" ip)]) + (cond + [(eqv? c #\*) + (let inner-lp () + (let ([c2 (next-char "comment" ip)]) + (cond + [(eqv? c2 #\/) (next-non-ws ip json5?)] + [(eqv? c2 #\*) (inner-lp)] + [else (read-block-comment)])))] + [else (read-block-comment)]))) (let ([c (read-char ip)]) (cond [(eof-object? c) c] - [(ws? c) (seek-non-ws ip)] + [(ws? c json5?) + (next-non-ws ip json5?)] + [(and json5? (eqv? c #\/)) + (let ([c2 (peek-char ip)]) + (cond + [(eof-object? c2) c] + [(eqv? c2 #\/) + (read-char ip) + (read-line-comment)] + [(eqv? c2 #\*) + (read-char ip) + (read-block-comment)] + [else + c]))] [else c]))) - (define (read-string ip op) + (define (unicode-escape context ip op) + (let ([x (read-4hexdig ip)]) + (cond + [(<= #xD800 x #xDBFF) ;; high surrogate + (expect-char context #\\ ip) + (expect-char context #\u ip) + (let ([y (read-4hexdig ip)]) + (unless (<= #xDC00 y #xDFFF) + (throw 'invalid-surrogate-pair)) + (write-char + (integer->char + (+ (ash (bitwise-and x #x3FF) 10) + (bitwise-and y #x3FF) + #x10000)) + op))] + [(<= #xDC00 x #xDFFF) (throw 'invalid-surrogate-pair)] + [else (write-char (integer->char x) op) #t]))) + + (define (string-escape ip op) + (declare-unsafe-primitives char=? write-char) + (let ([c (next-char "string" ip)]) + (cond + [(char=? c #\") (write-char c op) #t] + [(char=? c #\\) (write-char c op) #t] + [(char=? c #\/) (write-char c op) #t] + [(char=? c #\b) (write-char #\x08 op) #t] + [(char=? c #\f) (write-char #\x0C op) #t] + [(char=? c #\n) (write-char #\x0A op) #t] + [(char=? c #\r) (write-char #\x0D op) #t] + [(char=? c #\t) (write-char #\x09 op) #t] + [(char=? c #\u) (unicode-escape "string" ip op)] + [else + (unread-char c ip) + #f]))) + + (define (string-escape5 ip op) + (declare-unsafe-primitives char=? write-char) + (or (string-escape ip op) + (let ([c (read-char ip)]) + (cond + [(char=? c #\') (write-char c op) #t] + [(char=? c #\v) (write-char #\x0B op) #t] + [(char=? c #\0) + (let ([c (next-char "string" ip)]) + (cond + [(char<=? #\0 c #\9) + (unread-char c ip) + #f] + [else + (unread-char c ip) + (write-char #\x00 op) + #t]))] + [(char=? c #\x) + (let ([x (read-2hexdig ip)]) + (write-char (integer->char x) op) #t)] + [(char=? c #\newline) #t] + [(char=? c #\return) + (let ([c (next-char "string" ip)]) + (unless (char=? c #\newline) + (unread-char c ip)) + #t)] + [(char=? c #\x2028) #t] ; line separator + [(char=? c #\x2029) #t] ; paragraph separator + [(char<=? #\1 c #\9) + (unread-char c ip) + #f] + [else + (write-char c op) #t])))) + + (define (read-string ip op mark json5?) + (declare-unsafe-primitives char=? write-char) + (let ([c (next-char "string" ip)]) + (cond + [(char=? c mark) (get-json-buffer-string op)] + [(char=? c #\\) + (or (if json5? + (string-escape5 ip op) + (string-escape ip op)) + (unexpected-input "string" (read-char ip) ip)) + (read-string ip op mark json5?)] + [(char<=? c #\x1F) + (unexpected-input "string" c ip)] + [else (write-char c op) (read-string ip op mark json5?)]))) + + (define (json5-strict-char? c first?) + (declare-unsafe-primitives char-general-category) + (cond + [(memq (char-general-category c) '(Lu Ll Lt Lm Lo Nl)) #t] + [(memv c '(#\$ #\_)) #t] + [first? #f] + [(memq (char-general-category c) '(Mn Mc Nd Pc)) #t] + [(memv c '(#\x200C #\x200D)) #t] ; ZWNJ, ZWJ + [else #f])) + + (define (identifier-helper context ip op clean?) + (declare-unsafe-primitives peek-char read-char write-char) + (let lp ([clean? clean?]) + (let ([c (peek-char ip)]) + (cond + [(or (eof-object? c) + (char-whitespace? c) + (structural? c)) + (values (get-output-string op) clean?)] + [(char=? c #\\) + (read-char ip) + (let ([c (next-char context ip)]) + (cond + [(char=? c #\u) + (unicode-escape context ip op) + (lp clean?)] + [else + (unexpected-input context c ip)]))] + [else + (read-char ip) + (write-char c op) + (lp (and clean? (json5-strict-char? c #f)))])))) + + (define (read-unquoted-key c ip op extended?) + (define strict? (not extended?)) (declare-unsafe-primitives write-char) - (let ([c (next-char ip)]) - (case c - [(#\") (get-json-buffer-string op)] - [(#\\) - (let ([c (next-char ip)]) - (case c - [(#\" #\\ #\/) (write-char c op)] - [(#\b) (write-char #\x08 op)] - [(#\f) (write-char #\x0C op)] - [(#\n) (write-char #\x0A op)] - [(#\r) (write-char #\x0D op)] - [(#\t) (write-char #\x09 op)] - [(#\u) - (let ([x (read-4hexdig ip)]) - (cond - [(<= #xD800 x #xDBFF) ;; high surrogate - (expect-char #\\ ip) - (expect-char #\u ip) - (let ([y (read-4hexdig ip)]) - (unless (<= #xDC00 y #xDFFF) - (throw 'invalid-surrogate-pair)) - (write-char - (integer->char - (+ (ash (bitwise-and x #x3FF) 10) - (bitwise-and y #x3FF) - #x10000)) - op))] - [(<= #xDC00 x #xDFFF) (throw 'invalid-surrogate-pair)] - [else (write-char (integer->char x) op)]))] - [else (unexpected-input c ip)])) - (read-string ip op)] - [else (write-char c op) (read-string ip op)]))) + (write-char c op) + (let-values ([(str clean?) (identifier-helper "object key" ip op (and strict? (json5-strict-char? c #t)))]) + (cond + [(and strict? (not clean?)) + (unexpected-str "object key" str ip)] + [else + (let ([sym (string->symbol str)]) + (when (memq sym '(true false null)) + (unexpected-str "object key" str ip)) + sym)]))) + + (define (read-identifier chars ip op json5? extended? inflate-symbol) + (define strict? (not extended?)) + (declare-unsafe-primitives write-char) + (let lp ([chars chars] [clean? strict?]) + (match chars + [() + (let-values ([(str clean?) (identifier-helper "value" ip op clean?)]) + (let ([sym (string->symbol str)]) + (cond + [(eq? sym 'true) #t] + [(eq? sym 'false) #f] + [(eq? sym 'null) 'null] + [(and json5? + (match sym + [Infinity +inf.0] + [+Infinity +inf.0] + [-Infinity -inf.0] + [NaN +nan.0] + [+NaN +nan.0] + [-NaN -nan.0] + [,_ #f]))] + [(and strict? (not clean?)) + (unexpected-str "value" str ip)] + [inflate-symbol + (inflate-symbol sym)] + [else + (unexpected-str "value" str ip)])))] + [(,c . ,chars) + (write-char c op) + (lp chars (and clean? (json5-strict-char? c #f)))]))) (define (read-4hexdig ip) (let* ([x (hex-digit ip)] @@ -215,10 +421,15 @@ [x (+ (ash x 4) (hex-digit ip))]) x)) - (define (expect-char expected ip) - (let ([c (next-char ip)]) + (define (read-2hexdig ip) + (let* ([x (hex-digit ip)] + [x (+ (ash x 4) (hex-digit ip))]) + x)) + + (define (expect-char context expected ip) + (let ([c (next-char context ip)]) (unless (char=? c expected) - (unexpected-input c ip)))) + (unexpected-input context c ip)))) (define-syntax make-write-string (syntax-rules () @@ -236,24 +447,28 @@ (define write-string (make-write-string s op)) + (define (char->hex-digit c) + (cond + [(char<=? #\0 c #\9) (digit-value c)] + [(char<=? #\A c #\F) (- (char->integer c) (- (char->integer #\A) 10))] + [(char<=? #\a c #\f) (- (char->integer c) (- (char->integer #\a) 10))] + [else #f])) + (define (hex-digit ip) - (let ([c (next-char ip)]) - (cond - [(char<=? #\0 c #\9) (digit-value c)] - [(char<=? #\A c #\F) (- (char->integer c) (- (char->integer #\A) 10))] - [(char<=? #\a c #\f) (- (char->integer c) (- (char->integer #\a) 10))] - [else (unexpected-input c ip)]))) + (let ([c (next-char "hexadecimal number" ip)]) + (or (char->hex-digit c) + (unexpected-input "hexadecimal number" c ip)))) (define (digit-value c) (- (char->integer c) (char->integer #\0))) - (define (read-unsigned ip) - (let-values ([(mantissa n c) (read-digits ip 0 0)]) + (define (read-unsigned* chars ip json5?) + (let-values ([(chars mantissa n c) (read-digits chars ip 0 0)]) (cond - [(eqv? n 0) (unexpected-input c ip)] [(eqv? c #\.) - (let-values ([(mantissa m c) (read-digits ip mantissa 0)]) + (let-values ([(chars mantissa m c) (read-digits chars ip mantissa 0)]) (cond - [(eqv? m 0) (unexpected-input c ip)] + [(and (not json5?) (eqv? m 0)) + (unexpected-input "number" c ip)] [(memv c '(#\e #\E)) (read-exp ip mantissa m)] [else (unless (eof-object? c) @@ -265,35 +480,74 @@ (unread-char c ip)) mantissa]))) - (define (read-digits ip mantissa n) - (let ([c (read-char ip)]) + (define (read-unsigned chars ip json5?) + (let ([x (read-unsigned* chars ip json5?)]) + (let ([c (peek-char ip)]) + (unless (or (eof-object? c) + (ws? c json5?) + (structural? c)) + (read-char ip) + (unexpected-input "number" c ip))) + x)) + + (define (read-digits chars ip mantissa n) + (let ([c (if (null? chars) + (read-char ip) + (car chars))] + [chars (if (null? chars) + chars + (cdr chars))]) (cond - [(eof-object? c) (values mantissa n c)] + [(eof-object? c) + (values chars mantissa n c)] [(char<=? #\0 c #\9) - (read-digits ip (+ (* mantissa 10) (digit-value c)) (+ n 1))] + (read-digits chars ip (+ (* mantissa 10) (digit-value c)) (+ n 1))] + [else + (values chars mantissa n c)]))) + + (define (read-hex-digits ip mantissa n json5?) + (let ([c (read-char ip)]) + (cond + [(eof-object? c) + (values mantissa n c)] + [(or (ws? c json5?) + (structural? c)) + (unread-char c ip) + (values mantissa n c)] + [(char->hex-digit c) => + (lambda (value) + (read-hex-digits ip (+ (* mantissa 16) value) (+ n 1) json5?))] [else - (values mantissa n c)]))) + (unexpected-input "hexadecimal number" c ip)]))) + + (define (read-hex ip json5?) + (let-values ([(mantissa n c) (read-hex-digits ip 0 0 json5?)]) + (when (and (= n 0) (zero? mantissa)) + (unexpected-input "hexadecimal number" c ip)) + mantissa)) (define (read-exp ip mantissa m) - (let ([c (next-char ip)]) + (let ([c (next-char "exponent" ip)]) (case c [(#\+) (scale mantissa (- (read-int ip) m))] [(#\-) (scale mantissa (- (- (read-int ip)) m))] [else (unread-char c ip) (scale mantissa (- (read-int ip) m))]))) (define (read-int ip) - (let-values ([(int n c) (read-digits ip 0 0)]) + (let-values ([(chars int n c) (read-digits '() ip 0 0)]) (cond - [(eqv? n 0) (unexpected-input c ip)] + [(eqv? n 0) (unexpected-input "exponent" c ip)] [else (unless (eof-object? c) (unread-char c ip)) int]))) (define (scale mantissa exponent) - (if (>= exponent 0) - (inexact (* mantissa (expt 10 exponent))) - (inexact (/ mantissa (expt 10 (- exponent)))))) + (cond + [(eqv? mantissa 0) 0.0] + [(> exponent 308) +inf.0] + [(>= exponent 0) (inexact (* mantissa (expt 10 exponent)))] + [else (inexact (/ mantissa (expt 10 (- exponent))))])) (define (string->key s) (let ([len (string-length s)]) @@ -305,17 +559,18 @@ (read (open-input-string s)))) (string->symbol s)))) - (define (make-weak-process-local init) + (define (make-weak-process-local init refresh!) (define param (make-process-parameter #f)) (lambda () (let ([val (cond [(param) => car] [else #!bwp])]) (if (not (eq? val #!bwp)) - val + (refresh! val) (let ([val (init)]) (param (weak-cons val #f)) val))))) - (define json-buffer (make-weak-process-local open-output-string)) + (define json-buffer (make-weak-process-local open-output-string + (lambda (op) (set-port-output-index! op 0) op))) (define (get-json-buffer-string op) ;; We don't reset string output port's buffer via get-output-string since ;; we will likely have to regrow the buffer. The collector can reclaim the @@ -329,75 +584,181 @@ ;; Strings and objects are common enough that it appears ;; to be worth resolving json-buffer eagerly and making ;; it available via json-buf within R. - (define-syntactic-monad R json-buf custom-inflate) + (define-syntactic-monad R + json-buf + extended-identifiers? + inflate-object + inflate-symbol + json5? + ) (R define (rd ip) - (let ([c (next-non-ws ip)]) + (let ([c (next-non-ws ip json5?)]) (cond - [(eqv? c #\t) - (expect-char #\r ip) - (expect-char #\u ip) - (expect-char #\e ip) - #t] - [(eqv? c #\f) - (expect-char #\a ip) - (expect-char #\l ip) - (expect-char #\s ip) - (expect-char #\e ip) - #f] - [(eqv? c #\n) - (expect-char #\u ip) - (expect-char #\l ip) - (expect-char #\l ip) - #\nul] - [(eqv? c #\") (read-string ip json-buf)] + [(memv c '(#\} #\: #\, #\] #\\)) (unexpected-input "value" c ip)] + [(or (eqv? c #\") (and json5? (eqv? c #\'))) + (read-string ip json-buf c json5?)] [(eqv? c #\[) - (let lp ([acc '()]) - (let ([c (next-non-ws ip)]) - (cond - [(and (eqv? c #\]) (null? acc)) '()] - [else - (unread-char c ip) - (let* ([acc (cons (R rd () ip) acc)] - [c (next-non-ws ip)]) - (case c - [(#\,) (lp acc)] - [(#\]) (reverse acc)] - [else (unexpected-input c ip)]))])))] + (R read-array () ip)] [(eqv? c #\{) - (custom-inflate - (let lp ([obj (json:make-object)]) - (let ([c (next-non-ws ip)]) - (cond - [(eqv? c #\") - (let* ([key (string->key (read-string ip json-buf))] - [c (next-non-ws ip)]) - (unless (eqv? c #\:) - (unexpected-input c ip)) - (#3%hashtable-set! obj key (R rd () ip))) - (let ([c (next-non-ws ip)]) - (case c - [(#\,) (lp obj)] - [(#\}) obj] - [else (unexpected-input c ip)]))] - [(and (eqv? c #\}) (eqv? (#3%hashtable-size obj) 0)) obj] - [else (unexpected-input c ip)]))))] - [(eqv? c #\-) (- (read-unsigned ip))] - [else (unread-char c ip) (read-unsigned ip)]))) + (R read-object () ip)] + [else + (R read-number-or-identifier () c ip)]))) + + (R define (read-array ip) + (let lp ([acc '()]) + (let ([c (next-non-ws ip json5?)]) + (cond + [(eof-object? c) (unexpected-input "array" c ip)] + [(and (eqv? c #\]) (null? acc)) '()] + [else + (unread-char c ip) + (let* ([acc (cons (R rd () ip) acc)] + [c (next-non-ws ip json5?)]) + (case c + [(#\,) + (if json5? + (let ([c (next-non-ws ip json5?)]) + (case c + [(#\]) (reverse acc)] + [else + (unless (eof-object? c) + (unread-char c ip)) + (lp acc)])) + (lp acc))] + [(#\]) (reverse acc)] + [else (unexpected-input "array" c ip)]))])))) + + (R define (read-object ip) + (inflate-object + (let ([obj (json:make-object)]) + (define (read-key) + (let ([c (next-non-ws ip json5?)]) + (cond + [(eof-object? c) (unexpected-input "object key" c ip)] + [(or (eqv? c #\") (and json5? (eqv? c #\'))) + (read-value (string->key (read-string ip json-buf c json5?)))] + [(and (eqv? c #\}) (eqv? (#3%hashtable-size obj) 0)) obj] + [(and json5? (not (memv c '(#\} #\: #\, #\] #\\)))) + (read-value (read-unquoted-key c ip json-buf extended-identifiers?))] + [else (unexpected-input "object key" c ip)]))) + (define (read-value key) + (let ([c (next-non-ws ip json5?)]) + (cond + [(eof-object? c) + (unexpected-input "object value" c ip)] + [(eqv? c #\:) + (#3%hashtable-set! obj key (R rd () ip))] + [else + (unexpected-input "object value" c ip)])) + (let ([c (next-non-ws ip json5?)]) + (case c + [(#\,) + (if json5? + (let ([c (next-non-ws ip json5?)]) + (case c + [(#\}) obj] + [else + (unless (eof-object? c) + (unread-char c ip)) + (read-key)])) + (read-key))] + [(#\}) obj] + [else (unexpected-input "object" c ip)]))) + (read-key)))) + + (R define (read-number-or-identifier c ip) + (define (sign rchars) + ;; A decimal point is allowed without a leading digit by JSON5. + (let ([c (peek-char ip)]) + (cond + [(or (eof-object? c) + (ws? c json5?) + (structural? c)) + (start-identifier rchars)] + [(char=? #\0 c) + (read-char ip) + (zero (cons c rchars))] + [(char<=? #\1 c #\9) + (read-char ip) + (start-number (cons c rchars))] + [(and json5? (char=? c #\.)) + (read-char ip) + (point (cons c rchars))] + [else + (read-char ip) + (start-identifier (cons c rchars))]))) + (define (zero rchars) + (let ([c (peek-char ip)]) + (cond + [(or (eof-object? c) + (ws? c json5?) + (structural? c)) + (start-number rchars)] + [(char<=? #\0 c #\9) + (read-char ip) + (unexpected-input "number" #\0 ip)] + [(not json5?) + (start-number rchars)] + [else + (read-char ip) + (start-number (cons c rchars))]))) + (define (point rchars) + (let ([c (peek-char ip)]) + (cond + [(or (eof-object? c) + (ws? c json5?) + (structural? c)) + (start-identifier rchars)] + [(char<=? #\0 c #\9) + (read-char ip) + (start-number (cons c rchars))] + [else + (read-char ip) + (start-identifier (cons c rchars))]))) + (define (start-number rchars) + (let lp ([chars (reverse rchars)]) + (match chars + [(#\- . ,rest) (- (lp rest))] + [(#\+ . ,rest) (lp rest)] + [(#\0 ,x) + (guard (memv x '(#\x #\X))) + (read-hex ip json5?)] + [,_ + (read-unsigned chars ip json5?)]))) + (define (start-identifier rchars) + (read-identifier (reverse rchars) ip json-buf json5? extended-identifiers? inflate-symbol)) + (cond + [(eof-object? c) c] + [(char=? c #\-) (sign (list c))] + [(char=? c #\0) (zero (list c))] + [(char<=? #\1 c #\9) (start-number (list c))] + [(not json5?) (start-identifier (list c))] + [(char=? c #\+) (sign (list c))] + [(char=? c #\.) (point (list c))] + [else (start-identifier (list c))])) + + (define (no-inflate-object x) x) (define json:read (case-lambda - [(ip) (json:read ip no-custom-inflate)] - [(ip custom-inflate) + [(ip) (json:read ip (json:read-options))] + [(ip options) (arg-check 'json:read [ip input-port? textual-port?] - [custom-inflate valid-custom-inflate?]) - (let ([x (seek-non-ws ip)]) + [options (json:read-options is?)]) + (let ([x (peek-char ip)]) (cond [(eof-object? x) x] [else - (unread-char x ip) - (R rd ([json-buf (json-buffer)]) ip)]))])) + (match options + [`( + ,extended-identifiers? + ,inflate-object + ,inflate-symbol + ,json5?) + (let ([inflate-object (or inflate-object no-inflate-object)]) + (R rd ([json-buf (json-buffer)]) ip))])]))])) (define (newline-and-indent indent op) (newline op) @@ -450,7 +811,8 @@ (let ([len (string-length (number->string (most-negative-fixnum)))]) (define display-fixnum-buffer (make-weak-process-local - (lambda () (make-string len)))) + (lambda () (make-string len)) + values)) (declare-unsafe-primitives char->integer fx+ fx- fx< fx<= fx= fxabs fxdiv-and-mod integer->char put-string string-set! write-char) ;; #3% (define (digit->char d) @@ -473,8 +835,8 @@ (define (valid-custom-write? x) (or (not x) (procedure/arity? #b10000 x))) - (define (valid-custom-inflate? x) - (procedure/arity? #b10 x)) + (define (valid-inflate-object? x) + (or (not x) (procedure/arity? #b10 x))) (define json:custom-write (make-process-parameter #f @@ -496,7 +858,7 @@ (keysort-key (car x)) (json-key->sort-key (car y)))) v)) - (define-syntactic-monad W op indent custom-write keystring x) op)] + [(bignum? x) (display-string (number->string x) op)] + [(flonum? x) + (cond + [(finite? x) + (parameterize ([print-precision #f] [print-subnormal-precision #f]) + (display-string (number->string x) op))] + [(not json5?) + (throw `#(json:invalid-datum ,x))] + [(eqv? x +inf.0) (display-string "Infinity" op)] + [(eqv? x -inf.0) (display-string "-Infinity" op)] + [else (display-string "NaN" op)])] [(and custom-write (custom-write op x indent))] [(null? x) (display-string "[]" op)] [(pair? x) @@ -541,77 +912,77 @@ (json:write-structural-char #\: indent op) (W wr () val)))) (W finish () #\})))] - [else (throw `#(invalid-datum ,x))])) + [else (throw `#(json:invalid-datum ,x))])) - (define (internal-write op x indent custom-writer default-key ,custom-write ,json5?) options) + (define custom-writer (or custom-write (json:custom-write))) (define key= x 0)))) (define json:write (case-lambda [(op x) (json:write op x #f)] - [(op x indent) (json:write op x indent (json:custom-write))] - [(op x indent custom-writer) + [(op x indent) (json:write op x indent (json:write-options))] + [(op x indent options) (arg-check 'json:write + [op output-port? textual-port?] [indent valid-indent?] - [custom-writer valid-custom-write?]) - (internal-write op x indent custom-writer stringstring (case-lambda [(x) (json:object->string x #f)] - [(x indent) (json:object->string x indent (json:custom-write))] - [(x indent custom-write) + [(x indent) (json:object->string x indent (json:write-options))] + [(x indent options) (let-values ([(op get) (open-string-output-port)]) - (json:write op x indent custom-write) + (json:write op x indent options) (get))])) (define json:string->object (case-lambda - [(x) (json:string->object x no-custom-inflate)] - [(x custom-inflate) - (->object (open-string-input-port x) custom-inflate)])) + [(x) (json:string->object x (json:read-options))] + [(x options) + (->object (open-string-input-port x) options)])) (define json:object->bytevector (case-lambda [(x) (json:object->bytevector x #f)] - [(x indent) (json:object->bytevector x indent (json:custom-write))] - [(x indent custom-write) + [(x indent) (json:object->bytevector x indent (json:write-options))] + [(x indent options) (call-with-bytevector-output-port - (lambda (op) (json:write op x indent custom-write)) + (lambda (op) (json:write op x indent options)) (make-utf8-transcoder))])) (define json:bytevector->object (case-lambda - [(x) (json:bytevector->object x no-custom-inflate)] - [(x custom-inflate) + [(x) (json:bytevector->object x (json:read-options))] + [(x options) (->object (open-bytevector-input-port x (make-utf8-transcoder)) - custom-inflate)])) + options)])) - (define (->object ip custom-inflate) - (let ([obj (json:read ip custom-inflate)]) + (define (->object ip options) + (let ([obj (json:read ip options)]) + (match-define `( ,json5?) options) ;; Make sure there's nothing but whitespace left. - (let ([x (seek-non-ws ip)]) + (let ([x (next-non-ws ip json5?)]) (if (eof-object? x) obj - (unexpected-input x ip))))) - - (define (no-custom-inflate x) x) + (unexpected-input #f x ip))))) (define (write-key indent pre key whole op) ;; pre is a token @@ -645,7 +1016,7 @@ ;; in (W define (wr x) ...) above. (or (boolean? val) (fixnum? val) (string? val) (and (flonum? val) (finite? val)) - (eqv? val #\nul)) + (eq? val 'null)) (eval `(let () (import (swish json)) (json:object->string ,val))))) (lambda (x) (syntax-case x () @@ -734,6 +1105,95 @@ (define json:pretty (case-lambda [(x) (json:pretty x (current-output-port))] - [(x op) - (internal-write op x 0 (json:custom-write) natural-string-cijson + (case-lambda + [(k) (stack->json k 'default)] + [(k max-depth) + (define who 'stack->json) + (define (set-source! obj field x) + (when (source-object? x) + (let ([sfd (source-object-sfd x)]) + (json:set! obj field + (json:make-object + [bfp (source-object-bfp x)] + [efp (source-object-efp x)] + [path (source-file-descriptor-path sfd)] + [checksum (source-file-descriptor-checksum sfd)]))))) + (define (var->json var) + (json:make-object + [name (format "~s" (car var))] + [value (format "~s" (cdr var))])) + (define obj (inspect/object k)) + (unless (eq? 'continuation (obj 'type)) + (bad-arg who k)) + (parameterize ([print-graph #t]) + (let ([stack (json:make-object [type "stack"] [depth (obj 'depth)])]) + (json:set! stack 'frames + (walk-stack k '() + (lambda (description source proc-source free) + (let ([frame + (json:make-object + [type "stack-frame"] + [description description])]) + (set-source! frame 'source source) + (set-source! frame 'procedure-source proc-source) + (when free (json:set! frame 'free (map var->json free))) + frame)) + (lambda (frame base depth next) + (json:set! frame 'depth depth) + (cons frame (next base))) + who + max-depth + (lambda (base depth) + (json:set! stack 'truncated depth) + base))) + stack))])) + + (define json-stack->string + (let () + (define who 'json-stack->string) + (define ($json-stack->string op x) + (define (dump-src prefix) + (lambda (src) + (fprintf op "~@[ ~a~] at offset ~a of ~a" prefix + (json:ref src 'bfp "?") + (json:ref src 'path "?")))) + (define (dump-frame x) + (fprintf op "~a" (json:ref x 'description "?")) + (cond + [(json:ref x 'source #f) => (dump-src #f)] + [(json:ref x 'procedure-source #f) => (dump-src "in procedure")]) + (newline op) + (for-each + (lambda (free) + (fprintf op " ~a: ~a\n" + (json:ref free 'name "?") + (json:ref free 'value "?"))) + (json:ref x 'free '()))) + (unless (and (json:object? x) (equal? "stack" (json:ref x 'type #f))) + (bad-arg who x)) + (for-each dump-frame (json:ref x 'frames '())) + (cond + [(json:ref x 'truncated #f) => + (lambda (max-depth) + (fprintf op "Stack dump truncated due to max-depth = ~a.\n" + max-depth))])) + (case-lambda + [(op x) + (arg-check who [op output-port? textual-port?]) + ($json-stack->string op x)] + [(x) + (let-values ([(op get) (open-string-output-port)]) + ($json-stack->string op x) + (get))]))) ) diff --git a/src/swish/log-db.ms b/src/swish/log-db.ms index ec069ebc..ef10b191 100644 --- a/src/swish/log-db.ms +++ b/src/swish/log-db.ms @@ -420,21 +420,7 @@ (isolate-mat bad-args () (match-let* - ([`(catch #(bad-arg stack->json 234)) (try (stack->json 234))] - [,empty-stack (json:make-object [type "stack"])] - [`(catch #(bad-arg stack->json port)) - (try (stack->json 'port empty-stack))] - [`(catch #(bad-arg json-stack->string deck)) - (try (json-stack->string 'deck))] - [,ip (open-input-string "")] - [`(catch #(bad-arg json-stack->string ,@ip)) - (try (json-stack->string ip empty-stack))] - [,op (let-values ([(op get) (open-bytevector-output-port)]) op)] - [`(catch #(bad-arg json-stack->string ,@op)) - (try (json-stack->string op empty-stack))] - [`(catch #(bad-arg json-stack->string 123)) - (try (json-stack->string (open-output-string) 123))] - [`(catch #(bad-arg log-db:start&link "bad options")) + ([`(catch #(bad-arg log-db:start&link "bad options")) (try (log-db:start&link "bad options"))] [`(catch #(bad-arg create-prune-on-insert-trigger -1)) (try (create-prune-on-insert-trigger 'table 'column -1 10))] diff --git a/src/swish/log-db.ss b/src/swish/log-db.ss index ccd92337..1c44053d 100644 --- a/src/swish/log-db.ss +++ b/src/swish/log-db.ss @@ -29,14 +29,12 @@ create-prune-on-insert-trigger create-table define-simple-events - json-stack->string log-db:event-logger log-db:get-instance-id log-db:setup log-db:start&link log-db:version make-swish-event-logger - stack->json swish-event-logger ) (import @@ -238,88 +236,6 @@ [(json:object? x) (json:object->string x)] [else (parameterize ([print-graph #t]) (format "~s" x))])) - (define stack->json - (case-lambda - [(k) (stack->json k 'default)] - [(k max-depth) - (define who 'stack->json) - (define (set-source! obj field x) - (when (source-object? x) - (let ([sfd (source-object-sfd x)]) - (json:set! obj field - (json:make-object - [bfp (source-object-bfp x)] - [efp (source-object-efp x)] - [path (source-file-descriptor-path sfd)] - [checksum (source-file-descriptor-checksum sfd)]))))) - (define (var->json var) - (json:make-object - [name (format "~s" (car var))] - [value (format "~s" (cdr var))])) - (define obj (inspect/object k)) - (unless (eq? 'continuation (obj 'type)) - (bad-arg who k)) - (parameterize ([print-graph #t]) - (let ([stack (json:make-object [type "stack"] [depth (obj 'depth)])]) - (json:set! stack 'frames - (walk-stack k '() - (lambda (description source proc-source free) - (let ([frame - (json:make-object - [type "stack-frame"] - [description description])]) - (set-source! frame 'source source) - (set-source! frame 'procedure-source proc-source) - (when free (json:set! frame 'free (map var->json free))) - frame)) - (lambda (frame base depth next) - (json:set! frame 'depth depth) - (cons frame (next base))) - who - max-depth - (lambda (base depth) - (json:set! stack 'truncated depth) - base))) - stack))])) - - (define json-stack->string - (let () - (define who 'json-stack->string) - (define ($json-stack->string op x) - (define (dump-src prefix) - (lambda (src) - (fprintf op "~@[ ~a~] at offset ~a of ~a" prefix - (json:ref src 'bfp "?") - (json:ref src 'path "?")))) - (define (dump-frame x) - (fprintf op "~a" (json:ref x 'description "?")) - (cond - [(json:ref x 'source #f) => (dump-src #f)] - [(json:ref x 'procedure-source #f) => (dump-src "in procedure")]) - (newline op) - (for-each - (lambda (free) - (fprintf op " ~a: ~a\n" - (json:ref free 'name "?") - (json:ref free 'value "?"))) - (json:ref x 'free '()))) - (unless (and (json:object? x) (equal? "stack" (json:ref x 'type #f))) - (bad-arg who x)) - (for-each dump-frame (json:ref x 'frames '())) - (cond - [(json:ref x 'truncated #f) => - (lambda (max-depth) - (fprintf op "Stack dump truncated due to max-depth = ~a.\n" - max-depth))])) - (case-lambda - [(op x) - (arg-check who [op output-port? textual-port?]) - ($json-stack->string op x)] - [(x) - (let-values ([(op get) (open-string-output-port)]) - ($json-stack->string op x) - (get))]))) - (define-syntax (log-sql x) (syntax-case x () [(k sql) diff --git a/src/swish/swish-test.ms b/src/swish/swish-test.ms index 912d2be5..4e8084f7 100644 --- a/src/swish/swish-test.ms +++ b/src/swish/swish-test.ms @@ -1296,12 +1296,12 @@ (nonzero-exit (swish-test "--harvest " mo-path1 " " report-file1) '() - "swish-test: cannot load mat results from.*report1.html: Unexpected input at position") + "swish-test: cannot load mat results from.*report1.html: Unexpected input") ;; try loading results from the wrong place (nonzero-exit (swish-test "--load-results " report-file1) '() - "swish-test: cannot load results from.*report1.html: Unexpected input at position") + "swish-test: cannot load results from.*report1.html: Unexpected input") ) (isolate-mat annotation ()