giles
8a08de26cd
Move defhandler/defquery/defaction/defpage/defrelation from hardcoded evaluator dispatch to web/web-forms.sx extension module, registered via register-special-form!. Adapters updated to use definition-form? and dynamically extended form-name lists. Fix modifier-key clicks (ctrl-click → new tab) in three click handlers: bindBoostLink, bindClientRouteClick, and orchestration.sx bind-event. Add event-modifier-key? primitive (eventModifierKey_p for transpiler). Fix CSSX SSR: ~cssx/flush no longer drains the collected bucket on the server, so the shell template correctly emits CSSX rules in <head>. Add missing server-side DOM stubs (create-text-node, dom-append, etc.) and SSR passthrough for portal/error-boundary/promise-delayed. Passive event listeners for touch/wheel/scroll to fix touchpad scrolling. 97/97 Playwright demo tests + 4/4 isomorphic SSR tests pass. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1372 lines
53 KiB
Plaintext
1372 lines
53 KiB
Plaintext
;; ==========================================================================
|
|
;; adapter-async.sx — Async rendering and serialization adapter
|
|
;;
|
|
;; Async versions of adapter-html.sx (render) and adapter-sx.sx (aser)
|
|
;; for use with I/O-capable server environments (Python async, JS promises).
|
|
;;
|
|
;; Structurally identical to the sync adapters but uses async primitives:
|
|
;; async-eval — evaluate with I/O interception (platform primitive)
|
|
;; async-render — defined here, async HTML rendering
|
|
;; async-aser — defined here, async SX wire format
|
|
;;
|
|
;; All functions in this file are emitted as async by the bootstrapper.
|
|
;; Calls to other async functions receive await automatically.
|
|
;;
|
|
;; Depends on:
|
|
;; eval.sx — cond-scheme?, eval-cond-scheme, eval-cond-clojure,
|
|
;; expand-macro, env-merge, lambda?, component?, island?,
|
|
;; macro?, lambda-closure, lambda-params, lambda-body
|
|
;; render.sx — HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS,
|
|
;; render-attrs, definition-form?, process-bindings, eval-cond
|
|
;;
|
|
;; Platform primitives (provided by host):
|
|
;; (async-eval expr env ctx) — evaluate with I/O interception
|
|
;; (io-primitive? name) — check if name is I/O primitive
|
|
;; (execute-io name args kw ctx) — execute an I/O primitive
|
|
;; (expand-components?) — context var: expand components in aser?
|
|
;; (svg-context?) — context var: in SVG rendering context?
|
|
;; (svg-context-set! val) — set SVG context
|
|
;; (svg-context-reset! token) — reset SVG context
|
|
;; (css-class-collect! val) — collect CSS classes for bundling
|
|
;; (is-raw-html? x) — check if value is raw HTML marker
|
|
;; (raw-html-content x) — extract HTML string from marker
|
|
;; (make-raw-html s) — wrap string as raw HTML
|
|
;; (async-coroutine? x) — check if value is a coroutine
|
|
;; (async-await! x) — await a coroutine value
|
|
;; ==========================================================================
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Async HTML renderer
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render :effects [render io]
|
|
(fn (expr (env :as dict) ctx)
|
|
(case (type-of expr)
|
|
"nil" ""
|
|
"boolean" ""
|
|
"string" (escape-html expr)
|
|
"number" (escape-html (str expr))
|
|
"raw-html" (raw-html-content expr)
|
|
"spread" (do (emit! "element-attrs" (spread-attrs expr)) "")
|
|
"symbol" (let ((val (async-eval expr env ctx)))
|
|
(async-render val env ctx))
|
|
"keyword" (escape-html (keyword-name expr))
|
|
"list" (if (empty? expr) "" (async-render-list expr env ctx))
|
|
"dict" ""
|
|
:else (escape-html (str expr)))))
|
|
|
|
|
|
(define-async async-render-list :effects [render io]
|
|
(fn (expr (env :as dict) ctx)
|
|
(let ((head (first expr)))
|
|
(if (not (= (type-of head) "symbol"))
|
|
;; Non-symbol head — data list, render each item
|
|
(if (or (lambda? head) (= (type-of head) "list"))
|
|
;; Lambda/list call — eval then render
|
|
(async-render (async-eval expr env ctx) env ctx)
|
|
;; Data list
|
|
(join "" (async-map-render expr env ctx)))
|
|
|
|
;; Symbol head — dispatch
|
|
(let ((name (symbol-name head))
|
|
(args (rest expr)))
|
|
(cond
|
|
;; I/O primitive
|
|
(io-primitive? name)
|
|
(async-render (async-eval expr env ctx) env ctx)
|
|
|
|
;; raw!
|
|
(= name "raw!")
|
|
(async-render-raw args env ctx)
|
|
|
|
;; Fragment
|
|
(= name "<>")
|
|
(join "" (async-map-render args env ctx))
|
|
|
|
;; html: prefix
|
|
(starts-with? name "html:")
|
|
(async-render-element (slice name 5) args env ctx)
|
|
|
|
;; Render-aware special form (but check HTML tag + keyword first)
|
|
(async-render-form? name)
|
|
(if (and (contains? HTML_TAGS name)
|
|
(or (and (> (len expr) 1) (= (type-of (nth expr 1)) "keyword"))
|
|
(svg-context?)))
|
|
(async-render-element name args env ctx)
|
|
(dispatch-async-render-form name expr env ctx))
|
|
|
|
;; Macro
|
|
(and (env-has? env name) (macro? (env-get env name)))
|
|
(async-render
|
|
(trampoline (expand-macro (env-get env name) args env))
|
|
env ctx)
|
|
|
|
;; HTML tag
|
|
(contains? HTML_TAGS name)
|
|
(async-render-element name args env ctx)
|
|
|
|
;; Island (~name)
|
|
(and (starts-with? name "~")
|
|
(env-has? env name)
|
|
(island? (env-get env name)))
|
|
(async-render-island (env-get env name) args env ctx)
|
|
|
|
;; Component (~name)
|
|
(starts-with? name "~")
|
|
(let ((val (if (env-has? env name) (env-get env name) nil)))
|
|
(cond
|
|
(component? val) (async-render-component val args env ctx)
|
|
(macro? val) (async-render (trampoline (expand-macro val args env)) env ctx)
|
|
:else (async-render (async-eval expr env ctx) env ctx)))
|
|
|
|
;; Custom element (has - and keyword arg)
|
|
(and (> (index-of name "-") 0)
|
|
(> (len expr) 1)
|
|
(= (type-of (nth expr 1)) "keyword"))
|
|
(async-render-element name args env ctx)
|
|
|
|
;; SVG context
|
|
(svg-context?)
|
|
(async-render-element name args env ctx)
|
|
|
|
;; Fallback — eval then render
|
|
:else
|
|
(async-render (async-eval expr env ctx) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-raw — handle (raw! ...) in async context
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-raw :effects [render io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((parts (list)))
|
|
(for-each
|
|
(fn (arg)
|
|
(let ((val (async-eval arg env ctx)))
|
|
(cond
|
|
(is-raw-html? val) (append! parts (raw-html-content val))
|
|
(= (type-of val) "string") (append! parts val)
|
|
(and (not (nil? val)) (not (= val false)))
|
|
(append! parts (str val)))))
|
|
args)
|
|
(join "" parts))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-element — render an HTML element with async arg evaluation
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-element :effects [render io]
|
|
(fn ((tag :as string) (args :as list) (env :as dict) ctx)
|
|
(let ((attrs (dict))
|
|
(children (list)))
|
|
;; Parse keyword attrs and children
|
|
(async-parse-element-args args attrs children env ctx)
|
|
;; Collect CSS classes
|
|
(let ((class-val (dict-get attrs "class")))
|
|
(when (and (not (nil? class-val)) (not (= class-val false)))
|
|
(css-class-collect! (str class-val))))
|
|
(if (contains? VOID_ELEMENTS tag)
|
|
(str "<" tag (render-attrs attrs) ">")
|
|
;; Provide scope for spread emit!
|
|
(let ((token (if (or (= tag "svg") (= tag "math"))
|
|
(svg-context-set! true)
|
|
nil))
|
|
(content-parts (list)))
|
|
(scope-push! "element-attrs" nil)
|
|
(for-each
|
|
(fn (c) (append! content-parts (async-render c env ctx)))
|
|
children)
|
|
(for-each
|
|
(fn (spread-dict) (merge-spread-attrs attrs spread-dict))
|
|
(emitted "element-attrs"))
|
|
(scope-pop! "element-attrs")
|
|
(when token (svg-context-reset! token))
|
|
(str "<" tag (render-attrs attrs) ">"
|
|
(join "" content-parts)
|
|
"</" tag ">"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-parse-element-args — parse :key val pairs + children, async eval
|
|
;; --------------------------------------------------------------------------
|
|
;; Uses for-each + mutable state instead of reduce, because the bootstrapper
|
|
;; compiles inline for-each lambdas as for loops (which can contain await).
|
|
|
|
(define-async async-parse-element-args :effects [render io]
|
|
(fn ((args :as list) (attrs :as dict) (children :as list) (env :as dict) ctx)
|
|
(let ((skip false)
|
|
(i 0))
|
|
(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 (async-eval (nth args (inc i)) env ctx)))
|
|
(dict-set! attrs (keyword-name arg) val)
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
(do
|
|
(append! children arg)
|
|
(set! i (inc i))))))
|
|
args))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-component — expand and render a component asynchronously
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-component :effects [render io]
|
|
(fn ((comp :as component) (args :as list) (env :as dict) ctx)
|
|
(let ((kwargs (dict))
|
|
(children (list)))
|
|
;; Parse keyword args and children
|
|
(async-parse-kw-args args kwargs children env ctx)
|
|
;; Build env: closure + caller env + params
|
|
(let ((local (env-merge (component-closure comp) env)))
|
|
(for-each
|
|
(fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
(component-params comp))
|
|
;; Pre-render children to raw HTML
|
|
(when (component-has-children? comp)
|
|
(let ((parts (list)))
|
|
(for-each
|
|
(fn (c) (append! parts (async-render c env ctx)))
|
|
children)
|
|
(env-bind! local "children"
|
|
(make-raw-html (join "" parts)))))
|
|
(async-render (component-body comp) local ctx)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-island — SSR render of reactive island with hydration markers
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-island :effects [render io]
|
|
(fn ((island :as island) (args :as list) (env :as dict) ctx)
|
|
(let ((kwargs (dict))
|
|
(children (list)))
|
|
(async-parse-kw-args args kwargs children env ctx)
|
|
(let ((local (env-merge (component-closure island) env))
|
|
(island-name (component-name island)))
|
|
(for-each
|
|
(fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
(component-params island))
|
|
;; Pre-render children
|
|
(when (component-has-children? island)
|
|
(let ((parts (list)))
|
|
(for-each
|
|
(fn (c) (append! parts (async-render c env ctx)))
|
|
children)
|
|
(env-bind! local "children"
|
|
(make-raw-html (join "" parts)))))
|
|
(let ((body-html (async-render (component-body island) local ctx))
|
|
(state-json (serialize-island-state kwargs)))
|
|
(str "<span data-sx-island=\"" (escape-attr island-name) "\""
|
|
(if state-json
|
|
(str " data-sx-state=\"" (escape-attr state-json) "\"")
|
|
"")
|
|
">"
|
|
body-html
|
|
"</span>"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-lambda — render lambda body in HTML context
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-lambda :effects [render io]
|
|
(fn ((f :as lambda) (args :as list) (env :as dict) ctx)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(for-each-indexed
|
|
(fn (i p) (env-bind! local p (nth args i)))
|
|
(lambda-params f))
|
|
(async-render (lambda-body f) local ctx))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-parse-kw-args — parse keyword args and children with async eval
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-parse-kw-args :effects [render io]
|
|
(fn ((args :as list) (kwargs :as dict) (children :as list) (env :as dict) ctx)
|
|
(let ((skip false)
|
|
(i 0))
|
|
(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 (async-eval (nth args (inc i)) env ctx)))
|
|
(dict-set! kwargs (keyword-name arg) val)
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
(do
|
|
(append! children arg)
|
|
(set! i (inc i))))))
|
|
args))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-map-render — map async-render over a list, return list of strings
|
|
;; --------------------------------------------------------------------------
|
|
;; Bootstrapper emits this as: [await async_render(x, env, ctx) for x in exprs]
|
|
|
|
(define-async async-map-render :effects [render io]
|
|
(fn ((exprs :as list) (env :as dict) ctx)
|
|
(let ((results (list)))
|
|
(for-each
|
|
(fn (x) (append! results (async-render x env ctx)))
|
|
exprs)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Render-aware form classification
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ASYNC_RENDER_FORMS
|
|
(list "if" "when" "cond" "case" "let" "let*" "begin" "do"
|
|
"define" "defcomp" "defisland" "defmacro" "defstyle"
|
|
"deftype" "defeffect"
|
|
"map" "map-indexed" "filter" "for-each" "scope" "provide"))
|
|
|
|
(define async-render-form? :effects []
|
|
(fn ((name :as string))
|
|
(contains? ASYNC_RENDER_FORMS name)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; dispatch-async-render-form — async special form rendering for HTML output
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Uses cond-scheme? from eval.sx (the FIXED version with every? check)
|
|
;; and eval-cond from render.sx for correct scheme/clojure classification.
|
|
|
|
(define-async dispatch-async-render-form :effects [render io]
|
|
(fn ((name :as string) expr (env :as dict) ctx)
|
|
(cond
|
|
;; if
|
|
(= name "if")
|
|
(let ((cond-val (async-eval (nth expr 1) env ctx)))
|
|
(if cond-val
|
|
(async-render (nth expr 2) env ctx)
|
|
(if (> (len expr) 3)
|
|
(async-render (nth expr 3) env ctx)
|
|
"")))
|
|
|
|
;; when — single body: pass through. Multi: join strings.
|
|
(= name "when")
|
|
(if (not (async-eval (nth expr 1) env ctx))
|
|
""
|
|
(if (= (len expr) 3)
|
|
(async-render (nth expr 2) env ctx)
|
|
(join "" (async-map-render (slice expr 2) env ctx))))
|
|
|
|
;; cond — uses cond-scheme? (every? check) from eval.sx
|
|
(= name "cond")
|
|
(let ((clauses (rest expr)))
|
|
(if (cond-scheme? clauses)
|
|
(async-render-cond-scheme clauses env ctx)
|
|
(async-render-cond-clojure clauses env ctx)))
|
|
|
|
;; case
|
|
(= name "case")
|
|
(async-render (async-eval expr env ctx) env ctx)
|
|
|
|
;; let / let* — single body: pass through. Multi: join strings.
|
|
(or (= name "let") (= name "let*"))
|
|
(let ((local (async-process-bindings (nth expr 1) env ctx)))
|
|
(if (= (len expr) 3)
|
|
(async-render (nth expr 2) local ctx)
|
|
(join "" (async-map-render (slice expr 2) local ctx))))
|
|
|
|
;; begin / do — single body: pass through. Multi: join strings.
|
|
(or (= name "begin") (= name "do"))
|
|
(if (= (len expr) 2)
|
|
(async-render (nth expr 1) env ctx)
|
|
(join "" (async-map-render (rest expr) env ctx)))
|
|
|
|
;; Definition forms
|
|
(definition-form? name)
|
|
(do (async-eval expr env ctx) "")
|
|
|
|
;; map
|
|
(= name "map")
|
|
(let ((f (async-eval (nth expr 1) env ctx))
|
|
(coll (async-eval (nth expr 2) env ctx)))
|
|
(join "" (async-map-fn-render f coll env ctx)))
|
|
|
|
;; map-indexed
|
|
(= name "map-indexed")
|
|
(let ((f (async-eval (nth expr 1) env ctx))
|
|
(coll (async-eval (nth expr 2) env ctx)))
|
|
(join "" (async-map-indexed-fn-render f coll env ctx)))
|
|
|
|
;; filter — eval fully then render
|
|
(= name "filter")
|
|
(async-render (async-eval expr env ctx) env ctx)
|
|
|
|
;; for-each (render variant)
|
|
(= name "for-each")
|
|
(let ((f (async-eval (nth expr 1) env ctx))
|
|
(coll (async-eval (nth expr 2) env ctx)))
|
|
(join "" (async-map-fn-render f coll env ctx)))
|
|
|
|
;; scope — unified render-time dynamic scope
|
|
(= name "scope")
|
|
(let ((scope-name (async-eval (nth expr 1) env ctx))
|
|
(rest-args (slice expr 2))
|
|
(scope-val nil)
|
|
(body-exprs 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 (async-eval (nth rest-args 1) env ctx))
|
|
(set! body-exprs (slice rest-args 2)))
|
|
(set! body-exprs rest-args))
|
|
(scope-push! scope-name scope-val)
|
|
(let ((result (if (= (len body-exprs) 1)
|
|
(async-render (first body-exprs) env ctx)
|
|
(join "" (async-map-render body-exprs env ctx)))))
|
|
(scope-pop! scope-name)
|
|
result))
|
|
|
|
;; provide — sugar for scope with value
|
|
(= name "provide")
|
|
(let ((prov-name (async-eval (nth expr 1) env ctx))
|
|
(prov-val (async-eval (nth expr 2) env ctx))
|
|
(body-start 3)
|
|
(body-count (- (len expr) 3)))
|
|
(scope-push! prov-name prov-val)
|
|
(let ((result (if (= body-count 1)
|
|
(async-render (nth expr body-start) env ctx)
|
|
(join "" (async-map-render (slice expr body-start) env ctx)))))
|
|
(scope-pop! prov-name)
|
|
result))
|
|
|
|
;; Fallback
|
|
:else
|
|
(async-render (async-eval expr env ctx) env ctx))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-cond-scheme — scheme-style cond for render mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-cond-scheme :effects [render io]
|
|
(fn ((clauses :as list) (env :as dict) ctx)
|
|
(if (empty? clauses)
|
|
""
|
|
(let ((clause (first clauses))
|
|
(test (first clause))
|
|
(body (nth clause 1)))
|
|
(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")))
|
|
(async-render body env ctx)
|
|
(if (async-eval test env ctx)
|
|
(async-render body env ctx)
|
|
(async-render-cond-scheme (rest clauses) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-render-cond-clojure — clojure-style cond for render mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-render-cond-clojure :effects [render io]
|
|
(fn ((clauses :as list) (env :as dict) ctx)
|
|
(if (< (len clauses) 2)
|
|
""
|
|
(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"))))
|
|
(async-render body env ctx)
|
|
(if (async-eval test env ctx)
|
|
(async-render body env ctx)
|
|
(async-render-cond-clojure (slice clauses 2) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-process-bindings — evaluate let-bindings asynchronously
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-process-bindings :effects [render io]
|
|
(fn (bindings (env :as dict) ctx)
|
|
;; env-extend (not merge) — Env is not a dict subclass, so merge()
|
|
;; returns an empty dict, losing all parent scope bindings.
|
|
(let ((local (env-extend env)))
|
|
(if (and (= (type-of bindings) "list") (not (empty? bindings)))
|
|
(if (= (type-of (first bindings)) "list")
|
|
;; Scheme-style: ((name val) ...)
|
|
(for-each
|
|
(fn (pair)
|
|
(when (and (= (type-of pair) "list") (>= (len pair) 2))
|
|
(let ((name (if (= (type-of (first pair)) "symbol")
|
|
(symbol-name (first pair))
|
|
(str (first pair)))))
|
|
(env-bind! local name (async-eval (nth pair 1) local ctx)))))
|
|
bindings)
|
|
;; Clojure-style: (name val name val ...)
|
|
(async-process-bindings-flat bindings local ctx)))
|
|
local)))
|
|
|
|
|
|
(define-async async-process-bindings-flat :effects [render io]
|
|
(fn ((bindings :as list) (local :as dict) ctx)
|
|
(let ((skip false)
|
|
(i 0))
|
|
(for-each
|
|
(fn (item)
|
|
(if skip
|
|
(do (set! skip false)
|
|
(set! i (inc i)))
|
|
(do
|
|
(let ((name (if (= (type-of item) "symbol")
|
|
(symbol-name item)
|
|
(str item))))
|
|
(when (< (inc i) (len bindings))
|
|
(env-bind! local name
|
|
(async-eval (nth bindings (inc i)) local ctx))))
|
|
(set! skip true)
|
|
(set! i (inc i)))))
|
|
bindings))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-map-fn-render — map a lambda/callable over collection for render
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-map-fn-render :effects [render io]
|
|
(fn (f (coll :as list) (env :as dict) ctx)
|
|
(let ((results (list)))
|
|
(for-each
|
|
(fn (item)
|
|
(if (lambda? f)
|
|
(append! results (async-render-lambda f (list item) env ctx))
|
|
(let ((r (async-invoke f item)))
|
|
(append! results (async-render r env ctx)))))
|
|
coll)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-map-indexed-fn-render — map-indexed variant for render
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-map-indexed-fn-render :effects [render io]
|
|
(fn (f (coll :as list) (env :as dict) ctx)
|
|
(let ((results (list))
|
|
(i 0))
|
|
(for-each
|
|
(fn (item)
|
|
(if (lambda? f)
|
|
(append! results (async-render-lambda f (list i item) env ctx))
|
|
(let ((r (async-invoke f i item)))
|
|
(append! results (async-render r env ctx))))
|
|
(set! i (inc i)))
|
|
coll)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-invoke — call a native callable, await if coroutine
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-invoke :effects [io]
|
|
(fn (f &rest args)
|
|
(let ((r (apply f args)))
|
|
(if (async-coroutine? r)
|
|
(async-await! r)
|
|
r))))
|
|
|
|
|
|
;; ==========================================================================
|
|
;; Async SX wire format (aser)
|
|
;; ==========================================================================
|
|
|
|
(define-async async-aser :effects [render io]
|
|
(fn (expr (env :as dict) ctx)
|
|
(let ((t (type-of expr))
|
|
(result nil))
|
|
(cond
|
|
(= t "number") (set! result expr)
|
|
(= t "string") (set! result expr)
|
|
(= t "boolean") (set! result expr)
|
|
(= t "nil") (set! result nil)
|
|
(= t "symbol")
|
|
(let ((name (symbol-name expr)))
|
|
(set! result
|
|
(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)))))
|
|
(= t "keyword") (set! result (keyword-name expr))
|
|
(= t "dict") (set! result (async-aser-dict expr env ctx))
|
|
;; Spread — emit attrs to nearest element provider
|
|
(= t "spread") (do (emit! "element-attrs" (spread-attrs expr))
|
|
(set! result nil))
|
|
(= t "list") (set! result (if (empty? expr) (list) (async-aser-list expr env ctx)))
|
|
:else (set! result expr))
|
|
;; Catch spread values from function calls and symbol lookups
|
|
(if (spread? result)
|
|
(do (emit! "element-attrs" (spread-attrs result)) nil)
|
|
result))))
|
|
|
|
|
|
(define-async async-aser-dict :effects [render io]
|
|
(fn ((expr :as dict) (env :as dict) ctx)
|
|
(let ((result (dict)))
|
|
(for-each
|
|
(fn (key)
|
|
(dict-set! result key (async-aser (dict-get expr key) env ctx)))
|
|
(keys expr))
|
|
result)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-list — dispatch on list head for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-list :effects [render io]
|
|
(fn (expr (env :as dict) ctx)
|
|
(let ((head (first expr))
|
|
(args (rest expr)))
|
|
(if (not (= (type-of head) "symbol"))
|
|
;; Non-symbol head
|
|
(if (or (lambda? head) (= (type-of head) "list"))
|
|
;; Function/list call — eval fully
|
|
(async-aser-eval-call head args env ctx)
|
|
;; Data list — aser each
|
|
(async-aser-map-list expr env ctx))
|
|
|
|
;; Symbol head — dispatch
|
|
(let ((name (symbol-name head)))
|
|
(cond
|
|
;; I/O primitive
|
|
(io-primitive? name)
|
|
(async-eval expr env ctx)
|
|
|
|
;; Fragment
|
|
(= name "<>")
|
|
(async-aser-fragment args env ctx)
|
|
|
|
;; raw!
|
|
(= name "raw!")
|
|
(async-aser-call "raw!" args env ctx)
|
|
|
|
;; html: prefix
|
|
(starts-with? name "html:")
|
|
(async-aser-call (slice name 5) args env ctx)
|
|
|
|
;; Component call (~name)
|
|
(starts-with? name "~")
|
|
(let ((val (if (env-has? env name) (env-get env name) nil)))
|
|
(cond
|
|
(macro? val)
|
|
(async-aser (trampoline (expand-macro val args env)) env ctx)
|
|
(and (component? val)
|
|
(or (expand-components?)
|
|
(= (component-affinity val) "server")))
|
|
(async-aser-component val args env ctx)
|
|
:else
|
|
(async-aser-call name args env ctx)))
|
|
|
|
;; Special/HO forms
|
|
(or (async-aser-form? name))
|
|
(if (and (contains? HTML_TAGS name)
|
|
(or (and (> (len expr) 1) (= (type-of (nth expr 1)) "keyword"))
|
|
(svg-context?)))
|
|
(async-aser-call name args env ctx)
|
|
(dispatch-async-aser-form name expr env ctx))
|
|
|
|
;; HTML tag
|
|
(contains? HTML_TAGS name)
|
|
(async-aser-call name args env ctx)
|
|
|
|
;; Macro
|
|
(and (env-has? env name) (macro? (env-get env name)))
|
|
(async-aser (trampoline (expand-macro (env-get env name) args env)) env ctx)
|
|
|
|
;; Custom element
|
|
(and (> (index-of name "-") 0)
|
|
(> (len expr) 1)
|
|
(= (type-of (nth expr 1)) "keyword"))
|
|
(async-aser-call name args env ctx)
|
|
|
|
;; SVG context
|
|
(svg-context?)
|
|
(async-aser-call name args env ctx)
|
|
|
|
;; Fallback — function/lambda call
|
|
:else
|
|
(async-aser-eval-call head args env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-eval-call — evaluate a function call fully in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-eval-call :effects [render io]
|
|
(fn (head (args :as list) (env :as dict) ctx)
|
|
(let ((f (async-eval head env ctx))
|
|
(evaled-args (async-eval-args args env ctx)))
|
|
(cond
|
|
(and (callable? f) (not (lambda? f)) (not (component? f)))
|
|
;; apply directly — async-invoke takes &rest so passing a list
|
|
;; would wrap it in another list
|
|
(let ((r (apply f evaled-args)))
|
|
(if (async-coroutine? r) (async-await! r) r))
|
|
(lambda? f)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(for-each-indexed
|
|
(fn (i p) (env-bind! local p (nth evaled-args i)))
|
|
(lambda-params f))
|
|
(async-aser (lambda-body f) local ctx))
|
|
(component? f)
|
|
(async-aser-call (str "~" (component-name f)) args env ctx)
|
|
(island? f)
|
|
(async-aser-call (str "~" (component-name f)) args env ctx)
|
|
:else
|
|
(error (str "Not callable: " (inspect f)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-eval-args — evaluate a list of args asynchronously
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-eval-args :effects [io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((results (list)))
|
|
(for-each
|
|
(fn (a) (append! results (async-eval a env ctx)))
|
|
args)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-map-list — aser each element of a list
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-map-list :effects [render io]
|
|
(fn ((exprs :as list) (env :as dict) ctx)
|
|
(let ((results (list)))
|
|
(for-each
|
|
(fn (x) (append! results (async-aser x env ctx)))
|
|
exprs)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-fragment — serialize (<> child1 child2 ...) in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-fragment :effects [render io]
|
|
(fn ((children :as list) (env :as dict) ctx)
|
|
(let ((parts (list)))
|
|
(for-each
|
|
(fn (c)
|
|
(let ((result (async-aser c env ctx)))
|
|
(if (= (type-of result) "list")
|
|
(for-each
|
|
(fn (item)
|
|
(when (not (nil? item))
|
|
(append! parts (serialize item))))
|
|
result)
|
|
(when (not (nil? result))
|
|
(append! parts (serialize result))))))
|
|
children)
|
|
(if (empty? parts)
|
|
(make-sx-expr "")
|
|
(make-sx-expr (str "(<> " (join " " parts) ")"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-component — expand component server-side in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-component :effects [render io]
|
|
(fn ((comp :as component) (args :as list) (env :as dict) ctx)
|
|
(let ((kwargs (dict))
|
|
(children (list)))
|
|
(async-parse-aser-kw-args args kwargs children env ctx)
|
|
(let ((local (env-merge (component-closure comp) env)))
|
|
(for-each
|
|
(fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
(component-params comp))
|
|
(when (component-has-children? comp)
|
|
(let ((child-parts (list)))
|
|
(for-each
|
|
(fn (c)
|
|
(let ((result (async-aser c env ctx)))
|
|
(if (list? result)
|
|
(for-each
|
|
(fn (item)
|
|
(when (not (nil? item))
|
|
(append! child-parts (serialize item))))
|
|
result)
|
|
(when (not (nil? result))
|
|
(append! child-parts (serialize result))))))
|
|
children)
|
|
(env-bind! local "children"
|
|
(make-sx-expr (str "(<> " (join " " child-parts) ")")))))
|
|
(async-aser (component-body comp) local ctx)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-parse-aser-kw-args — parse keyword args for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-parse-aser-kw-args :effects [render io]
|
|
(fn ((args :as list) (kwargs :as dict) (children :as list) (env :as dict) ctx)
|
|
(let ((skip false)
|
|
(i 0))
|
|
(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 (async-aser (nth args (inc i)) env ctx)))
|
|
(dict-set! kwargs (keyword-name arg) val)
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
(do
|
|
(append! children arg)
|
|
(set! i (inc i))))))
|
|
args))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-call — serialize an SX call (tag or component) in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-call :effects [render io]
|
|
(fn ((name :as string) (args :as list) (env :as dict) ctx)
|
|
(let ((token (if (or (= name "svg") (= name "math"))
|
|
(svg-context-set! true)
|
|
nil))
|
|
(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 (async-aser (nth args (inc i)) env ctx)))
|
|
(when (not (nil? val))
|
|
(append! attr-parts (str ":" (keyword-name arg)))
|
|
(if (= (type-of val) "list")
|
|
(let ((live (filter (fn (v) (not (nil? v))) val)))
|
|
(if (empty? live)
|
|
(append! attr-parts "nil")
|
|
(let ((items (map serialize live)))
|
|
(if (some (fn (v) (sx-expr? v)) live)
|
|
(append! attr-parts (str "(<> " (join " " items) ")"))
|
|
(append! attr-parts (str "(list " (join " " items) ")"))))))
|
|
(append! attr-parts (serialize val))))
|
|
(set! skip true)
|
|
(set! i (inc i)))
|
|
(let ((result (async-aser arg env ctx)))
|
|
(when (not (nil? result))
|
|
(if (= (type-of result) "list")
|
|
(for-each
|
|
(fn (item)
|
|
(when (not (nil? item))
|
|
(append! child-parts (serialize item))))
|
|
result)
|
|
(append! child-parts (serialize result))))
|
|
(set! i (inc i))))))
|
|
args)
|
|
;; Collect emitted spread attrs — 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)))
|
|
(emitted "element-attrs"))
|
|
(scope-pop! "element-attrs")
|
|
(when token (svg-context-reset! token))
|
|
(let ((parts (concat (list name) attr-parts child-parts)))
|
|
(make-sx-expr (str "(" (join " " parts) ")"))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Aser form classification
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ASYNC_ASER_FORM_NAMES
|
|
(list "if" "when" "cond" "case" "and" "or"
|
|
"let" "let*" "lambda" "fn"
|
|
"define" "defcomp" "defmacro" "defstyle"
|
|
"begin" "do" "quote" "->" "set!" "defisland"
|
|
"deftype" "defeffect" "scope" "provide"))
|
|
|
|
(define ASYNC_ASER_HO_NAMES
|
|
(list "map" "map-indexed" "filter" "for-each"))
|
|
|
|
(define async-aser-form? :effects []
|
|
(fn ((name :as string))
|
|
(or (contains? ASYNC_ASER_FORM_NAMES name)
|
|
(contains? ASYNC_ASER_HO_NAMES name))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; dispatch-async-aser-form — evaluate special/HO forms in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Uses cond-scheme? from eval.sx (the FIXED version with every? check).
|
|
|
|
(define-async dispatch-async-aser-form :effects [render io]
|
|
(fn ((name :as string) expr (env :as dict) ctx)
|
|
(let ((args (rest expr)))
|
|
(cond
|
|
;; if
|
|
(= name "if")
|
|
(let ((cond-val (async-eval (first args) env ctx)))
|
|
(if cond-val
|
|
(async-aser (nth args 1) env ctx)
|
|
(if (> (len args) 2)
|
|
(async-aser (nth args 2) env ctx)
|
|
nil)))
|
|
|
|
;; when
|
|
(= name "when")
|
|
(if (not (async-eval (first args) env ctx))
|
|
nil
|
|
(let ((result nil))
|
|
(for-each
|
|
(fn (body) (set! result (async-aser body env ctx)))
|
|
(rest args))
|
|
result))
|
|
|
|
;; cond — uses cond-scheme? (every? check)
|
|
(= name "cond")
|
|
(if (cond-scheme? args)
|
|
(async-aser-cond-scheme args env ctx)
|
|
(async-aser-cond-clojure args env ctx))
|
|
|
|
;; case
|
|
(= name "case")
|
|
(let ((match-val (async-eval (first args) env ctx)))
|
|
(async-aser-case-loop match-val (rest args) env ctx))
|
|
|
|
;; let / let*
|
|
(or (= name "let") (= name "let*"))
|
|
(let ((local (async-process-bindings (first args) env ctx))
|
|
(result nil))
|
|
(for-each
|
|
(fn (body) (set! result (async-aser body local ctx)))
|
|
(rest args))
|
|
result)
|
|
|
|
;; begin / do
|
|
(or (= name "begin") (= name "do"))
|
|
(let ((result nil))
|
|
(for-each
|
|
(fn (body) (set! result (async-aser body env ctx)))
|
|
args)
|
|
result)
|
|
|
|
;; and — short-circuit via flag to avoid 'some' with async lambda
|
|
(= name "and")
|
|
(let ((result true)
|
|
(stop false))
|
|
(for-each (fn (arg)
|
|
(when (not stop)
|
|
(set! result (async-eval arg env ctx))
|
|
(when (not result)
|
|
(set! stop true))))
|
|
args)
|
|
result)
|
|
|
|
;; or — short-circuit via flag to avoid 'some' with async lambda
|
|
(= name "or")
|
|
(let ((result false)
|
|
(stop false))
|
|
(for-each (fn (arg)
|
|
(when (not stop)
|
|
(set! result (async-eval arg env ctx))
|
|
(when result
|
|
(set! stop true))))
|
|
args)
|
|
result)
|
|
|
|
;; lambda / fn
|
|
(or (= name "lambda") (= name "fn"))
|
|
(sf-lambda args env)
|
|
|
|
;; quote
|
|
(= name "quote")
|
|
(if (empty? args) nil (first args))
|
|
|
|
;; -> thread-first
|
|
(= name "->")
|
|
(async-aser-thread-first args env ctx)
|
|
|
|
;; set!
|
|
(= name "set!")
|
|
(let ((value (async-eval (nth args 1) env ctx)))
|
|
(env-bind! env (symbol-name (first args)) value)
|
|
value)
|
|
|
|
;; map
|
|
(= name "map")
|
|
(async-aser-ho-map args env ctx)
|
|
|
|
;; map-indexed
|
|
(= name "map-indexed")
|
|
(async-aser-ho-map-indexed args env ctx)
|
|
|
|
;; filter
|
|
(= name "filter")
|
|
(async-eval expr env ctx)
|
|
|
|
;; for-each
|
|
(= name "for-each")
|
|
(async-aser-ho-for-each args env ctx)
|
|
|
|
;; defisland — evaluate AND serialize
|
|
(= name "defisland")
|
|
(do (async-eval expr env ctx)
|
|
(serialize expr))
|
|
|
|
;; Definition forms — evaluate for side effects
|
|
(definition-form? name)
|
|
(do (async-eval expr env ctx) nil)
|
|
|
|
;; scope — unified render-time dynamic scope
|
|
(= name "scope")
|
|
(let ((scope-name (async-eval (first args) env ctx))
|
|
(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 (async-eval (nth rest-args 1) env ctx))
|
|
(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 (async-aser body env ctx)))
|
|
body-args)
|
|
(scope-pop! scope-name)
|
|
result))
|
|
|
|
;; provide — sugar for scope with value
|
|
(= name "provide")
|
|
(let ((prov-name (async-eval (first args) env ctx))
|
|
(prov-val (async-eval (nth args 1) env ctx))
|
|
(result nil))
|
|
(scope-push! prov-name prov-val)
|
|
(for-each (fn (body) (set! result (async-aser body env ctx)))
|
|
(slice args 2))
|
|
(scope-pop! prov-name)
|
|
result)
|
|
|
|
;; Fallback
|
|
:else
|
|
(async-eval expr env ctx)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-cond-scheme — scheme-style cond for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-cond-scheme :effects [render io]
|
|
(fn ((clauses :as list) (env :as dict) ctx)
|
|
(if (empty? clauses)
|
|
nil
|
|
(let ((clause (first clauses))
|
|
(test (first clause))
|
|
(body (nth clause 1)))
|
|
(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")))
|
|
(async-aser body env ctx)
|
|
(if (async-eval test env ctx)
|
|
(async-aser body env ctx)
|
|
(async-aser-cond-scheme (rest clauses) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-cond-clojure — clojure-style cond for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-cond-clojure :effects [render io]
|
|
(fn ((clauses :as list) (env :as dict) ctx)
|
|
(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"))))
|
|
(async-aser body env ctx)
|
|
(if (async-eval test env ctx)
|
|
(async-aser body env ctx)
|
|
(async-aser-cond-clojure (slice clauses 2) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-case-loop — case dispatch for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-case-loop :effects [render io]
|
|
(fn (match-val (clauses :as list) (env :as dict) ctx)
|
|
(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"))))
|
|
(async-aser body env ctx)
|
|
(if (= match-val (async-eval test env ctx))
|
|
(async-aser body env ctx)
|
|
(async-aser-case-loop match-val (slice clauses 2) env ctx)))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-aser-thread-first — -> form in aser mode
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-thread-first :effects [render io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((result (async-eval (first args) env ctx)))
|
|
(for-each
|
|
(fn (form)
|
|
(if (= (type-of form) "list")
|
|
(let ((f (async-eval (first form) env ctx))
|
|
(fn-args (cons result
|
|
(async-eval-args (rest form) env ctx))))
|
|
(set! result (async-invoke-or-lambda f fn-args env ctx)))
|
|
(let ((f (async-eval form env ctx)))
|
|
(set! result (async-invoke-or-lambda f (list result) env ctx)))))
|
|
(rest args))
|
|
result)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-invoke-or-lambda — invoke a callable or lambda with args
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-invoke-or-lambda :effects [render io]
|
|
(fn (f (args :as list) (env :as dict) ctx)
|
|
(cond
|
|
(and (callable? f) (not (lambda? f)) (not (component? f)))
|
|
(let ((r (apply f args)))
|
|
(if (async-coroutine? r)
|
|
(async-await! r)
|
|
r))
|
|
(lambda? f)
|
|
(let ((local (env-merge (lambda-closure f) env)))
|
|
(for-each-indexed
|
|
(fn (i p) (env-bind! local p (nth args i)))
|
|
(lambda-params f))
|
|
(async-eval (lambda-body f) local ctx))
|
|
:else
|
|
(error (str "-> form not callable: " (inspect f))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Async aser HO forms (map, map-indexed, for-each)
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define-async async-aser-ho-map :effects [render io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((f (async-eval (first args) env ctx))
|
|
(coll (async-eval (nth args 1) env ctx))
|
|
(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 (async-aser (lambda-body f) local ctx)))
|
|
(append! results (async-invoke f item))))
|
|
coll)
|
|
results)))
|
|
|
|
|
|
(define-async async-aser-ho-map-indexed :effects [render io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((f (async-eval (first args) env ctx))
|
|
(coll (async-eval (nth args 1) env ctx))
|
|
(results (list))
|
|
(i 0))
|
|
(for-each
|
|
(fn (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)
|
|
(append! results (async-aser (lambda-body f) local ctx)))
|
|
(append! results (async-invoke f i item)))
|
|
(set! i (inc i)))
|
|
coll)
|
|
results)))
|
|
|
|
|
|
(define-async async-aser-ho-for-each :effects [render io]
|
|
(fn ((args :as list) (env :as dict) ctx)
|
|
(let ((f (async-eval (first args) env ctx))
|
|
(coll (async-eval (nth args 1) env ctx))
|
|
(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 (async-aser (lambda-body f) local ctx)))
|
|
(append! results (async-invoke f item))))
|
|
coll)
|
|
results)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; async-eval-slot-inner — server-side slot expansion for aser mode
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Coordinates component expansion for server-rendered pages:
|
|
;; 1. If expression is a direct component call (~name ...), expand it
|
|
;; 2. Otherwise aser the expression, then check if result is a (~...)
|
|
;; call that should be re-expanded
|
|
;;
|
|
;; Platform primitives required:
|
|
;; (sx-parse src) — parse SX source string
|
|
;; (make-sx-expr s) — wrap as SxExpr
|
|
;; (sx-expr? x) — check if SxExpr
|
|
;; (set-expand-components!) — enable component expansion context var
|
|
|
|
(define-async async-eval-slot-inner :effects [render io]
|
|
(fn (expr (env :as dict) ctx)
|
|
;; NOTE: Uses statement-form let + set! to avoid expression-context
|
|
;; let (IIFE lambdas) which can't contain await in Python.
|
|
(let ((result nil))
|
|
(if (and (list? expr) (not (empty? expr)))
|
|
(let ((head (first expr)))
|
|
(if (and (= (type-of head) "symbol")
|
|
(starts-with? (symbol-name head) "~"))
|
|
(let ((name (symbol-name head))
|
|
(val (if (env-has? env name) (env-get env name) nil)))
|
|
(if (component? val)
|
|
(set! result (async-aser-component val (rest expr) env ctx))
|
|
(set! result (async-maybe-expand-result (async-aser expr env ctx) env ctx))))
|
|
(set! result (async-maybe-expand-result (async-aser expr env ctx) env ctx))))
|
|
(set! result (async-maybe-expand-result (async-aser expr env ctx) env ctx)))
|
|
;; Normalize result to SxExpr
|
|
(if (sx-expr? result)
|
|
result
|
|
(if (nil? result)
|
|
(make-sx-expr "")
|
|
(if (string? result)
|
|
(make-sx-expr result)
|
|
(make-sx-expr (serialize result))))))))
|
|
|
|
|
|
(define-async async-maybe-expand-result :effects [render io]
|
|
(fn (result (env :as dict) ctx)
|
|
;; If the aser result is a component call string like "(~foo ...)",
|
|
;; re-parse and expand it. This handles indirect component references
|
|
;; (e.g. a let binding that evaluates to a component call).
|
|
(let ((raw (if (sx-expr? result)
|
|
(trim (str result))
|
|
(if (string? result)
|
|
(trim result)
|
|
nil))))
|
|
(if (and raw (starts-with? raw "(~"))
|
|
(let ((parsed (sx-parse raw)))
|
|
(if (and parsed (not (empty? parsed)))
|
|
(async-eval-slot-inner (first parsed) env ctx)
|
|
result))
|
|
result))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Platform interface — async adapter
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Async evaluation (provided by platform):
|
|
;; (async-eval expr env ctx) — evaluate with I/O interception
|
|
;; (execute-io name args kw ctx) — execute I/O primitive
|
|
;; (io-primitive? name) — check if name is I/O primitive
|
|
;;
|
|
;; From eval.sx:
|
|
;; cond-scheme?, eval-cond-scheme, eval-cond-clojure
|
|
;; eval-expr, trampoline, expand-macro, sf-lambda
|
|
;; env-has?, env-get, env-set!, env-merge
|
|
;; lambda?, component?, island?, macro?, callable?
|
|
;; lambda-closure, lambda-params, lambda-body
|
|
;; component-params, component-body, component-closure,
|
|
;; component-has-children?, component-name
|
|
;; inspect
|
|
;;
|
|
;; From render.sx:
|
|
;; HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS
|
|
;; render-attrs, definition-form?, cond-scheme?
|
|
;; escape-html, escape-attr, raw-html-content
|
|
;;
|
|
;; From adapter-html.sx:
|
|
;; serialize-island-state
|
|
;;
|
|
;; Context management (platform):
|
|
;; (expand-components?) — check if component expansion is enabled
|
|
;; (svg-context?) — check if in SVG context
|
|
;; (svg-context-set! val) — set SVG context (returns reset token)
|
|
;; (svg-context-reset! token) — reset SVG context
|
|
;; (css-class-collect! val) — collect CSS classes
|
|
;;
|
|
;; Spread + collect (from render.sx):
|
|
;; (spread? x) — check if spread value
|
|
;; (spread-attrs s) — extract attrs dict from spread
|
|
;; (merge-spread-attrs tgt src) — merge spread attrs onto target
|
|
;; (collect! bucket value) — add to render-time accumulator
|
|
;; (collected bucket) — read render-time accumulator
|
|
;; (clear-collected! bucket) — clear accumulator
|
|
;;
|
|
;; Raw HTML:
|
|
;; (is-raw-html? x) — check if raw HTML marker
|
|
;; (make-raw-html s) — wrap string as raw HTML
|
|
;; (raw-html-content x) — unwrap raw HTML
|
|
;;
|
|
;; SxExpr:
|
|
;; (make-sx-expr s) — wrap as SxExpr (wire format string)
|
|
;; (sx-expr? x) — check if SxExpr
|
|
;;
|
|
;; Async primitives:
|
|
;; (async-coroutine? x) — check if value is a coroutine
|
|
;; (async-await! x) — await a coroutine
|
|
;; --------------------------------------------------------------------------
|