std/misc/walist -- wrapped alists

Pure and stateful wrapped alists, carry with them the equality predicate
and, for the stateful ones, correctly handle the case of empty alists.

src/std/build-deps

@@ -174,6 +174,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?)