Improve parsing and pretty-printing of JSON (#1199)

Allow parsing to return walist with parameter json-object-walist?

Do pretty-printing without jq -M ., add a lisp-style? option as well as
an option to override json-sort-keys, and an indentation size.

doc/reference/std/text/json.md

@@ -1,12 +1,12 @@
 # JSON
 ::: tip To use the bindings from this module:
-``` scheme
+```scheme
 (import :std/text/json)
 ```
 :::
 
 ## read-json
-``` scheme
+```scheme
 (read-json [input = (current-input-port)]) -> json | error
 
   input := input source to read JSON data
@@ -20,7 +20,7 @@ The input source can be:
 - A BufferedReader.
 
 ## write-json
-``` scheme
+```scheme
 (write-json obj [sink = (current-output-port)]) -> void | error
 
   obj  := JSON object
@@ -38,7 +38,7 @@ The output sink can be:
 - A Writer.
 
 ## string->json-object
-``` scheme
+```scheme
 (string->json-object str) -> json | error
 
   str := a string of JSON data
@@ -47,7 +47,7 @@ The output sink can be:
 Parses given *str* and returns JSON object or signals an error if it fails to parse.
 
 ## json-object->string
-``` scheme
+```scheme
 (json-object->string obj) -> string | error
 
   obj := JSON object
@@ -57,7 +57,7 @@ Returns a newly allocated string with JSON object as a string. Signals an error
 fails to print JSON.
 
 ## bytes->json-object
-``` scheme
+```scheme
 (bytes->json-object str) -> json | error
 
   bytes := u8vector encoding a UTF-8 string of JSON data
@@ -66,7 +66,7 @@ fails to print JSON.
 Parses given *bytes* and returns JSON object or signals an error if it fails to parse.
 
 ## json-object->bytes
-``` scheme
+```scheme
 (json-object->bytes obj) -> u8vector | error
 
   obj := JSON object
@@ -76,53 +76,117 @@ Returns a newly allocated u8vector with JSON object as bytes.
 Signals an error if it fails to print JSON.
 
 ## port->json-object
-``` scheme
+```scheme
 (port->json-object port) -> json | error
 
   port := input port
 ```
 
 Parses data on given *port* and returns JSON object or signals an error if it fails to parse.
 
-## json-symbolic-keys
-``` scheme
-json-symbolic-keys
+## read-json-key-as-symbol?
+```scheme
+read-json-key-as-symbol?
 ```
 
-Boolean parameter to control should decoded hashes have symbols as keys? Defaults to `#t`.
-`#f` means that keys will be strings.
+Boolean parameter to control whether JSON “objects” be decoded
+as using symbols rather than strings as keys?
+`#f` the default means strings, `#t` means symbols.
+
+NB: Before v0.18.2, this parameter used to be called `json-symbolic-keys` and default to `#t`.
+The name is still available as an alias (sharing the default `#f`),
+but may be removed as early as v0.19.
 
 ::: tip Examples
-``` scheme
+```scheme
 > (hash->list (string->json-object "{\"a\":1}"))
-((a . 1))
+(("a" . 1))
 
-> (parameterize ((json-symbolic-keys #f))
+> (parameterize ((read-json-key-as-symbol? #t))
     (hash->list (string->json-object "{\"a\":1}")))
-(("a" . 1))
+((a . 1))
+```
+
+## json-object-walist?
+```scheme
+json-object-walist?
+```
+
+Parameter to control how JSON objects should be decoded.
+If false (the default), JSON objects will be hash-tables.
+If true, JSON objects will be `walistq`
+(or `walist` if read-json-key-as-symbol? is false).
+
+This allows you to preserve the order of keys from JSON text,
+in cases where this order matters, e.g. for the sake of
+pretty-printing JSON or reading pretty-printed JSON,
+where the order will make the data more readable to humans.
+
+NB: This parameter was introduced in Gerbil v0.18.2.
+
+::: tip Examples
+```scheme
+> (parameterize ((json-object-walist? #f))
+    (hash->list (string->json-object "{\"a\":1,\"b\":2}")))
+((a . 1) (b . 2))
+
+> (parameterize ((json-object-walist? #t))
+    (walist->alist (string->json-object "{\"a\":1,\"b\":2}")))
+((a . 1) (b . 2))
 ```
 
-## json-list-wrapper
-``` scheme
-json-list-wrapper
+## read-json-array-as-vector?
+```scheme
+read-json-array-as-vector?
 ```
 
-Parameter to control how JSON lists should be transformed.
-Defaults to `identity`, which means keep them as lists.
-If bound to `list->vector` then JSON lists will be parsed as vectors.
+Parameter to control how JSON “arrays” should be transformed.
+Defaults to `#f`, which means keep them as lists.
+Binding it to `#t` instead will mean read them as vectors.
+
+NB: Since Gerbil v0.18.2, this parameter replaces with reduced but more
+streamlined functionality the previous `json-list-wrapper` parameter.
+That previous parameter isn’t used anymore, and may be removed as early as v0.19.
 
 ::: tip Examples
-``` scheme
-> (string->json-object "[\"a\",1]")
-("a" 1)
+```scheme
+> (string->json-object "[\"a\",1,[]]")
+("a" 1 ())
 
-> (parameterize ((json-list-wrapper list->vector))
+> (parameterize ((read-json-array-as-vector? #t))
     (string->json-object "[\"a\",1]"))
-#("a" 1)
+#("a" 1 ())
+```
+
+## write-json-sort-keys?
+```scheme
+write-json-sort-keys?
+```
+
+This is a parameter that can be used to control how JSON objects should be written.
+If false (the default), keys in JSON objects represented by hash-tables will be written
+in no particular predictable order, by iterating as fast as possible through the hash-table.
+If true, keys in JSON objects represented by hash-tables will be written in asciibetical order.
+In either case, JSON objects represented by walists will be written in the order specified
+by the walist. You can sort the walist yourself according to the order that matters to you,
+whether asciibetical or not.
+
+NB: This parameter used to be called `json-sort-keys` and default to `#t` before Gerbil v0.18.2.
+The name is still available as an alias (sharing the default `#f`),
+but may be removed as early as v0.19.
+
+::: tip Examples
+```scheme
+> (parameterize ((write-json-sort-keys? #t))
+    (json-object->string (hash (foo 1) (bar 2) (baz 3))))
+"{\"bar\":2,\"baz\":3,\"foo\":1}"
+> (parameterize ((write-json-sort-keys? #f))
+    (json-object->string (hash (foo 1) (bar 2) (baz 3))))
+"{\"baz\":3,\"bar\":2,\"foo\":1}"
 ```
 
 ## trivial-class->json-object
-``` scheme
+```scheme
 (trivial-class->json-object object) -> json | error
 
   object := an object
@@ -132,7 +196,7 @@ Extracts a printable JSON object from the slots of an `object`,
 or signals an error if it fails.
 
 ## json-object->trivial-class
-``` scheme
+```scheme
 (json-object->trivial-class class-descriptor json) -> object | error
 
   class-descriptor := class-descriptor
@@ -143,7 +207,7 @@ Creates an object of the class corresponding to the `class-descriptor`
 by extracting its slots from a `json` hash-table.
 
 ## JSON
-``` scheme
+```scheme
 JSON -> class
 JSON::t -> class-descriptor
 ```
@@ -152,10 +216,21 @@ The default `:json` method is `trivial-class->json-object`.
 
 ## pretty-json
 ```scheme
-(pretty-json object [output])
+(pretty-json object [output]
+   [indent: 2] [sort-keys?: (json-sort-keys)] [lisp-style?: #f])
 ```
 A function that pretty-prints a JSON `object` to the specified `output`
-as per [with-output](../misc/ports.md#with-output)
+as per [open-buffered-string-writer](../stdio.md#open-buffered-reader)
 (defaults to `#f`, i.e. print to string).
-
-Internally this function uses the external program `jq -M .` to do the pretty-printing.
+The `indent` keyword specifies how much to increase indentation at each level of nesting
+(must be a positive integer, defaults to 2).
+The `sort-keys?` keyword offers a shortcut to parameterizing `write-json-sort-keys?`
+which is heeded just like by `write-json`.
+The `lisp-style?` keyword if true specifies a format that follows Lisp style,
+and saves number of lines by starting objects and lists on the same line as the
+square or curly bracket, and closing it on the same line as the last entry,
+as opposed to regular style that uses newlines copiously.
+
+NB: Since Gerbil v0.18.2, this function no longer invokes `jq -M .` as an external program,
+and no longer uses `with-output` but instead `open-buffered-string-writer`,
+and has extra keyword arguments.

src/std/io/interface.ss

@@ -122,7 +122,7 @@
   (skip (count :~ nonnegative-fixnum? :- :fixnum))
   => :void
 
-  ;; returns a new StringBufferedReader instance delimiting the input length that shares
+  ;; returns a new BufferedStringReader instance delimiting the input length that shares
   ;; the underlying buffer; the limit must be a fixnum.
   (delimit (limit :~ nonnegative-fixnum? :- :fixnum))
   => @BufferedStringReader

src/std/net/json-rpc-test.ss

@@ -49,12 +49,14 @@
       (test-basic-handlers 'GET)
       (check-exception (query 42 http-method: 'GET) true)) ;; can't uri-encode number 42
     (test-case "encode params"
-      (check-equal? (json-object->string
-                     (json-rpc-request jsonrpc: json-rpc-version
-                                       method: "foo" params: [42 "hello"] id: 13))
-                    "{\"id\":13,\"jsonrpc\":\"2.0\",\"method\":\"foo\",\"params\":[42,\"hello\"]}"))
+      (parameterize ((read-json-key-as-symbol? #f)
+                     (write-json-sort-keys? #t))
+        (check-equal? (json-object->string
+                       (json-rpc-request jsonrpc: json-rpc-version
+                                         method: "foo" params: [42 "hello"] id: 13))
+                      "{\"id\":13,\"jsonrpc\":\"2.0\",\"method\":\"foo\",\"params\":[42,\"hello\"]}")))
     (test-case "decode result"
-      (parameterize ((json-symbolic-keys #f))
+      (parameterize ((read-json-key-as-symbol? #f))
         (check-equal? (decode-json-rpc-response
                        1+ 69 (string->json-object "{\"jsonrpc\": \"2.0\", \"result\": 1776, \"id\": 69}"))
                       1777)))
@@ -66,7 +68,8 @@
                ((JSON-RPCError code: -151 message: "foo" data: #!void) #t)
                (else #f)) => #t))
     (test-case "decode errors"
-      (parameterize ((json-symbolic-keys #f))
+      (parameterize ((read-json-key-as-symbol? #f)
+                     (write-json-sort-keys? #t))
         (def response-json-1
           (string->json-object "{\"jsonrpc\": \"2.0\", \"error\": { \"code\": -151, \"message\": \"foo\", \"data\": [1] }, \"id\": 42 }"))
         (check-exception (decode-json-rpc-response 1+ 42 response-json-1)

src/std/net/json-rpc.ss

@@ -37,7 +37,7 @@
   (only-in :std/net/uri form-url-decode uri-decode)
   (only-in :std/sugar try catch hash)
   (only-in :std/text/base64 u8vector->base64-string base64-string->u8vector)
-  (only-in :std/text/json trivial-json-object->class JSON json-symbolic-keys
+  (only-in :std/text/json trivial-json-object->class JSON read-json-key-as-symbol?
            bytes->json-object json-object->bytes json-object->string))
 
 (deferror-class (JSON-RPCError IOError)
@@ -124,7 +124,7 @@
   class-instance-init!)
 
 (def (bytes->json b) ;; Don't intern JSON keys, using strings
-  (parameterize ((json-symbolic-keys #f)) (bytes->json-object b)))
+  (parameterize ((read-json-key-as-symbol? #f)) (bytes->json-object b)))
 
 ;;; Client code
 ;; TODO: implement timeouts, with semi-asynchronous shutdown of the http-post thread itself.

src/std/text/json/api.ss

@@ -5,7 +5,10 @@
 (export read-json write-json
         string->json-object json-object->string
         bytes->json-object json-object->bytes port->json-object
-        json-symbolic-keys json-list-wrapper json-sort-keys
+        read-json-key-as-symbol? read-json-object-as-walist? read-json-array-as-vector?
+        write-json-sort-keys?
+        ;; The following line is old names / aliases, TO BE REMOVED as early as v0.19
+        json-symbolic-keys json-sort-keys json-list-wrapper ;; <-- TO BE REMOVED
         trivial-class->json-object trivial-json-object->class
         trivial-struct->json-object trivial-json-object->struct
         JSON JSON::t pretty-json)

src/std/text/json/env.ss

@@ -1,33 +1,46 @@
 ;;; -*- Gerbil -*-
-;;; ̧© vyzo
+;;; © vyzo
 ;;; json io environment
 (import :std/error
         :std/sugar)
 (export #t)
 
-;; should decoded hashes have symbols as keys?
-(def json-symbolic-keys
-  (make-parameter #t))
+;; Should decoded JSON "objects" have symbols as keys rather than strings?
+(def read-json-key-as-symbol?
+  (make-parameter #f))
 
-;; What should lists be decoded to? identity means a list, list->vector means a vector.
-(def json-list-wrapper
-  (make-parameter identity))
+;; What should JSON "objects" be decoded to walist instead of hash?
+(def read-json-object-as-walist?
+  (make-parameter #f))
+
+;; What should JSON "arrays" be decoded to Scheme vectors rather than Scheme list?
+(def read-json-array-as-vector?
+  (make-parameter #f))
 
 ;; Should object keys be sorted when writing json?
 ;; Checking for duplicate keys only reliably works when this is true.
-(def json-sort-keys
-  (make-parameter #t))
+(def write-json-sort-keys?
+  (make-parameter #f))
+
+;; Old names, to be removed in v0.19.
+(def json-symbolic-keys read-json-key-as-symbol?)
+(def json-sort-keys write-json-sort-keys?)
+(def json-list-wrapper (make-parameter identity)) ;; not used anymore, only there for soft migration
 
-(defstruct env (symbolic-keys sort-keys list-wrapper)
+(defstruct env (read-json-key-as-symbol?
+                read-json-object-as-walist?
+                read-json-array-as-vector?
+                write-json-sort-keys?)
   constructor: :init!
-  final: #t )
+  transparent: #t final: #t)
 
 (defmethod {:init! env}
   (lambda (self)
     (using (self :- env)
-      (set! self.symbolic-keys (json-symbolic-keys))
-      (set! self.sort-keys (json-sort-keys))
-      (set! self.list-wrapper (json-list-wrapper)))))
+      (set! self.read-json-key-as-symbol? (read-json-key-as-symbol?))
+      (set! self.read-json-object-as-walist? (read-json-object-as-walist?))
+      (set! self.read-json-array-as-vector? (read-json-array-as-vector?))
+      (set! self.write-json-sort-keys? (write-json-sort-keys?)))))
 
 (defrule (raise-invalid-token where input char)
   (if (eof-object? char)