rose-ash/lib/guest/reflective/env.sx

;; lib/guest/reflective/env.sx — first-class environment kit.
;;
;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's
;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a
;; second consumer needing the same scope-chain semantics.
;;
;; Canonical wire shape
;; --------------------
;;   {:refl-tag :env :bindings DICT :parent ENV-OR-NIL}
;;
;;   - :bindings is a mutable SX dict keyed by symbol name.
;;   - :parent is either another env or nil (root).
;;   - Lookup walks the parent chain until a hit or nil.
;;   - Default cfg uses dict-set! to mutate bindings in place.
;;
;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent})
;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg
;; for unification over guest-specific term shapes.
;;
;; Adapter cfg keys
;; ----------------
;;   :bindings-of  — fn (scope) → DICT
;;   :parent-of    — fn (scope) → SCOPE-OR-NIL
;;   :extend       — fn (scope) → SCOPE         (push a fresh child)
;;   :bind!        — fn (scope name val) → scope (functional or mutable)
;;   :env?         — fn (v) → bool              (predicate; cheap shape check)
;;
;; Public API — canonical shape, mutable, raises on miss
;;
;;   (refl-make-env)
;;   (refl-extend-env PARENT)
;;   (refl-env? V)
;;   (refl-env-bind! ENV NAME VAL)
;;   (refl-env-has? ENV NAME)
;;   (refl-env-lookup ENV NAME)
;;   (refl-env-lookup-or-nil ENV NAME)
;;
;; Public API — adapter-cfg, any shape
;;
;;   (refl-env-extend-with CFG SCOPE)
;;   (refl-env-bind!-with  CFG SCOPE NAME VAL)
;;   (refl-env-has?-with   CFG SCOPE NAME)
;;   (refl-env-lookup-with CFG SCOPE NAME)
;;   (refl-env-lookup-or-nil-with CFG SCOPE NAME)
;;   (refl-env-find-frame-with CFG SCOPE NAME)
;;     — returns the scope in the chain that contains NAME (or nil).
;;       Consumers needing source-frame mutation use this.
;;
;;   (refl-canonical-cfg) — the default cfg, exposed so consumers
;;                          can compare or extend it.

;; ── Canonical-shape predicates and constructors ─────────────────

(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env))))

(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}}))

(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}}))

(define
  refl-env-bind!
  (fn (env name val) (dict-set! (get env :bindings) name val) env))

(define
  refl-env-has?
  (fn
    (env name)
    (cond
      ((nil? env) false)
      ((not (refl-env? env)) false)
      ((dict-has? (get env :bindings) name) true)
      (:else (refl-env-has? (get env :parent) name)))))

(define
  refl-env-lookup
  (fn
    (env name)
    (cond
      ((nil? env) (error (str "refl-env-lookup: unbound symbol: " name)))
      ((not (refl-env? env))
        (error (str "refl-env-lookup: corrupt env: " env)))
      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
      (:else (refl-env-lookup (get env :parent) name)))))

(define
  refl-env-lookup-or-nil
  (fn
    (env name)
    (cond
      ((nil? env) nil)
      ((not (refl-env? env)) nil)
      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
      (:else (refl-env-lookup-or-nil (get env :parent) name)))))

;; ── Adapter-cfg variants — any wire shape ───────────────────────

(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope)))

(define
  refl-env-bind!-with
  (fn (cfg scope name val) ((get cfg :bind!) scope name val)))

(define
  refl-env-has?-with
  (fn
    (cfg scope name)
    (cond
      ((nil? scope) false)
      ((not ((get cfg :env?) scope)) false)
      ((dict-has? ((get cfg :bindings-of) scope) name) true)
      (:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name)))))

(define
  refl-env-lookup-with
  (fn
    (cfg scope name)
    (cond
      ((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name)))
      ((not ((get cfg :env?) scope))
        (error (str "refl-env-lookup: corrupt scope: " scope)))
      ((dict-has? ((get cfg :bindings-of) scope) name)
        (get ((get cfg :bindings-of) scope) name))
      (:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name)))))

(define
  refl-env-lookup-or-nil-with
  (fn
    (cfg scope name)
    (cond
      ((nil? scope) nil)
      ((not ((get cfg :env?) scope)) nil)
      ((dict-has? ((get cfg :bindings-of) scope) name)
        (get ((get cfg :bindings-of) scope) name))
      (:else
        (refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name)))))

;; Returns the SCOPE in the chain that contains NAME, or nil if no
;; scope binds it. Consumers (e.g. Smalltalk) use this to mutate the
;; binding at its source frame rather than introducing a new shadow
;; binding at the current frame. Pairs with `refl-env-lookup-with`
;; for callers that need both the value and the defining scope.

(define refl-env-find-frame-with
  (fn (cfg scope name)
    (cond
      ((nil? scope) nil)
      ((not ((get cfg :env?) scope)) nil)
      ((dict-has? ((get cfg :bindings-of) scope) name) scope)
      (:else
        (refl-env-find-frame-with cfg ((get cfg :parent-of) scope) name)))))

(define refl-env-find-frame
  (fn (env name) (refl-env-find-frame-with refl-canonical-cfg env name)))

;; ── Default canonical cfg ───────────────────────────────────────
;; Exposed so consumers can use it explicitly, compose with it, or
;; check adapter-correctness against the canonical implementation.

(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))})