coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Decouple core evaluator from web platform, extract libraries

Browse Source 
The core evaluator (spec/evaluator.sx) is now the irreducible computational
core with zero web, rendering, or type-system knowledge. 2531 → 2313 lines.

- Add extensible special form registry (*custom-special-forms* + register-special-form!)
- Add render dispatch hooks (*render-check* / *render-fn*) replacing hardcoded render-active?/is-render-expr?/render-expr
- Extract freeze scopes → spec/freeze.sx (library, not core)
- Extract content addressing → spec/content.sx (library, not core)
- Move sf-deftype/sf-defeffect → spec/types.sx (self-registering)
- Move sf-defstyle → web/forms.sx (self-registering with all web forms)
- Move web tests (defpage, streaming) → web/tests/test-forms.sx
- Add is-else-clause? helper (replaces 5 inline patterns)
- Make escape-html/escape-attr library functions in render.sx (pure SX, not platform-provided)
- Add foundations plan: Step 3.5 (data representations), Step 3.7 (verified components), OCaml for Step 4d
- Update all three bootstrappers (JS 957/957, Python 744/744, OCaml 952/952)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-16 08:37:50 +00:00
parent 5ab3ecb7e0
commit 06666ac8c4
21 changed files with 886 additions and 603 deletions
Download Patch File Download Diff File Expand all files Collapse all files

312
spec/evaluator.sx
View File

@@ -306,6 +306,26 @@
(scan kont (list))))
;; --------------------------------------------------------------------------
;; Extension points — custom special forms and render dispatch
;; --------------------------------------------------------------------------
;;
;; Extensions (web forms, type system, etc.) register handlers here.
;; The evaluator calls these from step-eval-list after core forms.
(define *custom-special-forms* (dict))
(define register-special-form!
(fn ((name :as string) handler)
(dict-set! *custom-special-forms* name handler)))
;; Render dispatch — installed by web adapters, nil when no renderer active.
;; *render-check*: (expr env) → boolean — should this expression be rendered?
;; *render-fn*: (expr env) → value — render and return result
(define *render-check* nil)
(define *render-fn* nil)
;; **************************************************************************
;; Part 2: Evaluation Utilities
;; **************************************************************************
@@ -545,6 +565,14 @@
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
clauses)))
;; is-else-clause? — check if a cond/case test is an else marker
(define is-else-clause?
(fn (test)
(or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(and (= (type-of test) "symbol")
(or (= (symbol-name test) "else")
(= (symbol-name test) ":else"))))))
;; Named let: (let name ((x 0) (y 1)) body...)
;; Desugars to a self-recursive lambda called with initial values.
@@ -755,91 +783,6 @@
(list params rest-param))))
(define sf-defstyle
(fn ((args :as list) (env :as dict))
;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.)
(let ((name-sym (first args))
(value (trampoline (eval-expr (nth args 1) env))))
(env-bind! env (symbol-name name-sym) value)
value)))
;; -- deftype helpers (must be in eval.sx, not types.sx, because
;; sf-deftype is always compiled but types.sx is a spec module) --
(define make-type-def
(fn ((name :as string) (params :as list) body)
{:name name :params params :body body}))
(define normalize-type-body
(fn (body)
;; Convert AST type expressions to type representation.
;; Symbols → strings, (union ...) → (or ...), dict keys → strings.
(cond
(nil? body) "nil"
(= (type-of body) "symbol")
(symbol-name body)
(= (type-of body) "string")
body
(= (type-of body) "keyword")
(keyword-name body)
(= (type-of body) "dict")
;; Record type — normalize values
(map-dict (fn (k v) (normalize-type-body v)) body)
(= (type-of body) "list")
(if (empty? body) "any"
(let ((head (first body)))
(let ((head-name (if (= (type-of head) "symbol")
(symbol-name head) (str head))))
;; (union a b) → (or a b)
(if (= head-name "union")
(cons "or" (map normalize-type-body (rest body)))
;; (or a b), (list-of t), (-> ...) etc.
(cons head-name (map normalize-type-body (rest body)))))))
:else (str body))))
(define sf-deftype
(fn ((args :as list) (env :as dict))
;; (deftype name body) or (deftype (name a b ...) body)
(let ((name-or-form (first args))
(body-expr (nth args 1))
(type-name nil)
(type-params (list)))
;; Parse name — symbol or (symbol params...)
(if (= (type-of name-or-form) "symbol")
(set! type-name (symbol-name name-or-form))
(when (= (type-of name-or-form) "list")
(set! type-name (symbol-name (first name-or-form)))
(set! type-params
(map (fn (p) (if (= (type-of p) "symbol")
(symbol-name p) (str p)))
(rest name-or-form)))))
;; Normalize and store in *type-registry*
(let ((body (normalize-type-body body-expr))
(registry (if (env-has? env "*type-registry*")
(env-get env "*type-registry*")
(dict))))
(dict-set! registry type-name
(make-type-def type-name type-params body))
(env-bind! env "*type-registry*" registry)
nil))))
(define sf-defeffect
(fn ((args :as list) (env :as dict))
;; (defeffect name) — register an effect name
(let ((effect-name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
(str (first args))))
(registry (if (env-has? env "*effect-registry*")
(env-get env "*effect-registry*")
(list))))
(when (not (contains? registry effect-name))
(append! registry effect-name))
(env-bind! env "*effect-registry*" registry)
nil)))
(define qq-expand
(fn (template (env :as dict))
(if (not (= (type-of template) "list"))
@@ -1126,10 +1069,11 @@
;; (pop-wind!) → void (pop wind record from stack)
;; (call-thunk f env) → value (call a zero-arg function)
;;
;; Render-time accumulators:
;; (collect! bucket value) → void (add to named bucket, deduplicated)
;; (collected bucket) → list (all values in bucket)
;; (clear-collected! bucket) → void (empty the bucket)
;; Extension hooks (set by web adapters, type system, etc.):
;; *custom-special-forms* — dict of name → handler fn
;; register-special-form! — (name handler) → registers custom form
;; *render-check* — nil or (expr env) → boolean
;; *render-fn* — nil or (expr env) → value
;; --------------------------------------------------------------------------
@@ -1262,13 +1206,6 @@
(= name "defcomp") (make-cek-value (sf-defcomp args env) env kont)
(= name "defisland") (make-cek-value (sf-defisland args env) env kont)
(= name "defmacro") (make-cek-value (sf-defmacro args env) env kont)
(= name "defstyle") (make-cek-value (sf-defstyle args env) env kont)
(= name "defhandler") (make-cek-value (sf-defhandler args env) env kont)
(= name "defpage") (make-cek-value (sf-defpage args env) env kont)
(= name "defquery") (make-cek-value (sf-defquery args env) env kont)
(= name "defaction") (make-cek-value (sf-defaction args env) env kont)
(= name "deftype") (make-cek-value (sf-deftype args env) env kont)
(= name "defeffect") (make-cek-value (sf-defeffect args env) env kont)
(= name "begin") (step-sf-begin args env kont)
(= name "do") (step-sf-begin args env kont)
(= name "quote") (make-cek-value (if (empty? args) nil (first args)) env kont)
@@ -1303,14 +1240,20 @@
(= name "every?") (step-ho-every args env kont)
(= name "for-each") (step-ho-for-each args env kont)
;; Custom special forms (registered by extensions)
(has-key? *custom-special-forms* name)
(make-cek-value
((get *custom-special-forms* name) args env)
env kont)
;; Macro expansion
(and (env-has? env name) (macro? (env-get env name)))
(let ((mac (env-get env name)))
(make-cek-state (expand-macro mac args env) env kont))
;; Render expression
(and (render-active?) (is-render-expr? expr))
(make-cek-value (render-expr expr env) env kont)
;; Render dispatch (installed by web adapters)
(and *render-check* (*render-check* expr env))
(make-cek-value (*render-fn* expr env) env kont)
;; Fall through to function call
:else (step-eval-call head args env kont)))
@@ -1451,11 +1394,7 @@
(let ((clause (first args))
(test (first clause)))
;; Check for :else / else
(if (or (and (= (type-of test) "symbol")
(or (= (symbol-name test) "else")
(= (symbol-name test) ":else")))
(and (= (type-of test) "keyword")
(= (keyword-name test) "else")))
(if (is-else-clause? test)
(make-cek-state (nth clause 1) env kont)
(make-cek-state
test env
@@ -1464,10 +1403,7 @@
(if (< (len args) 2)
(make-cek-value nil env kont)
(let ((test (first args)))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(and (= (type-of test) "symbol")
(or (= (symbol-name test) "else")
(= (symbol-name test) ":else"))))
(if (is-else-clause? test)
(make-cek-state (nth args 1) env kont)
(make-cek-state
test env
@@ -1950,11 +1886,7 @@
(make-cek-value nil fenv rest-k)
(let ((next-clause (first next-clauses))
(next-test (first next-clause)))
(if (or (and (= (type-of next-test) "symbol")
(or (= (symbol-name next-test) "else")
(= (symbol-name next-test) ":else")))
(and (= (type-of next-test) "keyword")
(= (keyword-name next-test) "else")))
(if (is-else-clause? next-test)
(make-cek-state (nth next-clause 1) fenv rest-k)
(make-cek-state
next-test fenv
@@ -1966,10 +1898,7 @@
(if (< (len next) 2)
(make-cek-value nil fenv rest-k)
(let ((next-test (first next)))
(if (or (and (= (type-of next-test) "keyword") (= (keyword-name next-test) "else"))
(and (= (type-of next-test) "symbol")
(or (= (symbol-name next-test) "else")
(= (symbol-name next-test) ":else"))))
(if (is-else-clause? next-test)
(make-cek-state (nth next 1) fenv rest-k)
(make-cek-state
next-test fenv
@@ -2336,10 +2265,7 @@
(make-cek-value nil env kont)
(let ((test (first clauses))
(body (nth clauses 1)))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(and (= (type-of test) "symbol")
(or (= (symbol-name test) "else")
(= (symbol-name test) ":else"))))
(if (is-else-clause? test)
(make-cek-state body env kont)
;; Evaluate test expression
(let ((test-val (trampoline (eval-expr test env))))
@@ -2368,150 +2294,6 @@
val)))
;; --------------------------------------------------------------------------
;; 13. Freeze scopes — named serializable state boundaries
;; --------------------------------------------------------------------------
;;
;; A freeze scope collects signals registered within it. On freeze,
;; their current values are serialized to SX. On thaw, values are
;; restored. Multiple named scopes can coexist independently.
;;
;; Uses the scoped effects system: scope-push!/scope-pop!/context.
;;
;; Usage:
;; (freeze-scope "editor"
;; (let ((doc (signal "hello")))
;; (freeze-signal "doc" doc)
;; ...))
;;
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
;; Registry of freeze scopes: name → list of {name signal} entries
(define freeze-registry (dict))
;; Register a signal in the current freeze scope
(define freeze-signal :effects [mutation]
(fn (name sig)
(let ((scope-name (context "sx-freeze-scope" nil)))
(when scope-name
(let ((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
;; Freeze scope delimiter — collects signals registered within body
(define freeze-scope :effects [mutation]
(fn (name body-fn)
(scope-push! "sx-freeze-scope" name)
;; Initialize empty entry list for this scope
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
;; Freeze a named scope → SX dict of signal values
(define cek-freeze-scope :effects []
(fn (name)
(let ((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each (fn (entry)
(dict-set! signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
;; Freeze all scopes
(define cek-freeze-all :effects []
(fn ()
(map (fn (name) (cek-freeze-scope name))
(keys freeze-registry))))
;; Thaw a named scope — restore signal values from frozen data
(define cek-thaw-scope :effects [mutation]
(fn (name frozen)
(let ((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when values
(for-each (fn (entry)
(let ((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val))
(reset! sig val))))
entries)))))
;; Thaw all scopes from a list of frozen scope dicts
(define cek-thaw-all :effects [mutation]
(fn (frozen-list)
(for-each (fn (frozen)
(cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
;; Serialize a frozen scope to SX text
(define freeze-to-sx :effects []
(fn (name)
(sx-serialize (cek-freeze-scope name))))
;; Restore from SX text
(define thaw-from-sx :effects [mutation]
(fn (sx-text)
(let ((parsed (sx-parse sx-text)))
(when (not (empty? parsed))
(let ((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen))))))
;; --------------------------------------------------------------------------
;; 14. Content-addressed computation
;; --------------------------------------------------------------------------
;;
;; Hash frozen SX to a content identifier. Store and retrieve by CID.
;; The content IS the address — same SX always produces the same CID.
;;
;; Uses an in-memory content store. Applications can persist to
;; localStorage or IPFS by providing their own store backend.
(define content-store (dict))
(define content-hash :effects []
(fn (sx-text)
;; djb2 hash → hex string. Simple, deterministic, fast.
;; Real deployment would use SHA-256 / multihash.
(let ((hash 5381))
(for-each (fn (i)
(set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296)))
(range 0 (len sx-text)))
(to-hex hash))))
(define content-put :effects [mutation]
(fn (sx-text)
(let ((cid (content-hash sx-text)))
(dict-set! content-store cid sx-text)
cid)))
(define content-get :effects []
(fn (cid)
(get content-store cid)))
;; Freeze a scope → store → return CID
(define freeze-to-cid :effects [mutation]
(fn (scope-name)
(let ((sx-text (freeze-to-sx scope-name)))
(content-put sx-text))))
;; Thaw from CID → look up → restore
(define thaw-from-cid :effects [mutation]
(fn (cid)
(let ((sx-text (content-get cid)))
(when sx-text
(thaw-from-sx sx-text)
true))))
;; **************************************************************************
;; eval-expr / trampoline — canonical definitions (after cek-run is defined)
;; **************************************************************************