giles
d06de87bca
Fix: islands (defisland) pass component? check but must NEVER be expanded server-side — they use browser-only reactive primitives (signal, deref, computed). Added (not (island? comp)) guard in adapter-sx.sx aser component dispatch. New test file: shared/sx/tests/test_ocaml_helpers.py - TestHelperInjection: 5 tests — helper IO proxy, 2-arg calls, aser/aser_slot with helpers, undefined helper error - TestHelperIOPerformance: 2 tests — 20 sequential IO round-trips complete in <5s, aser_slot with 5 helpers in <3s - TestAserSlotClientAffinity: 6 tests — island exclusion, client affinity exclusion, server affinity expansion, auto affinity behavior in aser vs aser_slot eval_sx_url stays on bridge.aser() (server-affinity only) for now. Switching to aser_slot requires fixing the double-aser issue in _render_to_sx where content gets re-parsed and re-asered. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
518 lines
20 KiB
Plaintext
518 lines
20 KiB
Plaintext
;; ==========================================================================
|
|
;; adapter-sx.sx — SX wire format rendering adapter
|
|
;;
|
|
;; Serializes SX expressions for client-side rendering.
|
|
;; Component calls are NOT expanded — they're sent to the client as-is.
|
|
;; HTML tags are serialized as SX source text. Special forms are evaluated.
|
|
;;
|
|
;; Depends on:
|
|
;; render.sx — HTML_TAGS
|
|
;; eval.sx — eval-expr, trampoline, call-lambda, expand-macro
|
|
;; ==========================================================================
|
|
|
|
|
|
(define render-to-sx :effects [render]
|
|
(fn (expr (env :as dict))
|
|
(let ((result (aser expr env)))
|
|
;; aser-call already returns serialized SX strings;
|
|
;; only serialize non-string values
|
|
(if (= (type-of result) "string")
|
|
result
|
|
(serialize result)))))
|
|
|
|
(define aser :effects [render]
|
|
(fn ((expr :as any) (env :as dict))
|
|
;; Evaluate for SX wire format — serialize rendering forms,
|
|
;; evaluate control flow and function calls.
|
|
(set-render-active! true)
|
|
(let ((result
|
|
(case (type-of expr)
|
|
"number" expr
|
|
"string" expr
|
|
"boolean" expr
|
|
"nil" nil
|
|
|
|
"symbol"
|
|
(let ((name (symbol-name expr)))
|
|
(cond
|
|
(env-has? env name) (env-get env name)
|
|
(primitive? name) (get-primitive name)
|
|
(= name "true") true
|
|
(= name "false") false
|
|
(= name "nil") nil
|
|
:else (error (str "Undefined symbol: " name))))
|
|
|
|
"keyword" (keyword-name expr)
|
|
|
|
"list"
|
|
(if (empty? expr)
|
|
(list)
|
|
(aser-list expr env))
|
|
|
|
;; Spread — emit attrs to nearest element provider
|
|
"spread" (do (scope-emit! "element-attrs" (spread-attrs expr)) nil)
|
|
|
|
:else expr)))
|
|
;; Catch spread values from function calls and symbol lookups
|
|
(if (spread? result)
|
|
(do (scope-emit! "element-attrs" (spread-attrs result)) nil)
|
|
result))))
|
|
|
|
|
|
(define aser-list :effects [render]
|
|
(fn ((expr :as list) (env :as dict))
|
|
(let ((head (first expr))
|
|
(args (rest expr)))
|
|
(if (not (= (type-of head) "symbol"))
|
|
(map (fn (x) (aser x env)) expr)
|
|
(let ((name (symbol-name head)))
|
|
(cond
|
|
;; Fragment — serialize children
|
|
(= name "<>")
|
|
(aser-fragment args env)
|
|
|
|
;; raw! — pass through as serialized call
|
|
(= name "raw!")
|
|
(aser-call "raw!" args env)
|
|
|
|
;; Component call — expand if server-affinity or expand-components? is set.
|
|
;; expand-components? is a platform primitive (like eval-expr, trampoline);
|
|
;; adapter-async.sx uses the same pattern at line 684.
|
|
;; Guard with env-has? for backward compat with older kernels.
|
|
(starts-with? name "~")
|
|
(let ((comp (if (env-has? env name) (env-get env name) nil))
|
|
(expand-all (if (env-has? env "expand-components?")
|
|
(expand-components?) false)))
|
|
(cond
|
|
(and comp (macro? comp))
|
|
(aser (expand-macro comp args env) env)
|
|
(and comp (component? comp)
|
|
(not (island? comp))
|
|
(or expand-all
|
|
(= (component-affinity comp) "server"))
|
|
;; :affinity :client components are never expanded
|
|
;; server-side — they depend on browser-only state.
|
|
(not (= (component-affinity comp) "client")))
|
|
(aser-expand-component comp args env)
|
|
:else
|
|
(aser-call name args env)))
|
|
|
|
;; Lake — serialize (server-morphable slot)
|
|
(= name "lake")
|
|
(aser-call name args env)
|
|
|
|
;; Marsh — serialize (reactive server-morphable slot)
|
|
(= name "marsh")
|
|
(aser-call name args env)
|
|
|
|
;; HTML tag — serialize
|
|
(contains? HTML_TAGS name)
|
|
(aser-call name args env)
|
|
|
|
;; Special/HO forms — evaluate (produces data)
|
|
(or (special-form? name) (ho-form? name))
|
|
(aser-special name expr env)
|
|
|
|
;; Macro — expand then aser
|
|
(and (env-has? env name) (macro? (env-get env name)))
|
|
(aser (expand-macro (env-get env name) args env) env)
|
|
|
|
;; Function call — evaluate fully
|
|
:else
|
|
(let ((f (trampoline (eval-expr head env)))
|
|
(evaled-args (map (fn (a) (trampoline (eval-expr a env))) args)))
|
|
(cond
|
|
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
|
|
(apply f evaled-args)
|
|
(lambda? f)
|
|
(trampoline (call-lambda f evaled-args env))
|
|
(component? f)
|
|
(aser-call (str "~" (component-name f)) args env)
|
|
(island? f)
|
|
(aser-call (str "~" (component-name f)) args env)
|
|
:else (error (str "Not callable: " (inspect f)))))))))))
|
|
|
|
|
|
(define aser-fragment :effects [render]
|
|
(fn ((children :as list) (env :as dict))
|
|
;; Serialize (<> child1 child2 ...) to sx source string
|
|
;; Must flatten list results (e.g. from map/filter) to avoid nested parens
|
|
(let ((parts (list)))
|
|
(for-each
|
|
(fn (c)
|
|
(let ((result (aser c env)))
|
|
(cond
|
|
(nil? result) nil
|
|
;; Serialized SX from aser (tags, components, fragments)
|
|
;; starts with "(" — use directly without re-quoting
|
|
(and (= (type-of result) "string")
|
|
(> (string-length result) 0)
|
|
(starts-with? result "("))
|
|
(append! parts result)
|
|
;; list results (from map etc.)
|
|
(= (type-of result) "list")
|
|
(for-each
|
|
(fn (item)
|
|
(when (not (nil? item))
|
|
(if (and (= (type-of item) "string")
|
|
(> (string-length item) 0)
|
|
(starts-with? item "("))
|
|
(append! parts item)
|
|
(append! parts (serialize item)))))
|
|
result)
|
|
;; Everything else — serialize normally (quotes strings)
|
|
:else
|
|
(append! parts (serialize result)))))
|
|
children)
|
|
(if (empty? parts)
|
|
""
|
|
(if (= (len parts) 1)
|
|
(first parts)
|
|
(str "(<> " (join " " parts) ")"))))))
|
|
|
|
|
|
(define aser-call :effects [render]
|
|
(fn ((name :as string) (args :as list) (env :as dict))
|
|
;; Serialize (name :key val child ...) — evaluate args but keep as sx
|
|
;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops
|
|
;; that can contain nested for-each for list flattening.
|
|
;; Separate attrs and children so emitted spread attrs go before children.
|
|
(let ((attr-parts (list))
|
|
(child-parts (list))
|
|
(skip false)
|
|
(i 0))
|
|
;; Provide scope for spread emit!
|
|
(scope-push! "element-attrs" nil)
|
|
(for-each
|
|
(fn (arg)
|
|
(if skip
|
|
(do (set! skip false)
|
|
(set! i (inc i)))
|
|
(if (and (= (type-of arg) "keyword")
|
|
(< (inc i) (len args)))
|
|
(let ((val (aser (nth args (inc i)) env)))
|
|
(when (not (nil? val))
|
|
(append! attr-parts (str ":" (keyword-name arg)))
|
|
;; If the aser result is already serialized SX (starts
|
|
;; with "("), inline it directly — don't re-serialize
|
|
;; which would quote it as a string literal.
|
|
(if (and (= (type-of val) "string")
|
|
(> (string-length val) 0)
|
|
(starts-with? val "("))
|
|
(append! attr-parts val)
|
|
(append! attr-parts (serialize val))))
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
(let ((val (aser arg env)))
|
|
(when (not (nil? val))
|
|
(cond
|
|
;; Serialized SX (tags, components) — use directly
|
|
(and (= (type-of val) "string")
|
|
(> (string-length val) 0)
|
|
(starts-with? val "("))
|
|
(append! child-parts val)
|
|
;; List results (from map etc.)
|
|
(= (type-of val) "list")
|
|
(for-each
|
|
(fn (item)
|
|
(when (not (nil? item))
|
|
(if (and (= (type-of item) "string")
|
|
(> (string-length item) 0)
|
|
(starts-with? item "("))
|
|
(append! child-parts item)
|
|
(append! child-parts (serialize item)))))
|
|
val)
|
|
;; Plain values — serialize normally
|
|
:else
|
|
(append! child-parts (serialize val))))
|
|
(set! i (inc i))))))
|
|
args)
|
|
;; Collect emitted spread attrs — goes after explicit attrs, before children
|
|
(for-each
|
|
(fn (spread-dict)
|
|
(for-each
|
|
(fn (k)
|
|
(let ((v (dict-get spread-dict k)))
|
|
(append! attr-parts (str ":" k))
|
|
(append! attr-parts (serialize v))))
|
|
(keys spread-dict)))
|
|
(scope-peek "element-attrs"))
|
|
(scope-pop! "element-attrs")
|
|
(let ((parts (concat (list name) attr-parts child-parts)))
|
|
(str "(" (join " " parts) ")")))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Server-affinity component expansion
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; When a component has :affinity :server, the aser expands it inline:
|
|
;; bind keyword args + children, then aser the body.
|
|
;; This is the aser equivalent of render-to-html's component expansion.
|
|
|
|
(define aser-expand-component :effects [render]
|
|
(fn ((comp :as any) (args :as list) (env :as dict))
|
|
(let ((params (component-params comp))
|
|
(local (env-merge env (component-closure comp)))
|
|
(i 0)
|
|
(skip false)
|
|
(children (list)))
|
|
;; Default all keyword params to nil (same as the CEK evaluator)
|
|
(for-each (fn (p) (env-bind! local p nil)) params)
|
|
;; Parse keyword args and positional children from args.
|
|
;; Keyword values are ASERED (not eval'd) — they may contain
|
|
;; rendering constructs (<>, HTML tags) that eval-expr can't
|
|
;; handle. The aser result is a string/value that the body's
|
|
;; aser will inline correctly (strings starting with "(" are
|
|
;; recognized as serialized SX by aserCall).
|
|
(for-each
|
|
(fn (arg)
|
|
(if skip
|
|
(do (set! skip false) (set! i (inc i)))
|
|
(if (and (= (type-of arg) "keyword")
|
|
(< (inc i) (len args)))
|
|
;; Keyword arg: bind name = aser'd next arg
|
|
(do
|
|
(env-bind! local (keyword-name arg)
|
|
(aser (nth args (inc i)) env))
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
;; Positional child: keep as unevaluated AST for aser
|
|
(do
|
|
(append! children arg)
|
|
(set! i (inc i))))))
|
|
args)
|
|
;; Bind &rest children — aser each child first, then bind the result
|
|
(when (component-has-children comp)
|
|
(let ((asered-children
|
|
(map (fn (c) (aser c env)) children)))
|
|
(env-bind! local "children"
|
|
(if (= (len asered-children) 1)
|
|
(first asered-children)
|
|
asered-children))))
|
|
;; Aser the body in the merged env
|
|
(aser (component-body comp) local))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Form classification
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define SPECIAL_FORM_NAMES
|
|
(list "if" "when" "cond" "case" "and" "or"
|
|
"let" "let*" "lambda" "fn"
|
|
"define" "defcomp" "defmacro" "defstyle"
|
|
"defhandler" "defpage" "defquery" "defaction" "defrelation"
|
|
"begin" "do" "quote" "quasiquote"
|
|
"->" "set!" "letrec" "dynamic-wind" "defisland"
|
|
"deftype" "defeffect" "scope" "provide"))
|
|
|
|
(define HO_FORM_NAMES
|
|
(list "map" "map-indexed" "filter" "reduce"
|
|
"some" "every?" "for-each"))
|
|
|
|
(define special-form? :effects []
|
|
(fn ((name :as string))
|
|
(contains? SPECIAL_FORM_NAMES name)))
|
|
|
|
(define ho-form? :effects []
|
|
(fn ((name :as string))
|
|
(contains? HO_FORM_NAMES name)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; aser-special — evaluate special/HO forms in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Control flow forms evaluate conditions normally but render branches
|
|
;; through aser (serializing tags/components instead of rendering HTML).
|
|
;; Definition forms evaluate for side effects and return nil.
|
|
|
|
(define aser-special :effects [render]
|
|
(fn ((name :as string) (expr :as list) (env :as dict))
|
|
(let ((args (rest expr)))
|
|
(cond
|
|
;; if — evaluate condition, aser chosen branch
|
|
(= name "if")
|
|
(if (trampoline (eval-expr (first args) env))
|
|
(aser (nth args 1) env)
|
|
(if (> (len args) 2)
|
|
(aser (nth args 2) env)
|
|
nil))
|
|
|
|
;; when — evaluate condition, aser body if true
|
|
(= name "when")
|
|
(if (not (trampoline (eval-expr (first args) env)))
|
|
nil
|
|
(let ((result nil))
|
|
(for-each (fn (body) (set! result (aser body env)))
|
|
(rest args))
|
|
result))
|
|
|
|
;; cond — evaluate conditions, aser matching branch
|
|
(= name "cond")
|
|
(let ((branch (eval-cond args env)))
|
|
(if branch (aser branch env) nil))
|
|
|
|
;; case — evaluate match value, check each pair
|
|
(= name "case")
|
|
(let ((match-val (trampoline (eval-expr (first args) env)))
|
|
(clauses (rest args)))
|
|
(eval-case-aser match-val clauses env))
|
|
|
|
;; let / let*
|
|
(or (= name "let") (= name "let*"))
|
|
(let ((local (process-bindings (first args) env))
|
|
(result nil))
|
|
(for-each (fn (body) (set! result (aser body local)))
|
|
(rest args))
|
|
result)
|
|
|
|
;; begin / do
|
|
(or (= name "begin") (= name "do"))
|
|
(let ((result nil))
|
|
(for-each (fn (body) (set! result (aser body env))) args)
|
|
result)
|
|
|
|
;; and — short-circuit
|
|
(= name "and")
|
|
(let ((result true))
|
|
(some (fn (arg)
|
|
(set! result (trampoline (eval-expr arg env)))
|
|
(not result))
|
|
args)
|
|
result)
|
|
|
|
;; or — short-circuit
|
|
(= name "or")
|
|
(let ((result false))
|
|
(some (fn (arg)
|
|
(set! result (trampoline (eval-expr arg env)))
|
|
result)
|
|
args)
|
|
result)
|
|
|
|
;; map — evaluate function and collection, map through aser
|
|
(= name "map")
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(map (fn (item)
|
|
(if (lambda? f)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(env-bind! local (first (lambda-params f)) item)
|
|
(aser (lambda-body f) local))
|
|
(cek-call f (list item))))
|
|
coll))
|
|
|
|
;; map-indexed
|
|
(= name "map-indexed")
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
(map-indexed (fn (i item)
|
|
(if (lambda? f)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(env-bind! local (first (lambda-params f)) i)
|
|
(env-bind! local (nth (lambda-params f) 1) item)
|
|
(aser (lambda-body f) local))
|
|
(cek-call f (list i item))))
|
|
coll))
|
|
|
|
;; for-each — evaluate for side effects, aser each body
|
|
(= name "for-each")
|
|
(let ((f (trampoline (eval-expr (first args) env)))
|
|
(coll (trampoline (eval-expr (nth args 1) env)))
|
|
(results (list)))
|
|
(for-each (fn (item)
|
|
(if (lambda? f)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(env-bind! local (first (lambda-params f)) item)
|
|
(append! results (aser (lambda-body f) local)))
|
|
(cek-call f (list item))))
|
|
coll)
|
|
(if (empty? results) nil results))
|
|
|
|
;; defisland — evaluate AND serialize (client needs the definition)
|
|
(= name "defisland")
|
|
(do (trampoline (eval-expr expr env))
|
|
(serialize expr))
|
|
|
|
;; Definition forms — evaluate for side effects
|
|
(or (= name "define") (= name "defcomp") (= name "defmacro")
|
|
(= name "defstyle") (= name "defhandler") (= name "defpage")
|
|
(= name "defquery") (= name "defaction") (= name "defrelation")
|
|
(= name "deftype") (= name "defeffect"))
|
|
(do (trampoline (eval-expr expr env)) nil)
|
|
|
|
;; scope — unified render-time dynamic scope
|
|
(= name "scope")
|
|
(let ((scope-name (trampoline (eval-expr (first args) env)))
|
|
(rest-args (rest args))
|
|
(scope-val nil)
|
|
(body-args nil))
|
|
;; Check for :value keyword
|
|
(if (and (>= (len rest-args) 2)
|
|
(= (type-of (first rest-args)) "keyword")
|
|
(= (keyword-name (first rest-args)) "value"))
|
|
(do (set! scope-val (trampoline (eval-expr (nth rest-args 1) env)))
|
|
(set! body-args (slice rest-args 2)))
|
|
(set! body-args rest-args))
|
|
(scope-push! scope-name scope-val)
|
|
(let ((result nil))
|
|
(for-each (fn (body) (set! result (aser body env)))
|
|
body-args)
|
|
(scope-pop! scope-name)
|
|
result))
|
|
|
|
;; provide — sugar for scope with value
|
|
(= name "provide")
|
|
(let ((prov-name (trampoline (eval-expr (first args) env)))
|
|
(prov-val (trampoline (eval-expr (nth args 1) env)))
|
|
(result nil))
|
|
(scope-push! prov-name prov-val)
|
|
(for-each (fn (body) (set! result (aser body env)))
|
|
(slice args 2))
|
|
(scope-pop! prov-name)
|
|
result)
|
|
|
|
;; Everything else — evaluate normally
|
|
:else
|
|
(trampoline (eval-expr expr env))))))
|
|
|
|
|
|
;; Helper: case dispatch for aser mode
|
|
(define eval-case-aser :effects [render]
|
|
(fn (match-val (clauses :as list) (env :as dict))
|
|
(if (< (len clauses) 2)
|
|
nil
|
|
(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"))))
|
|
(aser body env)
|
|
(if (= match-val (trampoline (eval-expr test env)))
|
|
(aser body env)
|
|
(eval-case-aser match-val (slice clauses 2) env)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Platform interface — SX wire adapter
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; From eval.sx:
|
|
;; eval-expr, trampoline, call-lambda, expand-macro
|
|
;; env-has?, env-get, env-set!, env-merge, callable?, lambda?, component?,
|
|
;; macro?, island?, primitive?, get-primitive, component-name
|
|
;; lambda-closure, lambda-params, lambda-body
|
|
;;
|
|
;; From render.sx:
|
|
;; HTML_TAGS, eval-cond, process-bindings
|
|
;;
|
|
;; From parser.sx:
|
|
;; serialize (= sx-serialize)
|
|
;;
|
|
;; From signals.sx (optional):
|
|
;; invoke
|
|
;; --------------------------------------------------------------------------
|