diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 92795afe..358bfecd 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -1598,6 +1598,283 @@ (sep (if (> (len args) 1) (nth args 1) " "))) (assoc interp :result (join sep elems))))) +; --- dict command helpers --- + +; Parse flat dict string into SX list of [key val] pairs +(define + tcl-dict-to-pairs + (fn + (dict-str) + (let + ((flat (tcl-list-split dict-str))) + (let + ((go + (fn + (lst acc) + (if + (= 0 (len lst)) + acc + (if + (= 1 (len lst)) + (error "dict: malformed dict (odd number of elements)") + (go (rest (rest lst)) (append acc (list (list (first lst) (nth lst 1)))))))))) + (go flat (list)))))) + +; Build flat dict string from SX list of [key val] pairs +(define + tcl-dict-from-pairs + (fn + (pairs) + (tcl-list-build + (reduce + (fn (acc pair) (append (append acc (list (first pair))) (list (nth pair 1)))) + (list) + pairs)))) + +; Get value for key from flat dict string; returns nil if missing +(define + tcl-dict-get + (fn + (dict-str key) + (let + ((flat (tcl-list-split dict-str))) + (let + ((go + (fn + (lst) + (if + (< (len lst) 2) + nil + (if + (equal? (first lst) key) + (nth lst 1) + (go (rest (rest lst)))))))) + (go flat))))) + +; Set key=val in flat dict string; returns new flat dict string +(define + tcl-dict-set-pair + (fn + (dict-str key val) + (let + ((pairs (tcl-dict-to-pairs dict-str))) + (let + ((found? (reduce (fn (acc pair) (or acc (equal? (first pair) key))) false pairs))) + (if + found? + (tcl-dict-from-pairs (map (fn (pair) (if (equal? (first pair) key) (list key val) pair)) pairs)) + (tcl-dict-from-pairs (append pairs (list (list key val))))))))) + +; Remove key from flat dict string; returns new flat dict string +(define + tcl-dict-unset-key + (fn + (dict-str key) + (tcl-dict-from-pairs + (filter (fn (pair) (not (equal? (first pair) key))) (tcl-dict-to-pairs dict-str))))) + +; --- dict command --- + +(define + tcl-cmd-dict + (fn + (interp args) + (if + (= 0 (len args)) + (error "dict: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; dict create ?key val …? + ((equal? sub "create") + (if + (= 1 (mod (len rest-args) 2)) + (error "dict create: wrong # args (must be even)") + (assoc interp :result (tcl-list-build rest-args)))) + ; dict get dict key + ((equal? sub "get") + (let + ((dict-str (first rest-args)) (key (nth rest-args 1))) + (let + ((val (tcl-dict-get dict-str key))) + (if + (nil? val) + (error (str "dict get: key \"" key "\" not known in dictionary")) + (assoc interp :result val))))) + ; dict set varname key val + ((equal? sub "set") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (val (nth rest-args 2))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v)))) + (let + ((new-dict (tcl-dict-set-pair cur key val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))) + ; dict unset varname key + ((equal? sub "unset") + (let + ((varname (first rest-args)) (key (nth rest-args 1))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v)))) + (let + ((new-dict (tcl-dict-unset-key cur key))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))) + ; dict exists dict key + ((equal? sub "exists") + (let + ((dict-str (first rest-args)) (key (nth rest-args 1))) + (assoc interp :result (if (nil? (tcl-dict-get dict-str key)) "0" "1")))) + ; dict keys dict ?pattern? + ((equal? sub "keys") + (let + ((dict-str (first rest-args)) + (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil))) + (let + ((all-keys (map first (tcl-dict-to-pairs dict-str)))) + (let + ((filtered + (if + (nil? pattern) + all-keys + (filter (fn (k) (tcl-glob-match (split pattern "") (split k ""))) all-keys)))) + (assoc interp :result (tcl-list-build filtered)))))) + ; dict values dict + ((equal? sub "values") + (let + ((dict-str (first rest-args))) + (assoc interp :result (tcl-list-build (map (fn (pair) (nth pair 1)) (tcl-dict-to-pairs dict-str)))))) + ; dict size dict + ((equal? sub "size") + (let + ((dict-str (first rest-args))) + (assoc interp :result (str (len (tcl-dict-to-pairs dict-str)))))) + ; dict for {kvar vvar} dict body + ((equal? sub "for") + (let + ((var-pair-str (first rest-args)) + (dict-str (nth rest-args 1)) + (body (nth rest-args 2))) + (let + ((var-list (tcl-list-split var-pair-str))) + (let + ((kvar (first var-list)) (vvar (nth var-list 1))) + (let + ((pairs (tcl-dict-to-pairs dict-str))) + (define + dict-for-loop + (fn + (cur-interp ps) + (if + (= 0 (len ps)) + cur-interp + (let + ((pair (first ps))) + (let + ((bound (tcl-var-set (tcl-var-set cur-interp kvar (first pair)) vvar (nth pair 1)))) + (let + ((body-result (tcl-eval-string bound body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else (dict-for-loop (assoc body-result :code 0) (rest ps))))))))))) + (dict-for-loop interp pairs)))))) + ; dict update varname key var … body + ((equal? sub "update") + (let + ((varname (first rest-args))) + (let + ((n (len rest-args))) + (let + ((body (nth rest-args (- n 1))) + (kv-args (slice rest-args 1 (- n 1)))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v)))) + (let + ((bound-interp + (let + ((bind-pairs + (fn + (i-interp remaining) + (if + (< (len remaining) 2) + i-interp + (let + ((k (first remaining)) (var (nth remaining 1))) + (let + ((val (tcl-dict-get cur k))) + (bind-pairs + (tcl-var-set i-interp var (if (nil? val) "" val)) + (rest (rest remaining))))))))) + (bind-pairs interp kv-args)))) + (let + ((body-result (tcl-eval-string bound-interp body))) + (let + ((write-back + (fn + (i-interp remaining new-dict) + (if + (< (len remaining) 2) + (assoc (tcl-var-set i-interp varname new-dict) :result new-dict) + (let + ((k (first remaining)) (var (nth remaining 1))) + (let + ((new-val (frame-lookup (get body-result :frame) var))) + (write-back + i-interp + (rest (rest remaining)) + (if (nil? new-val) (tcl-dict-unset-key new-dict k) (tcl-dict-set-pair new-dict k new-val))))))))) + (write-back body-result kv-args cur))))))))) + ; dict merge ?dict…? + ((equal? sub "merge") + (let + ((merged + (reduce + (fn + (acc dict-str) + (reduce + (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1))) + acc + (tcl-dict-to-pairs dict-str))) + "" + rest-args))) + (assoc interp :result merged))) + ; dict incr varname key ?increment? + ((equal? sub "incr") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (delta (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 1))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v)))) + (let + ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "0" v)))) + (let + ((new-val (str (+ (parse-int old-val) delta)))) + (let + ((new-dict (tcl-dict-set-pair cur key new-val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) + ; dict append varname key ?string…? + ((equal? sub "append") + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (suffix (join "" (slice rest-args 2 (len rest-args))))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v)))) + (let + ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v)))) + (let + ((new-val (str old-val suffix))) + (let + ((new-dict (tcl-dict-set-pair cur key new-val))) + (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) + (else (error (str "dict: unknown subcommand \"" sub "\"")))))))) + (define make-default-tcl-interp (fn @@ -1670,4 +1947,6 @@ ((i (tcl-register i "concat" tcl-cmd-concat))) (let ((i (tcl-register i "split" tcl-cmd-split))) - (tcl-register i "join" tcl-cmd-join))))))))))))))))))))))))))))))))))))) + (let + ((i (tcl-register i "join" tcl-cmd-join))) + (tcl-register i "dict" tcl-cmd-dict)))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx index f6648d56..16261bc3 100644 --- a/lib/tcl/tests/eval.sx +++ b/lib/tcl/tests/eval.sx @@ -261,6 +261,31 @@ (ok "join-sep" (get (run "join {a b c} -") :result) "a-b-c") (ok "join-default" (get (run "join {a b c}") :result) "a b c") (ok "list-var" (get (run "set L {x y z}\nllength $L") :result) "3") + ; --- dict command tests --- + (ok "dict-create" (get (run "dict create a 1 b 2") :result) "a 1 b 2") + (ok "dict-create-empty" (get (run "dict create") :result) "") + (ok "dict-get" (get (run "dict get {a 1 b 2} a") :result) "1") + (ok "dict-get-b" (get (run "dict get {a 1 b 2} b") :result) "2") + (ok "dict-exists-yes" (get (run "dict exists {a 1 b 2} a") :result) "1") + (ok "dict-exists-no" (get (run "dict exists {a 1 b 2} z") :result) "0") + (ok "dict-set-new" (get (run "set d {}\ndict set d x 42") :result) "x 42") + (ok "dict-set-update" (get (run "set d {a 1 b 2}\ndict set d a 99") :result) "a 99 b 2") + (ok "dict-set-stored" (tcl-var-get (run "set d {a 1}\ndict set d b 2") "d") "a 1 b 2") + (ok "dict-unset" (get (run "set d {a 1 b 2}\ndict unset d a") :result) "b 2") + (ok "dict-unset-stored" (tcl-var-get (run "set d {a 1 b 2}\ndict unset d a") "d") "b 2") + (ok "dict-keys" (get (run "dict keys {a 1 b 2}") :result) "a b") + (ok "dict-keys-pattern" (get (run "dict keys {abc 1 abd 2 xyz 3} ab*") :result) "abc abd") + (ok "dict-values" (get (run "dict values {a 1 b 2}") :result) "1 2") + (ok "dict-size" (get (run "dict size {a 1 b 2 c 3}") :result) "3") + (ok "dict-size-empty" (get (run "dict size {}") :result) "0") + (ok "dict-for" (tcl-var-get (run "set acc {}\ndict for {k v} {a 1 b 2} {append acc $k$v}") "acc") "a1b2") + (ok "dict-merge-disjoint" (get (run "dict merge {a 1} {b 2}") :result) "a 1 b 2") + (ok "dict-merge-overlap" (get (run "dict merge {a 1 b 2} {b 99}") :result) "a 1 b 99") + (ok "dict-incr-existing" (get (run "set d {x 5}\ndict incr d x") :result) "x 6") + (ok "dict-incr-delta" (get (run "set d {x 5}\ndict incr d x 3") :result) "x 8") + (ok "dict-incr-missing" (get (run "set d {}\ndict incr d n") :result) "n 1") + (ok "dict-append" (get (run "set d {x hello}\ndict append d x _hi") :result) "x hello_hi") + (ok "dict-append-new" (get (run "set d {}\ndict append d k val") :result) "k val") (dict "passed" tcl-eval-pass