Add std/misc/walist, use it in std/text/json

Add a library for wrapped alists: alists in a box, such that the equality
predicate is transported with the data, and, when stateful, the empty alist
is properly handled.

Use walist to enable user-controled field order when printing json objects.

src/std/build-deps

@@ -123,6 +123,7 @@
    gerbil/gambit/exact
    gerbil/gambit/ports
    std/error
+   std/misc/walist
    std/sort
    std/text/hex))
  (std/text/_zlib
@@ -174,6 +175,7 @@
  (std/misc/list-builder "misc/list-builder" (gerbil/core))
  (std/misc/alist "misc/alist" (gerbil/core std/sugar))
  (std/misc/plist "misc/plist" (gerbil/core std/sugar))
+ (std/misc/walist "misc/walist" (gerbil/core std/sugar std/misc/alist))
  (std/misc/rtd "misc/rtd" (gerbil/core))
  (std/misc/shuffle "misc/shuffle" (gerbil/core gerbil/gambit/random))
  (std/event

src/std/build-spec.ss

@@ -254,6 +254,7 @@
     "misc/list"
     "misc/alist"
     "misc/plist"
+    "misc/walist"
     "misc/rtd"
     "misc/shuffle"
     "misc/uuid"

src/std/misc/walist-test.ss

@@ -0,0 +1,44 @@
+(export walist-test)
+
+(import
+  :gerbil/gambit/exceptions
+  :std/error :std/misc/walist :std/test)
+
+(def walist-test
+  (test-suite "test :std/misc/walist"
+    (def (test-walist-ro make a1b2)
+      (check-equal? (walist-alist (a1b2)) '((a . 1) (b . 2)))
+      (check-equal? {key? (a1b2) 'a} #t)
+      (check-equal? {key? (a1b2) 'b} #t)
+      (check-equal? {key? (a1b2) 'c} #f)
+      (check-equal? {get (a1b2) 'a} 1)
+      (check-equal? {get (a1b2) 'b} 2)
+      (check-exception {get (a1b2) 'c} true))
+    (def (test-walist make)
+      (def (a1b2) {acons {acons (make '()) 'b 2} 'a 1})
+      (test-walist-ro make a1b2)
+      (check-equal? {put (a1b2) 'a 3} (make '((a . 3) (b . 2))))
+      (check-equal? {put (a1b2) 'c 3} (make '((c . 3) (a . 1) (b . 2))))
+      (check-equal? {put (a1b2) 'b 4} (make '((a . 1) (b . 4))))
+      (check-equal? {remove (a1b2) 'a} (make '((b . 2))))
+      (check-equal? {remove (a1b2) 'b} (make '((a . 1))))
+      (check-equal? {remove (a1b2) 'c} (a1b2))
+      (check-equal? {remove (make '()) 'a} (make '()))
+      (check-equal? {remove (make '((a . 1))) 'a} (make '())))
+    (def (test-walist! make)
+      (def (a1b2) (def w (make '())) {acons! w 'b 2} {acons! w 'a 1} w)
+      (test-walist-ro make a1b2)
+      (check-equal? (let (w (a1b2)) {put! w 'a 3} w) (make '((a . 3) (b . 2))))
+      (check-equal? (let (w (a1b2)) {put! w 'c 3} w) (make '((c . 3) (a . 1) (b . 2))))
+      (check-equal? (let (w (a1b2)) {put! w 'b 4} w) (make '((a . 1) (b . 4))))
+      (check-equal? (let (w (a1b2)) {remove! w 'a} w) (make '((b . 2))))
+      (check-equal? (let (w (a1b2)) {remove! w 'b} w) (make '((a . 1))))
+      (check-equal? (let (w (a1b2)) {remove! w 'c} w) (a1b2))
+      (check-equal? (let (w (make '())) {remove! w 'a} w) (make '()))
+      (check-equal? (let (w (make [['a . 1]])) {remove! w 'a} w) (make '())))
+    (test-walist make-walist)
+    (test-walist make-walistq)
+    (test-walist make-walistv)
+    (test-walist! make-walist!)
+    (test-walist! make-walistq!)
+    (test-walist! make-walistv!)))

src/std/misc/walist.ss

@@ -0,0 +1,91 @@
+(import
+  :std/misc/alist
+  :std/sugar)
+
+(export
+  _walist_ _walist_?
+  walist walistq walistv walist! walistq! walistv!
+  walist? walistq? walistv? walist!? walistq!? walistv!?
+  make-walist make-walistq make-walistv make-walist! make-walistq! make-walistv!
+  walist-alist walist-alist-set!
+  walist-acons walistq-acons walistv-acons walist-acons!
+  walist-key? walistq-key? walistv-key?
+  walist-get walistq-get walistv-get
+  walist-put walistv-put walistq-put walist!-put! walistv!-put! walistq!-put!
+  walist-remove walistv-remove walistq-remove walist!-remove! walistv!-remove! walistq!-remove!)
+
+(defstruct _walist_ (alist) transparent: #t)
+(defstruct (_walist _walist_) () transparent: #t) ;; equal?
+(defstruct (_walistq _walist_) () transparent: #t) ;; eq?
+(defstruct (_walistv _walist_) () transparent: #t) ;; eqv?
+(defstruct (walist _walist) () transparent: #t final: #t) ;; equal?, pure
+(defstruct (walistq _walistq) () transparent: #t final: #t) ;; eq?, pure
+(defstruct (walistv _walistv) () transparent: #t final: #t) ;; eqv?, pure
+(defstruct (walist! _walist) () transparent: #t final: #t) ;; equal?, stateful
+(defstruct (walistq! _walistq) () transparent: #t final: #t) ;; eq?, stateful
+(defstruct (walistv! _walistv) () transparent: #t final: #t) ;; eqv?, stateful
+
+(def walist-alist _walist_-alist)
+(def (walist-alist-set! w a) (set! (_walist_-alist w) a))
+
+(def (walist-acons w k v) (make-walist (acons k v (walist-alist w))))
+(def (walistq-acons w k v) (make-walistq (acons k v (walist-alist w))))
+(def (walistv-acons w k v) (make-walistv (acons k v (walist-alist w))))
+(def (walist-acons! w k v) (set! (_walist_-alist w) (acons k v (_walist_-alist w))))
+(defmethod {acons walist} walist-acons)
+(defmethod {acons walistq} walistq-acons)
+(defmethod {acons walistv} walistv-acons)
+(defmethod {acons! _walist_} walist-acons!)
+
+(def (walist-key? w k) (pair? (assoc k (walist-alist w))))
+(def (walistq-key? w k) (pair? (assq k (walist-alist w))))
+(def (walistv-key? w k) (pair? (assv k (walist-alist w))))
+(defmethod {key? _walist} walist-key?)
+(defmethod {key? _walistq} walistq-key?)
+(defmethod {key? _walistv} walistv-key?)
+
+(def (walist-get w k) (cdr (assoc k (walist-alist w))))
+(def (walistq-get w k) (cdr (assq k (walist-alist w))))
+(def (walistv-get w k) (cdr (assv k (walist-alist w))))
+(defmethod {get _walist} walist-get)
+(defmethod {get _walistq} walistq-get)
+(defmethod {get _walistv} walistv-get)
+
+(def (walist-put w k v) (make-walist (aset (walist-alist w) k v)))
+(def (walistq-put w k v) (make-walistq (asetq (walist-alist w) k v)))
+(def (walistv-put w k v) (make-walistv (asetv (walist-alist w) k v)))
+(defmethod {put walist} walist-put)
+(defmethod {put walistq} walistq-put)
+(defmethod {put walistv} walistv-put)
+
+(def (walist-remove w k) (make-walist (arem k (walist-alist w))))
+(def (walistq-remove w k) (make-walistq (aremq k (walist-alist w))))
+(def (walistv-remove w k) (make-walistv (aremv k (walist-alist w))))
+(defmethod {remove walist} walist-remove)
+(defmethod {remove walistq} walistq-remove)
+(defmethod {remove walistv} walistv-remove)
+
+(def (walist!-put! w k v) (aset! (walist-alist w) k v))
+(def (walistq!-put! w k v) (asetq! (walist-alist w) k v))
+(def (walistv!-put! w k v) (asetv! (walist-alist w) k v))
+(defmethod {put! walist!} walist!-put!)
+(defmethod {put! walistv!} walistv!-put!)
+(defmethod {put! walistq!} walistq!-put!)
+
+(defrule (define-remove! struct! fun cmp)
+  (begin
+    (def (fun w key)
+      (let lp ((p (walist-alist w)) (prev #f))
+        (match p
+          ([[k . _] . r]
+           (cond
+            ((not (cmp key k)) (lp r p))
+            (prev (set-cdr! prev r))
+            (else (set! (_walist_-alist w) r))))
+          ([] (void)) ; key not found: NOP
+          (_ (error "Invalid walist" 'struct! w key)))))
+    (defmethod {remove! struct!} fun)))
+
+(define-remove! walist! walist!-remove! equal?)
+(define-remove! walistq! walistq!-remove! eq?)
+(define-remove! walistv! walistv!-remove! eqv?)

src/std/text/json-test.ss

@@ -4,25 +4,25 @@
 
 (import :std/test
         :std/text/json
+        :std/misc/walist
         :std/sugar)
 (export json-test)
 
 (defstruct foo (a b) transparent: #t)
 (defmethod {:write-json foo}
   (lambda (self port)
     (with ((foo a b) self)
-      (write-json-alist [(cons 'b (1+ b)) (cons 'a a)] port))))
+      (write-json (make-walist [(cons 'b (1+ b)) (cons 'a a)]) port))))
 
 (def json-test
   (test-suite "test :std/text/json"
 
     (def (check-encode-decode obj str)
       (parameterize ((json-sort-keys #f))
-        (check (call-with-input-string (call-with-output-string (cut write-json obj <>)) read-json)
-               => obj))
+        (check (string->json-object (json-object->string obj)) => obj))
       (parameterize ((json-sort-keys #t))
-        (check (call-with-output-string (cut write-json obj <>)) => str)
-        (check (call-with-input-string str read-json) => obj)))
+        (check (json-object->string obj) => str)
+        (check (string->json-object str) => obj)))
 
     (def (check-encode-decode= obj)
       (let (p (open-output-u8vector))
@@ -53,5 +53,5 @@
         (check-encode-decode (hash ("a" 1) ("b" 2) ("c" (hash ("d" 3) ("e" 4) ("f" 5))))
                              "{\"a\":1,\"b\":2,\"c\":{\"d\":3,\"e\":4,\"f\":5}}"))
       (check-encode-decode [1 2 #f #t 3] "[1,2,false,true,3]")
-      (check (call-with-output-string (cut write-json (foo 23 41) <>)) => "{\"b\":42,\"a\":23}")
+      (check (json-object->string (foo 23 41)) => "{\"b\":42,\"a\":23}")
     )))

src/std/text/json.ss

@@ -20,11 +20,11 @@
         :gerbil/gambit/exact
         :std/error
         :std/sort
+        :std/misc/walist
         :std/text/hex)
 (export read-json write-json
         string->json-object json-object->string
-        json-symbolic-keys json-list-wrapper json-sort-keys
-        write-json-alist write-json-alist/sort json-sort-alist)
+        json-symbolic-keys json-list-wrapper json-sort-keys)
 (declare (not safe))
 
 (def (read-json (port (current-input-port)))
@@ -287,6 +287,8 @@
     (write-json-vector obj port))
    ((hash-table? obj)
     (write-json-hash obj port))
+   ((_walist_? obj)
+    (write-json-alist (walist-alist obj) port))
    ((eq? #t obj)
     (write-string "true" port))
    ((eq? #f obj)
@@ -350,7 +352,7 @@
    (else
     (error "Illegal hash key; must be symbol, keyword or string" obj key))))
 
-;; Assume the list is sorted
+;; NB: we assume the list is sorted according to some order for the sake of detecting duplicates
 (def (write-json-alist alist port (obj alist))
   (write-char #\{ port)
   (let lp ((previous-key #f) (rest alist))