├── .gitignore
├── LICENSE
├── README.org
├── aliases.lisp
├── backend
    ├── cl-json.lisp
    └── jzon.lisp
├── conditions.lisp
├── functions.lisp
├── guix.scm
├── macros.lisp
├── njson.asd
├── njson.lisp
├── package.lisp
└── tests
    ├── baker.json
    ├── package.lisp
    ├── pointer-test.json
    ├── test.json
    └── tests.lisp


/.gitignore:
--------------------------------------------------------------------------------
 1 | # Ignore compiled lisp files
 2 | *.FASL
 3 | *.fasl
 4 | *.fas
 5 | *.lisp-temp
 6 | *.dfsl
 7 | *.pfsl
 8 | *.d64fsl
 9 | *.p64fsl
10 | *.lx64fsl
11 | *.lx32fsl
12 | *.dx64fsl
13 | *.dx32fsl
14 | *.fx64fsl
15 | *.fx32fsl
16 | *.sx64fsl
17 | *.sx32fsl
18 | *.wx64fsl
19 | *.wx32fsl
20 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | BSD 3-Clause License
 2 | 
 3 | Copyright (c) 2022-2025, Atlas Engineer LLC.
 4 | All rights reserved.
 5 | 
 6 | Redistribution and use in source and binary forms, with or without
 7 | modification, are permitted provided that the following conditions are met:
 8 | 
 9 | * Redistributions of source code must retain the above copyright notice, this
10 |   list of conditions and the following disclaimer.
11 | 
12 | * Redistributions in binary form must reproduce the above copyright notice,
13 |   this list of conditions and the following disclaimer in the documentation
14 |   and/or other materials provided with the distribution.
15 | 
16 | * Neither the name of the copyright holder nor the names of its
17 |   contributors may be used to endorse or promote products derived from
18 |   this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 | 


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
  1 | #+TITLE:njson
  2 | 
  3 | *A JSON handling framework aiming for convenience and brevity.*
  4 | 
  5 | NJSON aims to make it extremely convenient for you to decode,
  6 | validate, destructure, process, and encode JSON data, in the minimum
  7 | keystrokes/minutes possible.
  8 | 
  9 | * Getting started
 10 | Clone the Git repository:
 11 | #+begin_src sh
 12 |   git clone --recursive https://github.com/atlas-engineer/njson ~/common-lisp/njson
 13 | #+end_src
 14 | 
 15 | Load NJSON (with a jzon backend) in the REPL:
 16 | #+begin_src lisp
 17 |   ;; Show ASDF where NJSON is.
 18 |   (asdf:load-asd #p"/path/to/checkout/njson.asd")
 19 |   ;; Load it with ASDF.
 20 |   (asdf:load-system :njson/jzon)
 21 |   ;; Alternatively, load it with Quicklisp.
 22 |   (ql:quickload :njson/jzon)
 23 | #+end_src
 24 | 
 25 | And start parsing right away, be it from file:
 26 | #+begin_src lisp
 27 |   (njson:decode #p"/path/to/njson/checkout/tests/test.json")
 28 |   ;; => #(1 3.8 T NIL :NULL "foo" #(1 2 3) #("bar" T :NULL 1000000)
 29 |   ;;      #<HASH-TABLE :TEST EQUAL :COUNT 1 {100EAB1383}>
 30 |   ;;      #<HASH-TABLE :TEST EQUAL :COUNT 3 {100EAB16D3}>)
 31 | 
 32 | #+end_src
 33 | 
 34 | or from string:
 35 | #+begin_src lisp
 36 |   (njson:decode "[\"hello\", 5]")
 37 |   ;; => #("hello", 5)
 38 | #+end_src
 39 | 
 40 | or other specializeable types. Default methods support:
 41 | - pathnames,
 42 | - strings,
 43 | - streams.
 44 | 
 45 | ** Running tests
 46 | Given NJSON backend-agnostic nature, you can only test every particular backend against the uniform set of tests that NJSON provides. So, to test jzon backend, you can do:
 47 | #+begin_src lisp
 48 |   (asdf:test-system :njson/jzon)
 49 | #+end_src
 50 | And, for the CL-JSON backend,
 51 | #+begin_src lisp
 52 |   (asdf:test-system :njson/cl-json)
 53 | #+end_src
 54 | 
 55 | * What NJSON is not (and what it is, instead)
 56 | 
 57 | ** NJSON is not a JSON parsing library.
 58 | 
 59 | It's one level higher: it's a convenience wrapper around your JSON
 60 | parser of choice. NJSON is made in such a way so as to be usable with
 61 | almost any JSON library out there. The bundled backends are jzon
 62 | (reliable, though new), and CL-JSON (fuzzy yet battle-proven).
 63 | 
 64 | - To make NJSON support your preferred JSON parser, you have to
 65 |   specialize as little as two methods: ~decode-from-stream~ and
 66 |   ~encode-to-stream~. If you care about correctness or proper type
 67 |   dispatching, you may also define ~(en|de)code-(to|from)-string~ and
 68 |   ~(en|de)code-(to|from)-file~.
 69 | 
 70 | ** NJSON is not propagating unnecessary dependencies on you.
 71 | 
 72 | The core (~njson~ ASDF system) has no dependencies due to specifying
 73 | only the generics to implement.
 74 | 
 75 | Every other dependency is optional and depends on which backend you
 76 | want to use for parsing.
 77 | 
 78 | ** NJSON is not the fastest JSON handling solution out there.
 79 | 
 80 | Plug-n-play usability and type variety are much higher of a priority
 81 | than the performance. The types NJSON returns from its methods (and
 82 | that your own methods extending NJSON should expect/return) are:
 83 | 
 84 | - Lisp ~real~-s for JSON numbers.
 85 | - Lisp strings for JSON strings.
 86 | - ~:null~ for JSON ~null~.
 87 | - ~t~ for ~true~ and ~nil~ for ~false~.
 88 | - Vectors for JSON arrays.
 89 | - Hash-tables for JSON objects.
 90 | 
 91 | With this basic (yet disjoint) set of types, you can easily ~typecase~
 92 | over NJSON output and make informed decisions about the JSON you
 93 | have. Even if it's some couple of CPU work milliseconds slower than
 94 | handling raw lists. It's faster in human work seconds, which are much
 95 | more valuable.
 96 | 
 97 | ** NJSON is not minimalist.
 98 | 
 99 | NJSON has strict requirements on the returned data, but this
100 | strictness enables a rich set of JSON-handling primitives/helpers. You
101 | can
102 | - ~(:use #:cl #:njson)~ in your packages if you want short and
103 |   convenient JSON operations there. It's safe, because NJSON shadows
104 |   no symbols from CL.
105 | 
106 | - Or you can define a package local nickname for ~:njson/aliases~ to
107 |   be a mere ~j:~ (using ~trivial-package-local-nicknames~), so that
108 |   even shorter helpers (just a couple of characters longer than the
109 |   regular CL constructs) are available:
110 | #+begin_src lisp
111 |   (trivial-package-local-nicknames:add-package-local-nickname :j :njson/aliases :YOUR-PACKAGE)
112 |   ;; And then use it like.
113 |   (j:get ...)
114 |   (j:decode ...)
115 |   (j:if ...)
116 |   (j:match ...)
117 | #+end_src
118 | 
119 | See the next section for the functions/macros NJSON exports.
120 | 
121 | * API
122 | ** FUNCTION njson:jget (alias: njson/aliases:get)
123 | 
124 | Gets the value from the JSON object/array indexed by a certain
125 | key. Note that the second value is a boolean denoting whether the
126 | entry under key is found (like in ~gethash~).
127 | 
128 | #+begin_src lisp
129 |   (defvar data (njson:decode "{\"key\": 5, \"second-key\": [1, 2, false]}"))
130 |   (njson:jget "key" data)
131 |   ;; => 5, T
132 | 
133 |   ;; Index using sequence:
134 |   (njson:jget '("second-key" 1) data)
135 |   ;; => 2, T
136 | 
137 |   ;; Index using JSON Pointer (as pathname):
138 |   (njson:jget #p"/second-key/0" data)
139 |   ;; => 1, T
140 | 
141 |   ;; Modify the element in place:
142 |   (setf (njson:jget #p"/second-key/0" data) 3)
143 |   ;; Another indexing syntax, for no particular reason:
144 |   (njson:jget #("second-key" 0) data)
145 |   ;; => 3, T
146 | #+end_src
147 | 
148 | Note the pathname indexing—it uses the [[https://www.rfc-editor.org/rfc/rfc6901][JSON Pointer]] syntax for indexing convenience.
149 | 
150 | ** FUNCTION njson:jget* (alias: njson/aliases:get*)
151 | 
152 | A stricter version of =jget= that throws =no-key= error when there's nothing under the given key in the provided object.
153 | 
154 | Will be merged into =jget= with the next major release.
155 | 
156 | ** FUNCTION njson:jcopy (alias: njson/aliases:copy)
157 | 
158 | Copies the whole thing it's passed, no mater the nesting, into a fresh new equal object. Makes all the arrays adjustable and fillable for further possibly destructive use.
159 | 
160 | #+begin_src lisp
161 |   (defvar data (njson:jget "key" (njson:decode "{\"key\": 5}")))
162 |   ;; => 5, T
163 |   (njson:jget "key" (njson:jcopy data))
164 |   ;; => 5, T
165 | #+end_src
166 | 
167 | ** FUNCTION njson:jkeys (alias: njson/aliases:keys)
168 | 
169 | Gets all the keys present in the passed object. Integer keys for arrays, string keys for object, error for anything else.
170 | #+begin_src lisp
171 |   (njson:jkeys (njson:decode "{\"a\": 1, \"b\": 2}"))
172 |   ;; ("a" "b")
173 |   (njson:jkeys (njson:decode "[\"a\", \"b\"]"))
174 |   ;; (0 1)
175 | #+end_src
176 | 
177 | ** FUNCTIONS njson:ensure-array, njson:ensure-object (aliases: njson/aliases:ensure-array, njson/aliases:ensure-object)
178 | 
179 | Ensure that the passed object is turned into array or object (respectively). If ~:convert-objects~ is provided in ~njson:ensure-array~, it creates an array with all the values of object, discarding keys.
180 | #+begin_src lisp
181 |   (njson:ensure-array #(1 2 3))
182 |   ;; #(1 2 3)
183 |   (njson:ensure-array 3)
184 |   ;; #(3)
185 |   (njson:ensure-array (njson:decode "{\"a\": 3}"))
186 |   ;; #(#<hash-table>)
187 |   (njson:ensure-array (njson:decode "{\"a\": 3}") :convert-objects t)
188 |   ;; #(3)
189 | 
190 |   (njson:ensure-object "key" #<hash-table>)
191 |   ;; #<hash-table>
192 |   (njson:ensure-object "key" 3)
193 |   ;; #<hash-table> with "key": 3
194 |   (njson:ensure-object "key" #(1 2 3))
195 |   ;; #<hash-table> with "key": #(1 2 3)
196 | #+end_src
197 | 
198 | ** FUNCTION njson:jtruep (aliases: njson:jtrue-p, njson:jtrue?, njson:truep, njson:true-p, njson:true?)
199 | 
200 | Checks whether the given value is true (in other words, neither ~false~, nor ~null~) per JSON.
201 | 
202 | All the macros below utilize it, so, if you want to change the behavior of those, specialize this function.
203 | 
204 | ** MACRO njson:jwhen (alias: njson/aliases:when)
205 | 
206 | A regular CL ~when~ made aware of JSON's ~null~ and ~false~.
207 | 
208 | #+begin_src lisp
209 |   (njson:jwhen (njson:decode "null")
210 |     "This is never returned.")
211 |   ;; nil
212 |   (njson:jwhen (njson:decode "5")
213 |     "This is always returned.")
214 |   ;; "This is always returned"
215 | #+end_src
216 | 
217 | ** MACRO njson:if (alias: njson/aliases:if)
218 | 
219 | A regular Lisp ~if~ aware of JSON truths and lies.
220 | 
221 | #+begin_src lisp
222 |   (njson:jif (njson:decode "5")
223 |              "This is always returned."
224 |              "This is never returned.")
225 |   ;; "This is always returned"
226 | #+end_src
227 | 
228 | ** MACRO njson:jor, njson:jand, njson:jnot (and aliases: njson/aliases:or, njson/aliases:and, njson/aliases:not)
229 | 
230 | Regular Lisp logic operators, with awareness of JSON values.
231 | 
232 | ** MACRO njson:jbind (alias njson/aliases:bind)
233 | 
234 | Destructures a JSON object against the provided destructuring pattern. This is most useful for deeply nested JSON structures often returned from old/corporate APIs. One example of such APIs is the Reddit one. To get to the title of the post, one has to go through half a dozen layers of nested objects and arrays:
235 | #+begin_src js
236 |   [{"kind": "Listing",
237 |     "data": {"children": [{"kind": "t3",
238 |                            "data": {"approved_at_utc": null,
239 |                                     "subreddit": "programming",
240 |                                     ...
241 |                                     // Finally, a title!
242 |                                     "title": "Henry Baker: Meta-circular semantics for Common Lisp special forms",
243 |                                     "link_flair_richtext": [],
244 |                                     "subreddit_name_prefixed": "r/programming",
245 |                                     ...}}]
246 |              ...}}
247 |    ...]
248 | #+end_src
249 | 
250 | One needs a strong destructuring facility with type checking to move through this mess of JSON data. ~jbind~ is exactly this facility. Here's how accessing the title of Reddit post would look like (array patterns access JSON arrays, list patterns access JSON objects) with ~jbind~:
251 | #+begin_src lisp
252 |   (njson:jbind #(("data" ("children" #(("data" ("title" title))))))
253 |       ;; Dexador is not a dependency of NJSON, so load it separately
254 |       (njson:decode
255 |        (dex:get
256 |         "https://www.reddit.com/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common.json"))
257 |     title)
258 |   ;; "Henry Baker: Meta-circular semantics for Common Lisp special forms"
259 | #+end_src
260 | 
261 | See documentation for more examples.
262 | 
263 | ** MACRO njson:jmatch (alias njson/aliases:match)
264 | 
265 | Matches/destructures the provided form against patterns one by one, and executes the body of the successfully matching one with the bindings it established. Every pattern and body is essentially a ~jbind~ with checking for destructuring success. The use-case is dispatching over API responses that differ in structure.
266 | 
267 | Telegram Bot API, for example, has disjoint contents for error responses and success responses:
268 | - Error responses have "ok" key set to false, and keys called "description" and "error_code".
269 | - Successful responses have "ok" set to true and "result" as the payload they return.
270 | 
271 | Given these restrictions, we can ~jmatch~ the result of Bot API:
272 | #+begin_src lisp
273 |   (njson:jmatch
274 |    parsed-api-data
275 |    (("ok" :true "result" result)
276 |     (values t result))
277 |    (("ok" :false "error_code" _ "description" description)
278 |     (values nil description))
279 |    (t (error "Malformed data!")))
280 | #+end_src
281 | 
282 | After parsing the data, we have clear value distinctions:
283 | - On success, return (VALUES (EQL T) *) with the payload.
284 | - On error, return (VALUES NULL &OPTIONAL STRING).
285 | - And in the exceptional case of malformed data, error out.
286 | 
287 | ~jmatch~ (and ~jbind~) also checks the value matching (see the ~"ok" :true~ and ~"ok" :false~ parts) with arbitrary JSON atomic type (number, string, ~:true~ (for T), ~:false~ (for NIL), and ~:null~). Arrays and lists are destructuring patterns already, so any value in them can be equality-checked.
288 | 
289 | ** ERROR njson:jerror
290 | 
291 | An umbrella class for all the NJSON errors. If you want to play unsafe, simply ignore all of NJSON errors:
292 | #+begin_src lisp
293 |   (handler-case
294 |       (njson:jget ...)
295 |     ;; Or j:error if you nicknamed njson/aliases.
296 |     (njson:jerror ()
297 |       nil))
298 | #+end_src
299 | 
300 | ** ERROR njson:encode-to-stream-not-implemented, njson:decode-from-stream-not-implemented
301 | 
302 | These get thrown when the JSON parsing back-end does not define methods for =njson:encode-to-stream= and =njson:decode-from-stream=. These are the bare minimum a backend should have to work. Adding the string and file methods is nice, but not required.
303 | 
304 | ** ERROR njson:invalid-key
305 | 
306 | This gets thrown when you try to index objects with integer indices and arrays with string keys. Because such an indexing wouldn't make sense.
307 | 
308 | To allow string indexing for arrays (to make ="1"= be recognized as a valid index), you can patch the =njson:jget= method for string indices:
309 | 
310 | #+begin_src lisp
311 |   (defmethod njson:jget :around ((index string) (object array))
312 |     (if (every #'digit-char-p index)
313 |         (njson:jget (parse-integer index) object)
314 |         (call-next-method)))
315 | #+end_src
316 | 
317 | ** ERROR njson:non-indexable
318 | 
319 | It doesn't make sense to index a number. This error reinforces the idea.
320 | 
321 | ** ERROR njson:invalid-pointer
322 | 
323 | This error is JSON Pointer specific. It's thrown when there's something wrong with the pointer syntax.
324 | 
325 | ** ERROR njson:no-key
326 | 
327 | This error is thrown in =njson:jget*= when the indexed object doesn't have the key it's indexed with.
328 | 
329 | ** ERROR njson:value-mismatch
330 | 
331 | Some value validated in =njson:jbind= didn't match the expected value.
332 | 
333 | ** ERROR njson:deprecated
334 | 
335 | Marks a certain function as deprecated.
336 | 


--------------------------------------------------------------------------------
/aliases.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | (uiop:define-package #:njson/aliases
 5 |   (:use #:common-lisp)
 6 |   (:export
 7 |    #:decode #:encode
 8 |    #:get #:get* #:copy #:true #:truep #:true?
 9 |    #:keys #:ensure-array #:ensure-object
10 |    #:if #:when #:or #:and #:not
11 |    #:bind #:match
12 |    #:@)
13 |   (:shadow #:get #:rem #:if #:when #:or #:and #:not)
14 |   (:documentation "Short aliases for the regular njson functions.
15 | Perfect with j: package-local-nickname, disastrous when :use-d."))
16 | 
17 | (in-package #:njson/aliases)
18 | 
19 | (loop for (alias original) in '((njson/aliases:decode njson:decode)
20 |                                 (njson/aliases:encode njson:encode)
21 |                                 (njson/aliases:get njson:jget)
22 |                                 (njson/aliases:get* njson:jget*)
23 |                                 ((setf njson/aliases:get) (setf njson:jget))
24 |                                 (njson/aliases:copy njson:jcopy)
25 |                                 (njson/aliases:true njson:jtruep)
26 |                                 (njson/aliases:truep njson:jtruep)
27 |                                 (njson/aliases:true? njson:jtruep)
28 |                                 (njson/aliases:keys njson:jkeys)
29 |                                 (njson/aliases:not njson:jnot)
30 |                                 (njson/aliases:ensure-array njson:ensure-array)
31 |                                 (njson/aliases:ensure-object njson:ensure-object))
32 |       do (setf (fdefinition alias) (fdefinition original))
33 |       unless (listp alias)
34 |         do (setf (documentation alias 'function) (documentation original 'function)))
35 | 
36 | (loop for (alias original) in '((njson/aliases:if njson:jif)
37 |                                 (njson/aliases:when njson:jwhen)
38 |                                 (njson/aliases:or njson:jor)
39 |                                 (njson/aliases:and njson:jand)
40 |                                 (njson/aliases:bind njson:jbind)
41 |                                 (njson/aliases:match njson:jmatch))
42 |       do (setf (macro-function alias) (macro-function original))
43 |       unless (listp alias)
44 |         do (setf (documentation alias 'function) (documentation original 'function)))
45 | 
46 | (defun @ (object &rest keys)
47 |   "Alias for `jget' that indexes OBJECT with KEYS.
48 | Setf-able."
49 |   (njson:jget keys object))
50 | 
51 | (defun (setf @) (value object &rest keys)
52 |   (setf (njson:jget keys object) value))
53 | 


--------------------------------------------------------------------------------
/backend/cl-json.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
  2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
  3 | 
  4 | (in-package #:njson)
  5 | 
  6 | (defvar *json-object-accumulator* (make-hash-table :test 'equal)
  7 |   "Our own object accumulator to override the default `cl-json:decode-json' object->alist behavior.
  8 | Objects are transformed to the hash-tables instead.")
  9 | 
 10 | (defvar *json-last-object-key* nil
 11 |   "The last key used in `*json-object-accumulator*'.")
 12 | 
 13 | (defun json-object-init ()
 14 |   (setf *json-object-accumulator* (make-hash-table :test 'equal)))
 15 | 
 16 | (defun json-object-add-key (key)
 17 |   (setf (gethash key *json-object-accumulator*) nil
 18 |         *json-last-object-key* key))
 19 | 
 20 | (defun json-object-add-value (value)
 21 |   (setf (gethash *json-last-object-key* *json-object-accumulator*) value))
 22 | 
 23 | (defun json-object-get ()
 24 |   *json-object-accumulator*)
 25 | 
 26 | (defun json::read-json-token (stream)
 27 |   "Read a JSON token (literal name, number or punctuation char) from
 28 | the given STREAM, and return 2 values: the token category (a symbol)
 29 | and the token itself, as a string or character."
 30 |   (let ((c (peek-char t stream)))
 31 |     (case c
 32 |       ((#\{ #\[ #\] #\} #\" #\: #\,)
 33 |        (values :punct (read-char stream)))
 34 |       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\-)
 35 |        (json::read-json-number-token stream))
 36 |       ;; Modified to ignore comments.
 37 |       ((#\/)
 38 |        (loop for char = (peek-char nil stream nil nil)
 39 |              until (or (null char)
 40 |                        (char= char #\Newline))
 41 |              do (read-char stream)
 42 |              finally (return (when char
 43 |                                (json::read-json-token stream)))))
 44 |       (t (if (alpha-char-p c)
 45 |              (json::read-json-name-token stream)
 46 |              (json:json-syntax-error stream "Invalid char on JSON input: `~C'"
 47 |                                 c))))))
 48 | 
 49 | (defun json::peek-json-token (stream)
 50 |   "Return 2 values: the category and the first character of the next
 51 | token available in the given STREAM.  Unlike READ-JSON-TOKEN, this
 52 | function can not discriminate between integers and reals (hence, it
 53 | returns a single :NUMBER category), and cannot check whether the next
 54 | available symbol is a valid boolean or not (hence, the category for
 55 | such tokens is :SYMBOL)."
 56 |   (let ((c (peek-char t stream)))
 57 |     (values
 58 |      (case c
 59 |        ((#\{ #\[ #\] #\} #\" #\: #\,) :punct)
 60 |        ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\-) :number)
 61 |        ;; Modified to ignore comments.
 62 |        ((#\/)
 63 |         (loop for char = (peek-char nil stream nil nil)
 64 |               until (or (null char)
 65 |                         (char= char #\Newline))
 66 |               do (read-char stream)
 67 |               finally (return (when char
 68 |                                 (json::peek-json-token stream)))))
 69 |        (t (if (alpha-char-p c)
 70 |               :symbol
 71 |               (json::json-syntax-error stream "Invalid char on JSON input: `~C'"
 72 |                                  c))))
 73 |      c)))
 74 | 
 75 | (defmacro with-cl-json-settings (&body body)
 76 |   `(let ((json::+json-lisp-symbol-tokens+
 77 |            '(("true" . t)
 78 |              ("false" . nil)
 79 |              ("null" . :null)))
 80 |          (json:*object-scope-variables* '(json:*internal-decoder* *json-object-accumulator* *json-last-object-key*))
 81 |          (json:*beginning-of-object-handler* #'json-object-init)
 82 |          (json:*object-key-handler* #'json-object-add-key)
 83 |          (json:*object-value-handler* #'json-object-add-value)
 84 |          (json:*end-of-object-handler* #'json-object-get)
 85 |          (json:*json-array-type* 'vector)
 86 |          (json:*use-strict-json-rules* nil))
 87 |      ,@body))
 88 | 
 89 | (defmethod decode-from-stream ((stream stream))
 90 |   (with-cl-json-settings
 91 |     (cl-json:decode-json stream)))
 92 | 
 93 | (defmethod decode-from-string ((string string))
 94 |   (with-cl-json-settings
 95 |     (cl-json:decode-json-from-string string)))
 96 | 
 97 | (defmethod decode-from-file ((file pathname))
 98 |   (with-cl-json-settings
 99 |     (cl-json:decode-json-from-source file)))
100 | 
101 | (defmethod encode-to-stream ((object t) (stream stream))
102 |   (with-cl-json-settings
103 |     (cl-json:encode-json object stream)))
104 | 
105 | (defmethod encode-to-string ((object t))
106 |   (with-cl-json-settings
107 |     (cl-json:encode-json-to-string object)))
108 | 
109 | ;; NOTE: `encode-to-file' is not specialized, because CL-JSON doesn't
110 | ;; have a specialized function for that. We rather rely on the default
111 | ;; `encode-to-file' method of NJSON that opens a stream from file and
112 | ;; uses `encode-to-stream' with this stream.
113 | 


--------------------------------------------------------------------------------
/backend/jzon.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | (in-package #:njson)
 5 | 
 6 | ;; FIXME: 'null shouldn't be taken as valid.
 7 | 
 8 | (defmethod com.inuoe.jzon:write-value ((writer com.inuoe.jzon:writer) (value (eql :null)))
 9 |   "This allows us to serialize :null as actual null JSON."
10 |   (com.inuoe.jzon:write-value writer 'null))
11 | 
12 | (deftype com.inuoe.jzon:json-atom ()
13 |   "Redefined type so that :null counts too."
14 |   `(or (eql t)
15 |        (eql nil)
16 |        (eql null)
17 |        (eql :null)
18 |        real
19 |        string))
20 | 
21 | (defun default-decode (in)
22 |   (labels ((convert-nulls (object)
23 |              (typecase object
24 |                (string object)
25 |                (array
26 |                 (loop for elem across object
27 |                       for idx from 0
28 |                       if (or (hash-table-p elem)
29 |                              (and (arrayp elem)
30 |                                   (not (stringp elem))))
31 |                         do (convert-nulls elem)
32 |                       else if (and (symbolp elem)
33 |                                    (eq elem 'null))
34 |                              do (setf (elt object idx) :null))
35 |                 object)
36 |                (hash-table
37 |                 (maphash (lambda (key value)
38 |                            (cond
39 |                              ((eq 'null value)
40 |                               (setf (gethash key object) :null))
41 |                              ((or (hash-table-p value)
42 |                                   (and (arrayp value)
43 |                                        (not (stringp value))))
44 |                               (convert-nulls value))))
45 |                          object)
46 |                 object)
47 |                (t (if (eq object 'null)
48 |                       :null
49 |                       object)))))
50 |     (convert-nulls (com.inuoe.jzon:parse in :allow-comments t :allow-trailing-comma t))))
51 | 
52 | (defmethod decode-from-stream ((stream stream))
53 |   (default-decode stream))
54 | 
55 | (defmethod decode-from-string ((string string))
56 |   (default-decode string))
57 | 
58 | (defmethod decode-from-file ((file pathname))
59 |   (default-decode file))
60 | 
61 | (defun default-encode (object)
62 |   (com.inuoe.jzon:stringify object ))
63 | 
64 | (defmethod encode-to-stream ((object t) (stream stream))
65 |   (com.inuoe.jzon:stringify object :stream stream ))
66 | 
67 | (defmethod encode-to-string ((object t))
68 |   (com.inuoe.jzon:stringify object))
69 | 
70 | ;; NOTE: not specializing `encode-to-file', because the default plays
71 | ;; well enough with stream specialization.
72 | 


--------------------------------------------------------------------------------
/conditions.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
  2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
  3 | 
  4 | (in-package #:njson)
  5 | 
  6 | (define-condition jerror (error)
  7 |   ()
  8 |   (:documentation "Fundamental error class all the NJSON errors inherit from."))
  9 | 
 10 | (defun read-new-value ()
 11 |   (format *query-io* "Input the new value (evaluated)~%")
 12 |   (list (eval (uiop:safe-read-from-string (read-line *query-io* nil nil)))))
 13 | 
 14 | (defun read-new-key ()
 15 |   (format *query-io* "Input the new key (literal number or string)~%")
 16 |   (list (uiop:safe-read-from-string (read-line *query-io* nil nil))))
 17 | 
 18 | (defun read-new-pointer ()
 19 |   (format *query-io* "Input the new JSON Pointer~%")
 20 |   (list (pathname (read-line *query-io* nil nil))))
 21 | 
 22 | (define-condition decode-from-stream-not-implemented (jerror) ()
 23 |   (:documentation "Incomplete decoding implementation error.")
 24 |   (:report "DECODE-FROM-STREAM is not specialized.
 25 | You need to specialize it to use NJSON. Example:
 26 | 
 27 | (defmethod njson:decode-from-stream ((stream stream))
 28 |   (some-json-parsing-library:decode-json-from-stream stream))
 29 | 
 30 | Alternatively, load a system with this method already defined, like :njson/cl-json."))
 31 | 
 32 | (define-condition encode-to-stream-not-implemented (jerror) ()
 33 |   (:documentation "Incomplete encoding implementation error.")
 34 |   (:report "ENCODE-TO-STREAM is not specialized.
 35 | You need to specialize it to use NJSON. Example:
 36 | 
 37 | (defmethod njson:encode-to-stream ((object t) (stream stream))
 38 |   (some-json-parsing-library:encode-json-to-stream object stream))
 39 | 
 40 | Alternatively, load a system with this method already defined, like :njson/cl-json."))
 41 | 
 42 | ;; TODO: Generalize and export?
 43 | (defun json-short-print (object)
 44 |   "Produce a string with a short object representation for debugging.
 45 | 
 46 | May actually produce long results for objects/arrays with many
 47 | members. But it's implied that these are rare cases and don't need
 48 | special treatment."
 49 |   (with-output-to-string (*standard-output*)
 50 |     (flet ((nested-print (value)
 51 |              (princ (typecase value
 52 |                       (hash-table "{}")
 53 |                       ((and array (not string)) "[]")
 54 |                       (t (json-short-print value))))))
 55 |       (typecase object
 56 |         (string (prin1 object))
 57 |         (hash-table
 58 |          (princ "{")
 59 |          (maphash
 60 |           (lambda (key value)
 61 |             (princ key) (princ ": ")
 62 |             (nested-print value) (princ ", "))
 63 |           object)
 64 |          (princ "}"))
 65 |         (array
 66 |          (princ "[")
 67 |          (map nil (lambda (value)
 68 |                     (nested-print value)
 69 |                     (princ ", "))
 70 |               object)
 71 |          (princ "]"))
 72 |         (t (princ (encode object)))))))
 73 | 
 74 | (define-condition invalid-key (jerror)
 75 |   ((object :initarg :object
 76 |            :accessor object)
 77 |    (key :initarg :key
 78 |         :accessor key))
 79 |   (:documentation "The condition thrown on using wrong key with object/array.")
 80 |   (:report (lambda (condition stream)
 81 |              (format stream "Cannot index JSON ~[object~;array~;value~] ~a with key ~s.
 82 | ~[Use string keys instead.~;~
 83 | Use integer indices instead.~;~
 84 | Are you sure you're indexing the right thing?~]"
 85 |                      (type-num (object condition)) (json-short-print (object condition))
 86 |                      (key condition) (type-num (object condition))))))
 87 | 
 88 | (defun type-num (object)
 89 |   (typecase object
 90 |     (hash-table 0)
 91 |     (sequence 1)
 92 |     (t 2)))
 93 | 
 94 | (define-condition non-indexable (jerror)
 95 |   ((value :initarg :value
 96 |           :accessor value))
 97 |   (:documentation "The condition thrown on trying to index non-object/array.")
 98 |   (:report (lambda (condition stream)
 99 |              (format stream "Non-indexable ~a."
100 |                      (json-short-print (value condition))))))
101 | 
102 | (define-condition invalid-pointer (jerror)
103 |   ((pointer :initarg :pointer
104 |             :accessor pointer))
105 |   (:documentation "Condition thrown when trying to index an object with invalid pointer.")
106 |   (:report (lambda (condition stream)
107 |              (format stream "Pointer ~S is invalid."
108 |                      (pointer condition)))))
109 | 
110 | (define-condition no-key (jerror)
111 |   ((object :initarg :object
112 |            :accessor object)
113 |    (key :initarg :key
114 |         :accessor key))
115 |   (:documentation "Condition thrown when trying to index an object/array with a key not present in it.")
116 |   (:report (lambda (condition stream)
117 |              (format stream "There's no ~[key~;index~] ~s in ~[object~;array~] ~a."
118 |                      (type-num (object condition)) (key condition)
119 |                      (type-num (object condition)) (json-short-print (object condition))))))
120 | 
121 | (define-condition value-mismatch (jerror)
122 |   ((expected :initarg :expected
123 |              :accessor expected)
124 |    (actual :initarg :actual
125 |            :accessor actual)
126 |    (object :initarg :object
127 |            :accessor object))
128 |   (:documentation "Condition thrown when getting a value not matching `jbind'/`jmatch' specification.")
129 |   (:report (lambda (condition stream)
130 |              (format stream "Expected ~a in object ~a and got ~a."
131 |                      (json-short-print (expected condition))
132 |                      (json-short-print (object condition))
133 |                      (json-short-print (actual condition))))))
134 | 
135 | (define-condition deprecated (warning)
136 |   ((deprecated :initarg :deprecated
137 |                :accessor deprecated)
138 |    (replacement :initarg :replacement
139 |                 :accessor replacement))
140 |   (:documentation "Deprecation warning.")
141 |   (:report (lambda (condition stream)
142 |              (format stream "~a is deprecated. It will be removed in the next major release.
143 | Use ~a instead." (deprecated condition) (replacement condition)))))
144 | 


--------------------------------------------------------------------------------
/functions.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
  2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
  3 | 
  4 | (in-package #:njson)
  5 | 
  6 | ;; FIXME: CL pathname parsing on SBCL+Linux parses #p"/i\\j" as
  7 | ;; #p"/ij", which breaks one of JSON Pointer RFC example. It's bad,
  8 | ;; but avoidable with e.g. `make-pathname'.
  9 | (defun parse-pointer-pathname (pointer-pathname)
 10 |   "Parse POINTER-PATHNAME per JSON Pointer rules (https://www.rfc-editor.org/rfc/rfc6901).
 11 | Only supports JSON string representation, not the URL one."
 12 |   (flet ((resolve-tildes (string)
 13 |            (uiop:frob-substrings
 14 |             string '("~1" "~0")
 15 |             (lambda (match frob)
 16 |               (funcall frob (case (elt match 1)
 17 |                               (#\1 "/")
 18 |                               (#\0 "~"))))))
 19 |          (read-until (char stream)
 20 |            "Read from STREAM until encountering CHAR.
 21 | CHAR is left unread on STREAM after returning."
 22 |            (coerce (loop for peeked = (peek-char nil stream nil nil)
 23 |                          until (or (eql char peeked)
 24 |                                    (null peeked))
 25 |                          collect (read-char stream nil nil))
 26 |                    'string))
 27 |          (parse-if-number (string)
 28 |            (if (and (not (uiop:emptyp string))
 29 |                     (every #'digit-char-p string))
 30 |                (parse-integer string)
 31 |                string)))
 32 |     (let* ((name (namestring pointer-pathname)))
 33 |       (restart-case
 34 |           (with-input-from-string (s name)
 35 |             (loop for char = (read-char s nil nil)
 36 |                   while char
 37 |                   unless (eq #\/ char)
 38 |                     do (cerror "Use the pointer anyway"
 39 |                                'invalid-pointer :pointer pointer-pathname)
 40 |                   collect (parse-if-number (resolve-tildes (read-until #\/ s)))))
 41 |         (another-pointer (new-pointer)
 42 |           :report "Parse another pointer"
 43 |           :interactive read-new-pointer
 44 |           (parse-pointer-pathname new-pointer))))))
 45 | 
 46 | ;; TODO: Merge this into `jget' in 2.*.
 47 | (defgeneric jget* (key-or-index object)
 48 |   (:method ((keys sequence) (object t))
 49 |     (case (length keys)
 50 |       (0 (values object t))
 51 |       (1 (jget* (elt keys 0) object))
 52 |       (t (jget* (subseq keys 1)
 53 |                 (jget* (elt keys 0) object)))))
 54 |   (:method ((index integer) (object array))
 55 |     (cond
 56 |       ((<= 0 index (1- (length object)))
 57 |        (values (aref object index) t))
 58 |       (t (restart-case
 59 |              (cerror "Return nothing"
 60 |                      'no-key :object object :key index)
 61 |            (store-value (new-value)
 62 |              :report "Add a value under this key"
 63 |              :interactive read-new-value
 64 |              (adjust-array object index)
 65 |              (setf (elt object index) new-value)
 66 |              (values new-value t))))))
 67 |   (:method ((key string) (object hash-table))
 68 |     (cond
 69 |       ((nth-value 1 (gethash key object))
 70 |        (gethash key object))
 71 |       (t (restart-case
 72 |              (cerror "Return nothing"
 73 |                      'no-key :object object :key key)
 74 |            (store-value (new-value)
 75 |              :report "Add a new value under this key"
 76 |              :interactive read-new-value
 77 |              (setf (gethash key object) new-value)
 78 |              (values new-value t))))))
 79 |   (:method ((pointer pathname) object)
 80 |     (if (equal #p"" pointer)
 81 |         (values object t)
 82 |         (jget* (parse-pointer-pathname pointer) object)))
 83 |   (:method ((index string) (object array))
 84 |     (restart-case
 85 |         (cerror "Return nothing"
 86 |                 'invalid-key :key index :object object)
 87 |       (coerce-to-integer ()
 88 |         :report "Convert the key to integer"
 89 |         :test (lambda (c)
 90 |                 (declare (ignore c))
 91 |                 (every #'digit-char-p index))
 92 |         (jget* (parse-integer index) object))
 93 |       (use-integer (new-index)
 94 |         :report "Use an integer key"
 95 |         :interactive read-new-key
 96 |         (check-type new-index integer)
 97 |         (jget* new-index object))))
 98 |   (:method ((key integer) (object hash-table))
 99 |     (restart-case
100 |         (cerror "Return nothing"
101 |                 'invalid-key :key key :object object)
102 |       (coerce-to-string ()
103 |         :report "Convert the index to string"
104 |         (jget* (princ-to-string key) object))
105 |       (use-string (new-key)
106 |         :report "Use a string key"
107 |         :interactive read-new-key
108 |         (check-type new-key string)
109 |         (jget* new-key object))))
110 |   (:method (key object)
111 |     (declare (ignore key))
112 |     (cerror "Return nothing"
113 |             'non-indexable :value object)
114 |     (values nil nil))
115 |   (:method ((key string) (object string))
116 |     (declare (ignore key))
117 |     (cerror "Return nothing"
118 |             'non-indexable :value object))
119 |   (:method ((key integer) (object string))
120 |     (declare (ignore key))
121 |     (cerror "Return nothing"
122 |             'non-indexable :value object))
123 |   (:documentation "A version of `jget' that's more strict regarding missing keys."))
124 | 
125 | (defgeneric jget (key-or-index object)
126 |   (:method (key-or-index object)
127 |     (handler-case
128 |         (jget* key-or-index object)
129 |       (no-key ()
130 |         (values nil nil))))
131 |   (:documentation "Get the value at KEY-OR-INDEX in OBJECT.
132 | 
133 | KEY-OR-INDEX can be
134 | - an integer (for array indexing),
135 | - a string (for object keying),
136 | - a pathname (with JSON Pointer syntax),
137 | - a sequence of integers and strings (to index the nested structures).
138 | - an empty sequence/pathname (to match the whole object).
139 | 
140 | Return two values: the value under KEY-OR-INDEX and whether this value
141 | was found.
142 | 
143 | - (Starting from version 2) Throw `no-key' when the key is not present in the object.
144 | - Throw `invalid-key' if using the wrong index type.
145 | - Throw `non-indexable' when trying to index something other than
146 |   JSON arrays or objects.
147 | - Throw `invalid-pointer' when using JSON Pointer with invalid syntax
148 |   as key.
149 | 
150 | For example, to get the data from a structure like
151 | {\"data\": [1, 2, {\"three\": 3}]}
152 | you can use
153 | (jget #(\"data\" 2 \"three\") data)
154 | ;; => 3, T
155 | 
156 | OBJECT can be JSON array or object, which in Lisp translates to
157 | `array' or `hash-table'.
158 | 
159 | `jget*' is a more structured and strict version of `jget', enforcing
160 | the `no-key' condition and removing the two-valued approach because of
161 | that. `jget*' will be merged into `jget' in version 2."))
162 | 
163 | (defgeneric (setf jget) (value key-or-index object)
164 |   (:method (value (keys sequence) (object t))
165 |     (case (length keys)
166 |       (0 (cerror "Don't set the value"
167 |                  'invalid-key :key keys :object object))
168 |       (1 (setf (jget (elt keys 0) object) value))
169 |       (t (setf (jget (elt keys (1- (length keys)))
170 |                      (jget (subseq keys 0 (1- (length keys))) object))
171 |                value))))
172 |   (:method (value (index integer) (object array))
173 |     (setf (aref object index) value))
174 |   (:method (value (key string) (object hash-table))
175 |     (setf (gethash key object) value))
176 |   (:method (value (pointer pathname) object)
177 |     (if (equal #p"" pointer)
178 |         (restart-case
179 |             (cerror "Don't set the value"
180 |                     'invalid-key :key pointer :object object)
181 |           (another-pointer (new-pointer)
182 |             :report "Use another pointer"
183 |             :interactive read-new-pointer
184 |             (setf (jget new-pointer object) value)))
185 |         (setf (jget (parse-pointer-pathname pointer) object)
186 |               value)))
187 |   (:method (value (index string) (object array))
188 |     (restart-case
189 |         (cerror "Don't set the value"
190 |                 'invalid-key :key index :object object)
191 |       (use-integer (new-key)
192 |         :report "Use an integer key"
193 |         :interactive read-new-key
194 |         (check-type new-key integer)
195 |         (setf (jget new-key object) value))) )
196 |   (:method (value (key integer) (object hash-table))
197 |     (restart-case
198 |         (cerror "Don't set the value"
199 |                 'invalid-key :key key :object object)
200 |       (use-string (new-key)
201 |         :report "Use a string key"
202 |         :interactive read-new-key
203 |         (check-type new-key string)
204 |         (setf (jget new-key object) value))))
205 |   (:method (value key (object t))
206 |     (declare (ignore value key))
207 |     (cerror "Don't set the value"
208 |             'non-indexable :value object))
209 |   (:method :around (value key (object string))
210 |     (declare (ignore value key))
211 |     (cerror "Do nothing"
212 |             'non-indexable :value object))
213 |   (:documentation "Set the value at KEY-OR-INDEX in OBJECT.
214 | 
215 | The arguments are the same as in `jget', except KEY-OR-INDEX cannot be
216 | an empty pathname/sequence (because setting the object itself to a new
217 | value is not possible in CL, unless it's a place, which is not
218 | guaranteed for `jget' arguments).
219 | 
220 | - Throw `invalid-key' if using the wrong index type.
221 | - Throw `non-indexable' when trying to index something other than
222 |   JSON arrays or objects.
223 | - Throw `invalid-pointer' when using JSON Pointer with invalid syntax
224 |   as key.
225 | 
226 | OBJECT can be JSON array or object, which in Lisp translates to
227 | `array' or `hash-table'."))
228 | 
229 | (defgeneric jcopy (object)
230 |   (:method ((object real)) object)
231 |   (:method ((object (eql :null))) object)
232 |   (:method ((object (eql t))) object)
233 |   (:method ((object null)) object)
234 |   (:method ((object string)) object)
235 |   (:method ((object array))
236 |     (make-array (length object)
237 |                 :adjustable t
238 |                 :fill-pointer t
239 |                 :initial-contents (map 'vector #'jcopy object)))
240 |   (:method ((object hash-table))
241 |     (let ((new (make-hash-table :test 'equal)))
242 |       (maphash (lambda (key val)
243 |                  (setf (gethash key new) val))
244 |                object)
245 |       new))
246 |   (:documentation "Copy the OBJECT, potentially creating an identical one.
247 | Coerce all JSON arrays to adjustable vectors."))
248 | 
249 | (defgeneric jkeys (object)
250 |   (:method ((object vector))
251 |     (loop for i from 0 below (length object)
252 |           collect i))
253 |   (:method ((object string))
254 |     (cerror "Return nothing"
255 |             'non-indexable :value object))
256 |   (:method ((object hash-table))
257 |     (loop for key being the hash-key of object
258 |           collect key))
259 |   (:method ((object t))
260 |     (cerror "Return nothing"
261 |             'non-indexable :value object))
262 |   (:documentation "Get keys to index OBJECT with, as a list of integers/strings.
263 | If the OBJECT is not a JSON array/object, throws `non-indexable'."))
264 | 
265 | (defgeneric jtruep (object)
266 |   (:method (object)
267 |     (declare (ignore object))
268 |     t)
269 |   (:method ((object symbol))
270 |     (not (member object (list nil :null))))
271 |   (:documentation "Test OBJECT for truthiness in JSON terms.
272 | 
273 | Recognize all the values true, except for null and false. This is to
274 | make the transition from JSON to Lisp (2 false values -> 1 false
275 | value) smoother.
276 | 
277 | Unlike JavaScript, empty strings and zero are not false (because this
278 | behavior is confusing)."))
279 | 
280 | (dolist (symbol '(jtrue-p jtrue?))
281 |   (setf (symbol-function symbol) #'jtruep))
282 | 
283 | (defun jnot (arg)
284 |   "JSON-aware version of `cl:not'."
285 |   (not (jtruep arg)))
286 | 
287 | (defun make-singular-array (object)
288 |   (make-array 1 :adjustable t :fill-pointer t :initial-contents (list object)))
289 | 
290 | (defgeneric ensure-array (object &key &allow-other-keys)
291 |   (:method ((object hash-table) &key convert-objects &allow-other-keys)
292 |     (if convert-objects
293 |         (make-array (hash-table-count object)
294 |                     :adjustable t
295 |                     :fill-pointer t
296 |                     :initial-contents (loop for key in (jkeys object)
297 |                                             collect (jget key object)))
298 |         (make-singular-array object)))
299 |   (:method ((object sequence) &key &allow-other-keys)
300 |     (make-array (length object) :adjustable t :fill-pointer t :initial-contents object))
301 |   (:method ((object string) &key &allow-other-keys)
302 |     (make-singular-array object))
303 |   (:method ((object null) &key &allow-other-keys)
304 |     (make-singular-array object))
305 |   (:method ((object t) &key &allow-other-keys)
306 |     (make-singular-array object))
307 |   (:documentation "Ensure that the return value is an array.
308 | If OBJECT is an array already, return it.
309 | If it's a literal value, wrap it into a one-element array.
310 | If it's an object:
311 | - When CONVERT-OBJECTS is T, put all the values into an array (order
312 |   not guaranteed).
313 | - Otherwise wrap the object into an array."))
314 | 
315 | (defgeneric ensure-object (key object &key &allow-other-keys)
316 |   (:method ((key string) (object hash-table) &key &allow-other-keys)
317 |     (jget key object)
318 |     object)
319 |   (:method ((key string) (object t) &key &allow-other-keys)
320 |     (let ((hash-table (make-hash-table :test 'equal)))
321 |       (setf (jget key hash-table) object)
322 |       hash-table))
323 |   (:documentation "Ensure that the return value is a JSON object.
324 | If OBJECT is an object already, return it, checking KEY presence.
325 | If it's anything else, wrap it into an object with OBJECT under KEY.
326 | 
327 | Throws errors from underlying `jget'."))
328 | 


--------------------------------------------------------------------------------
/guix.scm:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | ;;; Commentary:
 5 | ;;
 6 | ;; GNU Guix development package.  To start the REPL:
 7 | ;;
 8 | ;;   guix shell -f path/to/guix.scm sbcl -- sbcl
 9 | ;;
10 | ;;; Code:
11 | 
12 | (use-modules (guix packages)
13 |              (guix gexp)
14 |              (gnu packages lisp-xyz))
15 | 
16 | (package
17 |   (inherit cl-njson)
18 |   (version "dev")
19 |   (source (local-file (dirname (current-filename)) #:recursive? #t)))
20 | 


--------------------------------------------------------------------------------
/macros.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
  2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
  3 | 
  4 | (in-package #:njson)
  5 | 
  6 | (defmacro jif (test then &optional (else nil))
  7 |   "JSON-aware version of `cl:if'.
  8 | If TEST is `jtruep' evaluate THEN, otherwise evaluate ELSE."
  9 |   `(if (jtruep ,test)
 10 |        ,then
 11 |        ,else))
 12 | 
 13 | (defmacro jwhen (test &body body)
 14 |   "JSON-aware version of `cl:when'.
 15 | If TEST is `jtruep' evaluate BODY."
 16 |   `(jif ,test
 17 |        (progn ,@body)))
 18 | 
 19 | (defmacro jor (&rest args)
 20 |   "JSON-aware version of `cl:or'."
 21 |   `(or ,@(loop for arg in args
 22 |                collecting `(jwhen ,arg ,arg))))
 23 | 
 24 | (defmacro jand (&rest args)
 25 |   "JSON-aware version of `cl:and'."
 26 |   `(and ,@(loop for arg in args
 27 |                 collecting `(jwhen ,arg ,arg))))
 28 | 
 29 | (defun check-value (expected indices object)
 30 |   "Check that JSON value in OBJECT at INDICES is `equal' to EXPECTED specification."
 31 |   (restart-case
 32 |       (let ((result (jget indices object)))
 33 |         (or (typecase expected
 34 |               ((eql t) (handler-case
 35 |                            (return-from check-value (jget* indices object))
 36 |                          (error () nil)))
 37 |               ((eql :true) (eq t result))
 38 |               ((eql :false) (eq nil result))
 39 |               ((and array (not string))
 40 |                (and (arrayp result)
 41 |                     (not (stringp result))))
 42 |               (list (hash-table-p result))
 43 |               ;; This is to allow double and single float comparisons.
 44 |               (number (when (numberp result)
 45 |                         (< (abs (- result expected))
 46 |                            single-float-epsilon)))
 47 |               (t (equal result expected)))
 48 |             (cerror
 49 |              "Ignore the mismatch"
 50 |              'value-mismatch
 51 |              :expected (typecase expected
 52 |                          ((eql :true) t)
 53 |                          ((eql :false) nil)
 54 |                          (null (make-hash-table))
 55 |                          (t expected))
 56 |              :actual result
 57 |              :object (jget (subseq indices 0
 58 |                                    ;; This 1- and max is to get the
 59 |                                    ;; "parent" of RESULT.
 60 |                                    (max 0 (1- (length indices))))
 61 |                            object))
 62 |             t))
 63 |     (store-value (new-value)
 64 |       :report "Replace the offending value"
 65 |       :interactive read-new-value
 66 |       (setf (jget indices object) new-value)
 67 |       (check-value expected indices object))
 68 |     (use-value (new-value)
 69 |       :report "Return a replacement"
 70 |       :interactive read-new-value
 71 |       new-value)))
 72 | 
 73 | ;; DESTRUCTURING-PATTERN is not a (&rest destructuring-pattern)
 74 | ;; because it might be a vector too.
 75 | (defmacro jbind (destructuring-pattern form &body body)
 76 |   "Match the FORM against DESTRUCTURING-PATTERN.
 77 | The pattern might be:
 78 | - A symbol, in which case the current chosen form is bound to it. If
 79 |   the symbol is _, simply skip the form.
 80 | - A literal form:
 81 |   - String or number: compare with `equal'.
 82 |   - Keywords :TRUE, :FALSE, and :NULL, matching T, NIL, and :NULL
 83 |     respectively.
 84 | - If the pattern is a property list of string+pattern pairs, match the
 85 |   string+pattern pairs inside it to the provided JSON object and
 86 |   resolve them recursively.
 87 | - If the pattern is a list of symbols (VAR &optional VAR-P), these are
 88 |   bound to the respective values of `jget'. It is a good way to make
 89 |   `jbind' to be more lenient to missing keys, because the default
 90 |   behavior is to error on missing data.
 91 | - If the pattern is an inline vector, match it against a JSON array
 92 |   with at least as many elements as provided in the vector. Match
 93 |   every form in the vector against the element with the same index.
 94 | 
 95 | If the DESTRUCTURING-PATTERN doesn't match the object, throw
 96 | `value-mismatch'.
 97 | 
 98 | Underlying `jget' can throw errors for the exceptionally malformed
 99 | inputs. See `jget' documentation for the types of errors it throws.
100 | 
101 | Example:
102 | \(\"hello\" hello \"a\" _ \"b\" b
103 |  \"array\" #(first second third _))
104 | 
105 | matches a JSON object
106 | {\"hello\": 3, \"a\": 8, \"b\": 3, \"c\": null, \"array\": [1, 2, 3, 4]}
107 | 
108 | and binds
109 | - HELLO to 3
110 | - B to 3
111 | - FIRST to 1
112 | - SECOND to 2
113 | - THIRD to 3
114 | 
115 | It also checks that \"a\" key is present in the object and there's a
116 | fourth element in the nested array.
117 | 
118 | See more examples in njson tests."
119 |   (let ((form-sym (gensym "BIND-FORM"))
120 |         (bindings (list)))
121 |     (labels ((parse-pattern (pattern &optional (current-path (list)))
122 |                (etypecase pattern
123 |                  ((or (member :true :false :null) string real)
124 |                   (push (cons pattern (copy-list current-path))
125 |                         bindings))
126 |                  ((cons symbol *)
127 |                   (push (cons pattern (copy-list current-path))
128 |                         bindings))
129 |                  (list
130 |                   (loop for (key subpattern) on pattern by #'cddr
131 |                         do (parse-pattern subpattern (append current-path (list key))))
132 |                   (push (cons nil (copy-list current-path))
133 |                         bindings))
134 |                  ((and symbol (not keyword))
135 |                   (push (cons (if (equal "_" (symbol-name pattern))
136 |                                   (gensym "_PATTERN")
137 |                                   pattern)
138 |                               (copy-list current-path))
139 |                         bindings))
140 |                  (array
141 | 		  (loop for elem across pattern
142 |                         for index from 0
143 |                         do (parse-pattern elem (append current-path (list index))))
144 | 		  (push (cons #() (copy-list current-path))
145 | 			bindings)))))
146 |       (check-type destructuring-pattern (or list (and array (not string))
147 |                                             (and symbol (not keyword)))
148 |                   "proper jbind destructuring pattern: list, array, or symbol")
149 |       (parse-pattern destructuring-pattern)
150 |       (let ((let-forms (loop for (binding . key) in bindings
151 |                              do (check-type binding (or array real symbol
152 |                                                         ;; For (VAR VAR-P) forms
153 |                                                         (cons symbol (or (cons symbol null)
154 |                                                                          null))))
155 |                              if (typep binding '(or array real null
156 |                                                  (member :true :false :null)))
157 |                                collect `(,(gensym) (check-value ,binding (vector ,@key) ,form-sym))
158 |                              else if (and (symbolp binding)
159 |                                           (uiop:emptyp key))
160 |                                     collect `(,binding ,form-sym)
161 |                              else if (listp binding)
162 |                                     append (destructuring-bind (var &optional (var-p nil var-p-provided))
163 |                                                binding
164 |                                              (append
165 |                                               `((,var (jget (vector ,@key) ,form-sym)))
166 |                                               (when var-p-provided
167 |                                                 `((,var-p (nth-value 1 (jget (vector ,@key) ,form-sym)))))))
168 |                              else
169 |                                collect `(,binding (check-value t (vector ,@key) ,form-sym)))))
170 |         `(let* ((,form-sym ,form)
171 |                 ,@let-forms)
172 |            (declare (ignorable ,form-sym ,@(mapcar #'first let-forms)))
173 |            ,@body)))))
174 | 
175 | (defmacro jmatch (form &body clauses)
176 |   "Similar to Trivia match macro, match the FORM (JSON value) against CLAUSES.
177 | CLAUSES are (PATTERN . BODY) forms, where
178 | - PATTERN is a `jbind' destructuring pattern.
179 | - And BODY is an implicit progn.
180 | 
181 | If PATTERN matches successfully in `jbind', then BODY is executed with
182 | the variables from the PATTERN bound to the respective values, as per
183 | `jbind'.
184 | 
185 | The last clause could start with T, OTHERWISE, ELSE, or _, and it will
186 | be invoked if other patterns don't match. If there's no such clause,
187 | `jmatch' will simply return NIL on no matching patterns."
188 |   (let ((form-sym (gensym "MATCH-FORM")))
189 |     `(let ((,form-sym ,form))
190 |        (cond
191 |          ,@(loop for (pattern . body) in clauses
192 |                  when (and (symbolp pattern)
193 |                            (member (symbol-name pattern) '("T" "_" "OTHERWISE" "ELSE")
194 |                                    :test #'string=))
195 |                    collect `(t ,@body)
196 |                  else
197 |                    collect `((ignore-errors (jbind ,pattern ,form-sym t))
198 |                              (jbind ,pattern ,form-sym ,@body)))))))
199 | 


--------------------------------------------------------------------------------
/njson.asd:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | (defsystem "njson"
 5 |   :description "NJSON is a JSON handling framework with the focus on convenience and brevity."
 6 |   :author "Atlas Engineer LLC"
 7 |   :homepage "https://github.com/atlas-engineer/njson"
 8 |   :bug-tracker "https://github.com/atlas-engineer/njson/issues"
 9 |   :source-control (:git "https://github.com/atlas-engineer/njson.git")
10 |   :license  "BSD-3 Clause"
11 |   :version "1.2.2"
12 |   :serial t
13 |   :components ((:file "package")
14 |                (:file "conditions")
15 |                (:file "njson")
16 |                (:file "functions")
17 |                (:file "macros")
18 |                (:file "aliases"))
19 |   :in-order-to ((test-op (test-op "njson/tests"))))
20 | 
21 | (defsystem "njson/cl-json"
22 |   :depends-on ("njson" "cl-json")
23 |   :components ((:file "backend/cl-json"))
24 |   :in-order-to ((test-op (test-op "njson/tests"))))
25 | 
26 | (defsystem "njson/jzon"
27 |   :depends-on ("njson" "com.inuoe.jzon")
28 |   :components ((:file "backend/jzon"))
29 |   :in-order-to ((test-op (test-op "njson/tests"))))
30 | 
31 | (defsystem "njson/tests"
32 |   :description "Backend conformance test set. Don't use on its own!"
33 |   :depends-on ("njson" "lisp-unit2")
34 |   :serial t
35 |   :pathname "tests/"
36 |   :components ((:file "package")
37 |                (:file "tests"))
38 |   :perform (test-op (op c)
39 |                     (eval-input
40 |                      "(lisp-unit2:run-tests
41 |                        :package :njson/tests
42 |                        :run-contexts #'lisp-unit2:with-summary-context)")))
43 | 


--------------------------------------------------------------------------------
/njson.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | (in-package #:njson)
 5 | 
 6 | (defgeneric decode-from-stream (stream)
 7 |   (:method (stream)
 8 |     (declare (ignore stream))
 9 |     (signal 'decode-from-stream-not-implemented))
10 |   (:documentation "Decode JSON from STREAM.
11 | Specialize on `stream' to make NJSON decode JSON."))
12 | 
13 | (defgeneric decode-from-string (string)
14 |   (:method (string)
15 |     (with-input-from-string (stream string)
16 |       (decode-from-stream stream)))
17 |   (:documentation "Decode JSON from STRING.
18 | Specialize on `string' to make NJSON better decode JSON strings.
19 | Uses `decode-from-stream' by default."))
20 | 
21 | (defgeneric decode-from-file (file)
22 |   (:method (file)
23 |     (with-open-file (stream file :direction :input)
24 |       (decode-from-stream stream)))
25 |   (:documentation "Decode JSON from FILE.
26 | Specialize on `pathname' to make NJSON better decode JSON files.
27 | Uses `decode-from-stream' by default."))
28 | 
29 | (defgeneric decode (from)
30 |   (:method ((from stream))
31 |     (decode-from-stream from))
32 |   (:method ((from pathname))
33 |     (decode-from-file from))
34 |   (:method ((from string))
35 |     (decode-from-string from))
36 |   (:documentation "Decode OBJECT from JSON source FROM.
37 | FROM can be a string, stream, pathname, or byte array.
38 | 
39 | Distinguishes between null/false and arrays/objects.
40 | Decodes:
41 | - null as :NULL,
42 | - false as nil,
43 | - true as t,
44 | - arrays as vectors,
45 | - objects as hash-tables."))
46 | 
47 | (defgeneric encode-to-stream (object stream)
48 |   (:method (object stream)
49 |     (declare (ignore object stream))
50 |     (signal 'encode-to-stream-not-implemented))
51 |   (:documentation "Encode OBJECT to STREAM as JSON.
52 | Specialize on `stream' (and, optionally, OBJECT types) to make NJSON encode JSON."))
53 | 
54 | (defgeneric encode-to-string (object)
55 |   (:method (object)
56 |     (with-output-to-string (stream)
57 |       (encode-to-stream object stream)
58 |       (get-output-stream-string stream)))
59 |   (:documentation "Encode OBJECT to JSON string.
60 | Specialize on `string' (and, optionally, OBJECT types) to make NJSON better encode JSON to strings.
61 | Uses `encode-to-stream' by default."))
62 | 
63 | (defgeneric encode-to-file (object file)
64 |   (:method (object file)
65 |     (with-open-file (stream file)
66 |       (encode-to-stream object stream)))
67 |   (:documentation "Encode OBJECT to FILE.
68 | Specialize on `pathname' (and, optionally, OBJECT types) to make NJSON better encode JSON to files.
69 | Uses `encode-to-stream' by default."))
70 | 
71 | (defgeneric encode (object &optional to)
72 |   (:method :around (object &optional to)
73 |     (typecase to
74 |       (null (encode-to-string object))
75 |       (pathname (encode-to-file object to))
76 |       (stream (call-next-method object to))
77 |       ((eql t) (call-next-method object *standard-output*))))
78 |   (:method (object &optional to)
79 |     (encode-to-stream object to))
80 |   (:documentation "Encode OBJECT to JSON output spec TO.
81 | TO can be:
82 | - T, in which case `*standard-output*' is used as encoding stream.
83 | - NIL, in which case OBJECT is encoded to a string.
84 | - STREAM, in which case OBJECT is encoded to it.
85 | - PATHNAME, in which case OBJECT is encoded to the file designated by the pathname.
86 | 
87 | Distinguishes between null and false.
88 | Encodes:
89 | - :NULL as null,
90 | - nil as false."))
91 | 


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
 3 | 
 4 | (uiop:define-package #:njson
 5 |   (:use #:common-lisp)
 6 |   (:export
 7 |    ;; Conditions
 8 |    #:jerror
 9 |    #:decode-from-stream-not-implemented
10 |    #:encode-to-stream-not-implemented
11 |    #:invalid-key #:non-indexable #:value-mismatch #:invalid-pointer #:no-key
12 |    ;; Main generics
13 |    #:decode #:encode
14 |    ;; Generics to implement for backends.
15 |    #:decode-from-stream #:decode-from-string #:decode-from-file
16 |    #:encode-to-stream #:encode-to-string #:encode-to-file
17 |    ;; Helpers
18 |    #:jget #:jget* #:jcopy #:jkeys
19 |    #:jtruep #:jtrue-p #:jtrue?
20 |    #:ensure-array #:ensure-object
21 |    ;; Macro helpers
22 |    #:jif #:jwhen #:jor #:jand #:jnot
23 |    ;; Binding macros.
24 |    #:jbind #:jmatch)
25 |   (:documentation "NJSON is a convenience library for JSON handling. Important functions/APIs:
26 | - `njson:encode' and `njson:decode' as universal (en|de)coding functions working
27 |   on strings, streams, and pathnames.
28 | - `njson:jget' (and `njson:get_' alias) to get the value from decoded
29 |   and arbitrarily nested JSON array/object.
30 | - `njson:jtruep' (and aliases) to check the non-falsity of a decoded
31 |   value.
32 | - `njson:jif', `njson:jwhen', `njson:jor', `njson:jand', and
33 |   `njson:jnot' (and aliases) as convenience macros for JSON
34 |   non-falsity-based control flow.
35 | 
36 | Generics to implement:
37 | - `njson:encode-to-stream' and `njson:decode-from-stream' as the basic
38 |   methods to specialize for every backend.
39 | - `njson:encode-to-string' and `njson:encode-to-file', as more specific
40 |   methods to speed things up.
41 | - `njson:decode-from-string' and `njson:decode-from-file', as more
42 |   specific decoding methods."))
43 | 


--------------------------------------------------------------------------------
/tests/baker.json:
--------------------------------------------------------------------------------
1 | [{"kind": "Listing", "data": {"after": null, "dist": 1, "modhash": "", "geo_filter": "", "children": [{"kind": "t3", "data": {"approved_at_utc": null, "subreddit": "programming", "selftext": "", "user_reports": [], "saved": false, "mod_reason_title": null, "gilded": 0, "clicked": false, "title": "Henry Baker: Meta-circular semantics for Common Lisp special forms", "link_flair_richtext": [], "subreddit_name_prefixed": "r/programming", "hidden": false, "pwls": 6, "link_flair_css_class": null, "downs": 0, "top_awarded_type": null, "parent_whitelist_status": "all_ads", "hide_score": false, "name": "t3_6er9d", "quarantine": false, "link_flair_text_color": "dark", "upvote_ratio": 0.59, "author_flair_background_color": "", "subreddit_type": "public", "ups": 10, "total_awards_received": 0, "media_embed": {}, "author_flair_template_id": null, "is_original_content": false, "secure_media": null, "is_reddit_media_domain": false, "is_meta": false, "category": null, "secure_media_embed": {}, "link_flair_text": null, "can_mod_post": false, "score": 10, "approved_by": null, "is_created_from_ads_ui": false, "thumbnail": "", "edited": false, "author_flair_css_class": null, "gildings": {}, "content_categories": null, "is_self": false, "mod_note": null, "created": 1207471396.0, "link_flair_type": "text", "wls": 6, "removed_by_category": null, "banned_by": null, "domain": "home.pipeline.com", "allow_live_comments": false, "selftext_html": null, "likes": null, "suggested_sort": null, "banned_at_utc": null, "url_overridden_by_dest": "http://home.pipeline.com/~hbaker1/MetaCircular.html", "view_count": null, "archived": false, "no_follow": false, "is_crosspostable": false, "pinned": false, "over_18": false, "all_awardings": [], "awarders": [], "media_only": false, "can_gild": false, "spoiler": false, "locked": false, "author_flair_text": null, "treatment_tags": [], "visited": false, "removed_by": null, "num_reports": null, "distinguished": null, "subreddit_id": "t5_2fwo", "author_is_blocked": false, "mod_reason_by": null, "removal_reason": null, "link_flair_background_color": "", "id": "6er9d", "is_robot_indexable": true, "num_duplicates": 0, "report_reasons": null, "author": "[deleted]", "discussion_type": null, "num_comments": 11, "send_replies": true, "media": null, "contest_mode": false, "author_flair_text_color": "dark", "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/", "whitelist_status": "all_ads", "stickied": false, "url": "http://home.pipeline.com/~hbaker1/MetaCircular.html", "subreddit_subscribers": 5352664, "created_utc": 1207471396.0, "num_crossposts": 0, "mod_reports": [], "is_video": false}}], "before": null}}, {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"total_awards_received": 0, "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "ups": 4, "removal_reason": null, "link_id": "t3_6er9d", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": "", "user_reports": [], "saved": false, "id": "c03nk4b", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "kragensitaker", "can_mod_post": false, "send_replies": true, "parent_id": "t1_c03n9zj", "score": 1, "author_fullname": "t2_32umk", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "No, lower, because Henry Baker stopped publishing awesome papers when he stopped getting paid.", "edited": false, "top_awarded_type": null, "downs": 0, "author_flair_css_class": null, "name": "t1_c03nk4b", "is_submitter": false, "collapsed": false, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;No, lower, because Henry Baker stopped publishing awesome papers when he stopped getting paid.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03nk4b/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207598382.0, "author_flair_text": null, "treatment_tags": [], "created_utc": 1207598382.0, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 2, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n9zj", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "bitwize", "can_mod_post": false, "created_utc": 1207523076.0, "send_replies": true, "parent_id": "t1_c03n6xr", "score": 1, "author_fullname": "t2_6dq6", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "Agreed -- probably with in the same order of magnitude of godhood as Oleg.", "edited": false, "top_awarded_type": null, "author_flair_css_class": null, "name": "t1_c03n9zj", "is_submitter": false, "downs": 0, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;Agreed -- probably with in the same order of magnitude of godhood as Oleg.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n9zj/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207523076.0, "author_flair_text": null, "treatment_tags": [], "collapsed": false, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 1, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n6xr", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": false, "author": "[deleted]", "can_mod_post": false, "send_replies": true, "parent_id": "t3_6er9d", "score": 4, "approved_by": null, "report_reasons": null, "all_awardings": [], "subreddit_id": "t5_2fwo", "body": "voted up because Henry Baker is a hacker demigod.", "edited": false, "downs": 0, "author_flair_css_class": null, "collapsed": false, "is_submitter": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;voted up because Henry Baker is a hacker demigod.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "associated_award": null, "stickied": false, "subreddit_type": "public", "can_gild": false, "top_awarded_type": null, "unrepliable_reason": null, "author_flair_text_color": "dark", "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n6xr/", "num_reports": null, "locked": false, "name": "t1_c03n6xr", "created": 1207500747.0, "subreddit": "programming", "author_flair_text": null, "treatment_tags": [], "created_utc": 1207500747.0, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 0, "author_flair_background_color": "", "collapsed_because_crowd_control": null, "mod_reports": [], "mod_note": null, "distinguished": null}}, {"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"total_awards_received": 0, "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "ups": 3, "removal_reason": null, "link_id": "t3_6er9d", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": "", "user_reports": [], "saved": false, "id": "c03o1kh", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "BlakeStone", "can_mod_post": false, "send_replies": true, "parent_id": "t1_c03n8v1", "score": 1, "author_fullname": "t2_1twh", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "Very simply:\n    (defun not (x)\n         (eq x nil))", "edited": false, "top_awarded_type": null, "downs": 0, "author_flair_css_class": null, "name": "t1_c03o1kh", "is_submitter": false, "collapsed": false, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;Very simply:\n    (defun not (x)\n         (eq x nil))&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03o1kh/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207713117.0, "author_flair_text": null, "treatment_tags": [], "created_utc": 1207713117.0, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 2, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n8v1", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": false, "author": "[deleted]", "can_mod_post": false, "send_replies": true, "parent_id": "t1_c03n8j5", "score": 3, "approved_by": null, "report_reasons": null, "all_awardings": [], "subreddit_id": "t5_2fwo", "body": "Well LET is not a special form in Scheme, but some compilers treat it as one, and many optimize specifically for lambda in call position. Many Schemes optimize certain built-in procedures. What is primitive or derived is a very nebulous thing in Lisps...\n\nBaker's implementation of IF depends on NOT - I can't see how NOT can be implemented without IF unless it becomes a primitive.", "edited": false, "author_flair_css_class": null, "collapsed": false, "downs": 0, "is_submitter": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;Well LET is not a special form in Scheme, but some compilers treat it as one, and many optimize specifically for lambda in call position. Many Schemes optimize certain built-in procedures. What is primitive or derived is a very nebulous thing in Lisps...&lt;/p&gt;\n\n&lt;p&gt;Baker&amp;#39;s implementation of IF depends on NOT - I can&amp;#39;t see how NOT can be implemented without IF unless it becomes a primitive.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "associated_award": null, "stickied": false, "subreddit_type": "public", "can_gild": false, "top_awarded_type": null, "unrepliable_reason": null, "author_flair_text_color": "dark", "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n8v1/", "num_reports": null, "locked": false, "name": "t1_c03n8v1", "created": 1207514820.0, "subreddit": "programming", "author_flair_text": null, "treatment_tags": [], "created_utc": 1207514820.0, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 1, "author_flair_background_color": "", "collapsed_because_crowd_control": null, "mod_reports": [], "mod_note": null, "distinguished": null}}, {"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": "", "user_reports": [], "saved": false, "id": "c03nk5b", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "kragensitaker", "can_mod_post": false, "created_utc": 1207598530.0, "send_replies": true, "parent_id": "t1_c03n8j5", "score": 1, "author_fullname": "t2_32umk", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "The idea is that one unambiguous way to explain what Common Lisp special forms do is to write definitions of them in Lisp --- rather than, say, using denotational semantics or Hoare axiomatic semantics.  There was at the time a big movement to define your language formally so that you could prove things about your programs' behavior, which has turned out to be harder than expected.", "edited": false, "top_awarded_type": null, "author_flair_css_class": null, "name": "t1_c03nk5b", "is_submitter": false, "downs": 0, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;The idea is that one unambiguous way to explain what Common Lisp special forms do is to write definitions of them in Lisp --- rather than, say, using denotational semantics or Hoare axiomatic semantics.  There was at the time a big movement to define your language formally so that you could prove things about your programs&amp;#39; behavior, which has turned out to be harder than expected.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03nk5b/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207598530.0, "author_flair_text": null, "treatment_tags": [], "collapsed": false, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 1, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n8j5", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "shreknel", "can_mod_post": false, "created_utc": 1207512083.0, "send_replies": true, "parent_id": "t3_6er9d", "score": 3, "author_fullname": "t2_22vln", "approved_by": null, "mod_note": null, "all_awardings": [], "collapsed": false, "body": "If anyone could explain the intent of this paper, I'd be grateful.\nFrom what I could grasp, he's saying that due to the fact that one could emulate these CL special forms, they should not be defined as special forms...\nThe fact that they are (to me) implies that it was an efficiency-based decision...", "edited": false, "top_awarded_type": null, "author_flair_css_class": null, "name": "t1_c03n8j5", "is_submitter": false, "downs": 0, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;If anyone could explain the intent of this paper, I&amp;#39;d be grateful.\nFrom what I could grasp, he&amp;#39;s saying that due to the fact that one could emulate these CL special forms, they should not be defined as special forms...\nThe fact that they are (to me) implies that it was an efficiency-based decision...&lt;/p&gt;\n&lt;/div&gt;", "removal_reason": null, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "gildings": {}, "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n8j5/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207512083.0, "author_flair_text": null, "treatment_tags": [], "link_id": "t3_6er9d", "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 0, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 3}}, {"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": {"kind": "Listing", "data": {"after": null, "dist": null, "modhash": "", "geo_filter": "", "children": [{"kind": "t1", "data": {"subreddit_id": "t5_2fwo", "approved_at_utc": null, "author_is_blocked": false, "comment_type": null, "awarders": [], "mod_reason_by": null, "banned_by": null, "author_flair_type": "text", "total_awards_received": 0, "subreddit": "programming", "author_flair_template_id": null, "likes": null, "replies": "", "user_reports": [], "saved": false, "id": "c03n8r3", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "killerstorm", "can_mod_post": false, "send_replies": true, "parent_id": "t1_c03n7mg", "score": 1, "author_fullname": "t2_m827", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "it seems to be better than i thought -- i thougt it requires writing interpreter or something of that scale, hacking funcall and apply.", "edited": false, "top_awarded_type": null, "downs": 0, "author_flair_css_class": null, "name": "t1_c03n8r3", "is_submitter": false, "collapsed": false, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;it seems to be better than i thought -- i thougt it requires writing interpreter or something of that scale, hacking funcall and apply.&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n8r3/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207513855.0, "author_flair_text": null, "treatment_tags": [], "created_utc": 1207513855.0, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 2, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n7mg", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": false, "author": "chneukirchen", "can_mod_post": false, "created_utc": 1207505370.0, "send_replies": true, "parent_id": "t1_c03n76o", "score": 4, "author_fullname": "t2_2l43", "removal_reason": null, "approved_by": null, "mod_note": null, "all_awardings": [], "body": "[Possible, but ugly.](http://www.emacswiki.org/cgi-bin/wiki/DynamicBindingVsLexicalBinding#toc10)", "edited": false, "top_awarded_type": null, "author_flair_css_class": null, "name": "t1_c03n7mg", "is_submitter": false, "downs": 0, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;&lt;a href=\"http://www.emacswiki.org/cgi-bin/wiki/DynamicBindingVsLexicalBinding#toc10\"&gt;Possible, but ugly.&lt;/a&gt;&lt;/p&gt;\n&lt;/div&gt;", "gildings": {}, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "link_id": "t3_6er9d", "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n7mg/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207505370.0, "author_flair_text": null, "treatment_tags": [], "collapsed": false, "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 1, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 4}}], "before": null}}, "user_reports": [], "saved": false, "id": "c03n76o", "banned_at_utc": null, "mod_reason_title": null, "gilded": 0, "archived": false, "collapsed_reason_code": null, "no_follow": true, "author": "killerstorm", "can_mod_post": false, "created_utc": 1207502437.0, "send_replies": true, "parent_id": "t3_6er9d", "score": 1, "author_fullname": "t2_m827", "approved_by": null, "mod_note": null, "all_awardings": [], "collapsed": false, "body": "it would be quite interesting to emulate _lexical_ variables when having only dynamic ones.", "edited": false, "top_awarded_type": null, "author_flair_css_class": null, "name": "t1_c03n76o", "is_submitter": false, "downs": 0, "author_flair_richtext": [], "author_patreon_flair": false, "body_html": "&lt;div class=\"md\"&gt;&lt;p&gt;it would be quite interesting to emulate &lt;em&gt;lexical&lt;/em&gt; variables when having only dynamic ones.&lt;/p&gt;\n&lt;/div&gt;", "removal_reason": null, "collapsed_reason": null, "distinguished": null, "associated_award": null, "stickied": false, "author_premium": false, "can_gild": true, "gildings": {}, "unrepliable_reason": null, "author_flair_text_color": null, "score_hidden": false, "permalink": "/r/programming/comments/6er9d/henry_baker_metacircular_semantics_for_common/c03n76o/", "subreddit_type": "public", "locked": false, "report_reasons": null, "created": 1207502437.0, "author_flair_text": null, "treatment_tags": [], "link_id": "t3_6er9d", "subreddit_name_prefixed": "r/programming", "controversiality": 0, "depth": 0, "author_flair_background_color": null, "collapsed_because_crowd_control": null, "mod_reports": [], "num_reports": null, "ups": 1}}], "before": null}}]
2 | 


--------------------------------------------------------------------------------
/tests/package.lisp:
--------------------------------------------------------------------------------
1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
3 | 
4 | (uiop:define-package #:njson/tests
5 |   (:use #:common-lisp #:lisp-unit2 #:njson))
6 | 


--------------------------------------------------------------------------------
/tests/pointer-test.json:
--------------------------------------------------------------------------------
 1 | {
 2 |     "foo": ["bar", "baz"],
 3 |     "": 0,
 4 |     "a/b": 1,
 5 |     "c%d": 2,
 6 |     "e^f": 3,
 7 |     "g|h": 4,
 8 |     "i\\j": 5,
 9 |     "k\"l": 6,
10 |     " ": 7,
11 |     "m~n": 8
12 | }
13 | 


--------------------------------------------------------------------------------
/tests/test.json:
--------------------------------------------------------------------------------
1 | [1, 3.8,
2 |  true, false, null,
3 |  "foo", [1, 2, 3], ["bar", true, null, 1000000],
4 |  {"quux": 1883}, {"foo": 1, "bar": [1, 2, "hey"], "quux": {"one": 1}}]
5 | 


--------------------------------------------------------------------------------
/tests/tests.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
  2 | ;;;; SPDX-License-Identifier: BSD-3-Clause
  3 | 
  4 | (in-package #:njson/tests)
  5 | 
  6 | (define-test json-literals ()
  7 |   (assert-eq :null (decode "null"))
  8 |   (assert-false (decode "false"))
  9 |   (assert-eq t (decode "true")))
 10 | 
 11 | (define-test json-atoms ()
 12 |   (assert-equal 5 (decode "5"))
 13 |   (assert-float-equal 5.5 (decode "5.5"))
 14 |   (assert-float-equal -885.5 (decode "-885.5"))
 15 |   (assert-equal "foo32348hjvn" (decode "\"foo32348hjvn\""))
 16 |   (assert-equal "" (decode "\"\"")))
 17 | 
 18 | (define-test tricky-values ()
 19 |   (assert-typep 'hash-table (decode "{}"))
 20 |   (assert-eql 0 (hash-table-count (decode "{}")))
 21 |   (assert-typep 'vector (decode "[]"))
 22 |   (assert-equalp #(nil) (decode "[false]")))
 23 | 
 24 | (define-test allow-json-comments ()
 25 |   (assert-true (prog1 t (decode "// hello
 26 | 3")))
 27 |   (assert-true (prog1 t (decode "{\"object\": //comment
 28 | \"value\"}")))
 29 |   (assert-true (prog1 t (decode "{\"object\" //comment
 30 | :\"value\"}")))
 31 |   (assert-true (prog1 t (decode "{//comment
 32 | \"object\": \"value\"}")))
 33 |   (assert-true (prog1 t (decode "[//comment
 34 | 1,2,3]")))
 35 |   (assert-true (prog1 t (decode "[//comment
 36 | 1, // comment
 37 | 2,3]")))
 38 |   (assert-true (prog1 t (decode "[//comment
 39 | 1,// comment
 40 | 2,3// comment
 41 | ]"))))
 42 | 
 43 | (define-test from-file ()
 44 |   (destructuring-bind (simple-1 float-3.8 true false null
 45 |                        string-foo array-123 array-of-everything
 46 |                        object-quux-1883 object-of-everything)
 47 |       (coerce (decode (asdf:system-relative-pathname :njson "tests/test.json")) 'list)
 48 |     (assert-eql 1 simple-1)
 49 |     (assert-float-equal 3.8 float-3.8)
 50 |     (assert-eq t true)
 51 |     (assert-false false)
 52 |     (assert-eq :null null)
 53 |     (assert-equal "foo" string-foo)
 54 |     (assert-equalp #(1 2 3) array-123)
 55 |     (assert-equalp #("bar" t :null 1000000) array-of-everything)
 56 |     (assert-typep 'hash-table object-quux-1883)
 57 |     (assert-eql 1883 (jget "quux" object-quux-1883))
 58 |     (assert-typep 'hash-table object-of-everything)
 59 |     (assert-eql 1 (jget "foo" object-of-everything))
 60 |     (assert-equalp #(1 2 "hey") (jget "bar" object-of-everything))
 61 |     (assert-typep 'hash-table (jget "quux" object-of-everything))
 62 |     (assert-eql 1 (jget "one" (jget "quux" object-of-everything)))))
 63 | 
 64 | (define-test jcopy-test ()
 65 |   (let* ((array #(1 2 3 "hello")))
 66 |     (assert-eql 8 (jcopy 8))
 67 |     (assert-float-equal 1.3 (jcopy 1.3))
 68 |     (assert-eq :null (jcopy :null))
 69 |     (assert-error 'error (jcopy :whatever))
 70 |     (assert-eq t (jcopy t))
 71 |     (assert-false (jcopy nil))
 72 |     (assert-equal "hello there" (jcopy "hello there"))
 73 |     ;; TODO: hash-tables
 74 |     (assert-false (eq array (jcopy array)))
 75 |     (assert-equalp array (jcopy array))))
 76 | 
 77 | (define-test jget-json-pointer ()
 78 |   (let ((object (decode (asdf:system-relative-pathname
 79 |                          ;; Taken directly from RFC 6901.
 80 |                          :njson "tests/pointer-test.json"))))
 81 |     (assert-eq object (jget #p"" object))
 82 |     (assert-equalp #("bar" "baz") (jget #p"/foo" object))
 83 |     (assert-equal "bar" (jget #p"/foo/0" object))
 84 |     (assert-eql 0 (jget #p"/" object))
 85 |     (assert-eql 1 (jget #p"/a~1b" object))
 86 |     (assert-eql 2 (jget #p"/c%d" object))
 87 |     (assert-eql 3 (jget #p"/e^f" object))
 88 |     (assert-eql 4 (jget #p"/g|h" object))
 89 |     ;; FIXME: broken due to pathname processing.
 90 |     ;; (assert-eql 5 (jget #p"/i\\j" object))
 91 |     (assert-eql 6 (jget #p"/k\"l" object))
 92 |     (assert-eql 7 (jget #p"/ " object))
 93 |     (assert-eql 8 (jget #p"/m~0n" object))))
 94 | 
 95 | (define-test jget-errors ()
 96 |   (let ((object (decode (asdf:system-relative-pathname :njson "tests/test.json"))))
 97 |     (assert-error 'non-indexable (jget 20 nil))
 98 |     (assert-error 'non-indexable (jget 20 t))
 99 |     (assert-error 'non-indexable (jget 20 :null))
100 |     (assert-error 'non-indexable (jget 20 200))
101 |     (assert-error 'non-indexable (jget 20 200.3))
102 |     (assert-error 'non-indexable (jget 20 "foo"))
103 |     (assert-error 'invalid-key (jget 20 (jget 8 object)))
104 |     (assert-error 'invalid-key (jget "bar" (jget 7 object)))
105 |     (assert-error 'invalid-pointer (jget #p"hello" object))))
106 | 
107 | (define-test setf-jget-errors ()
108 |   (let ((object (decode (asdf:system-relative-pathname :njson "tests/test.json"))))
109 |     (assert-error 'invalid-key (setf (jget 20 (jget 8 object)) nil))
110 |     (assert-error 'invalid-key (setf (jget "bar" (jget 7 object)) nil))
111 |     (assert-error 'invalid-key (setf (jget #p"" (jget 7 object)) nil))
112 |     (assert-error 'invalid-key (setf (jget #() (jget 7 object)) nil))
113 |     (assert-error 'non-indexable (setf (jget 20 200.3) 10))
114 |     (assert-error 'non-indexable (setf (jget 20 "foo") nil))))
115 | 
116 | (define-test keys ()
117 |   (let ((object (decode (asdf:system-relative-pathname :njson "tests/test.json"))))
118 |     (assert-error 'non-indexable (jkeys (jget 0 object)))
119 |     (assert-error 'non-indexable (jkeys (jget 5 object)))
120 |     (assert-equal '(0 1 2 3) (jkeys (jget 7 object)))
121 |     (assert-equal '("quux") (jkeys (jget 8 object)))
122 |     (assert-equal '() (jkeys (decode "{}")))
123 |     (assert-equal '() (jkeys (decode "[]")))))
124 | 
125 | (define-test ensure ()
126 |   (assert-equalp #("hello") (ensure-array "hello"))
127 |   (assert-equalp #(t) (ensure-array t))
128 |   (assert-equalp #(nil) (ensure-array nil))
129 |   (assert-equalp #(:null) (ensure-array :null))
130 |   (assert-equalp #(8) (ensure-array 8))
131 |   (assert-equalp #(1.3) (ensure-array 1.3))
132 |   (assert-equalp #(1.3 "foo") (ensure-array #(1.3 "foo")))
133 |   (assert-equalp #() (ensure-array #()))
134 |   (assert-equalp (vector (decode "{}"))
135 |                  (ensure-array (decode "{}")))
136 |   (assert-equalp (vector (decode "{\"a\": 1, \"b\": 2}"))
137 |                  (ensure-array (decode "{\"a\": 1, \"b\": 2}")))
138 |   ;; Order is not guaranteed.
139 |   (assert-true (member (ensure-array (decode "{\"a\": 1, \"b\": 2}") :convert-objects t)
140 |                        (list #(1 2) #(2 1))
141 |                        :test #'equalp))
142 | 
143 |   (let ((literal-object (ensure-object "number" 3)))
144 |     (assert-typep 'hash-table literal-object)
145 |     (assert-eql 3 (jget "number" literal-object)))
146 |   (let ((object-already (ensure-object "number" (njson:decode "{\"number\": 3}"))))
147 |     (assert-typep 'hash-table object-already)
148 |     (assert-eql 3 (jget "number" object-already)))
149 |   (let ((array-object (ensure-object "numbers" #(1 2 3 4 82))))
150 |     (assert-typep 'hash-table array-object)
151 |     (assert-equalp #(1 2 3 4 82) (jget "numbers" array-object))))
152 | 
153 | (define-test jbind-patterns ()
154 |   (let ((baker (decode (asdf:system-relative-pathname :njson "tests/baker.json"))))
155 |     (macrolet ((assert-bind (path)
156 |                  `(assert-true
157 |                    (njson:jbind ,path
158 |                        baker
159 |                      t)))
160 |                (assert-mismatch (path)
161 |                  `(assert-error
162 |                    'value-mismatch
163 |                    (njson:jbind ,path
164 |                        baker)))
165 |                (assert-no-key (path)
166 |                  `(assert-error
167 |                    'no-key
168 |                    (njson:jbind ,path
169 |                        baker))))
170 |       (assert-bind #())
171 |       (assert-bind #(()))
172 |       (assert-mismatch ())
173 |       (assert-typep
174 |        'hash-table
175 |        (njson:jbind #(("data" data))
176 |            baker
177 |          data))
178 |       (assert-bind #(("data" ("children" #()))))
179 |       (assert-bind #(("data" ("children" #(())))))
180 |       (assert-typep
181 |        'hash-table
182 |        (njson:jbind #(("data" ("children" #(("data" data)))))
183 |            baker
184 |          data))
185 |       (assert-bind #(("data" ("children" #(("data" ()))))))
186 |       (assert-equal
187 |        "Henry Baker: Meta-circular semantics for Common Lisp special forms"
188 |        (njson:jbind #(("data" ("children" #(("data" ("title" title))))))
189 |            baker
190 |          title))
191 |       (assert-bind #(("data" ("children" #(("kind" "t3"))))))
192 |       (assert-mismatch #(("data" ("children" ()))))
193 |       (assert-mismatch #(("data" ("children" #(("kind" 5))))))
194 |       (assert-bind #(("data" ("after" :null))))
195 |       (assert-mismatch #(("data" ("after" "not null"))))
196 |       (assert-bind #(("data" ("dist" 1))))
197 |       (assert-mismatch #(("data" ("dist" 1.000001))))
198 |       (assert-bind #(("data" ("children" #(("data" ("upvote_ratio" 0.59)))))))
199 |       (assert-mismatch #(("data" ("children" #(("data" ("upvote_ratio" 0.6)))))))
200 |       (assert-bind #(("data" ("children" #(("data" ("hide_score" :false)))))))
201 |       (assert-mismatch #(("data" ("children" #(("data" ("hide_score" :true)))))))
202 |       (assert-bind #(("data" ("children" #(("data" ("is_robot_indexable" :true)))))))
203 |       (assert-mismatch #(("data" ("children" #(("data" ("is_robot_indexable" :false)))))))
204 |       (assert-bind #(("data" ("modhash" ""))))
205 |       (assert-mismatch #(("data" ("modhash" "non-empty-string"))))
206 |       (assert-mismatch #(("data" ("modhash" #()))))
207 |       (assert-bind
208 |        #(("data"
209 |           ("children"
210 |            #(("data" ("title"
211 |                       "Henry Baker: Meta-circular semantics for Common Lisp special forms")))))))
212 |       (assert-error
213 |        'type-error
214 |        (macroexpand
215 |         '(jbind #(("data" ("modhash" :invalid-keword)))
216 |           baker)))
217 |       (assert-true
218 |        (jbind true
219 |            t
220 |          true))
221 |       (assert-false
222 |        (jbind false
223 |            nil
224 |          nil))
225 |       (assert-equal
226 |        "hello" (jbind string
227 |                    "hello"
228 |                  string))
229 |       ;; Test lenient var-p bindings
230 |       (assert-bind #(("data" ("modhash" (modhash modhash-p)))))
231 |       (assert-bind #(("data" ("modfoo" (modfoo modfoo-p)))))
232 |       (assert-bind #(("data" ("modfoo" (modfoo)))))
233 |       ;; Uncomment on version 2 when jget* and jget merge into one.
234 |       ;; (assert-no-key #(() () 8))
235 |       ;; (assert-no-key #(("data" ("parents" _))))
236 |       ;; (assert-no-key #(("data" ("parents" ("nested" :true)))))
237 |       )))
238 | 


--------------------------------------------------------------------------------