diff --git a/src/std/misc/walist-test.ss b/src/std/misc/walist-test.ss new file mode 100644 index 0000000000..5e3fcb630e --- /dev/null +++ b/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!))) diff --git a/src/std/misc/walist.ss b/src/std/misc/walist.ss new file mode 100644 index 0000000000..70b47148ef --- /dev/null +++ b/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?) diff --git a/src/std/text/json-test.ss b/src/std/text/json-test.ss index 10331fc8f8..f568cf0591 100644 --- a/src/std/text/json-test.ss +++ b/src/std/text/json-test.ss @@ -4,6 +4,7 @@ (import :std/test :std/text/json + :std/misc/walist :std/sugar) (export json-test) @@ -11,18 +12,17 @@ (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}") ))) diff --git a/src/std/text/json.ss b/src/std/text/json.ss index bf7a5cbac2..47ecb2dbe5 100644 --- a/src/std/text/json.ss +++ b/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))