coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
6008a1be303cbb970eb11c23e2786f8f97be994a
rose-ash/web/adapter-sx.sx
giles 2d7dd7d582 Step 5 piece 6: migrate 23 .sx files to define-library/import 
Wraps all core .sx files in R7RS define-library with explicit export
lists, plus (import ...) at end for backward-compatible global re-export.

Libraries registered:
  (sx bytecode)      — 83 opcode constants
  (sx render)        — 15 tag registries + render helpers
  (sx signals)       — 23 reactive signal primitives
  (sx r7rs)          — 21 R7RS aliases
  (sx compiler)      — 42 compiler functions
  (sx vm)            — 32 VM functions
  (sx freeze)        — 9 freeze/thaw functions
  (sx content)       — 6 content store functions
  (sx callcc)        — 1 call/cc wrapper
  (sx highlight)     — 13 syntax highlighting functions
  (sx stdlib)        — 47 stdlib functions
  (sx swap)          — 13 swap algebra functions
  (sx render-trace)  — 8 render trace functions
  (sx harness)       — 21 test harness functions
  (sx canonical)     — 12 canonical serialization functions
  (web adapter-html) — 13 HTML renderer functions
  (web adapter-sx)   — 13 SX wire format functions
  (web engine)       — 33 hypermedia engine functions
  (web request-handler) — 4 request handling functions
  (web page-helpers) — 12 page helper functions
  (web router)       — 36 routing functions
  (web deps)         — 19 dependency analysis functions
  (web orchestration) — 59 page orchestration functions

Key changes:
- define-library now inherits parent env (env-extend env instead of
  env-extend make-env) so library bodies can access platform primitives
- sx_server.ml: added resolve_library_path + load_library_file for
  import resolution (maps library specs to file paths)
- cek_run_with_io: handles "import" locally instead of sending to
  Python bridge

2608/2608 tests passing.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-03 21:48:54 +00:00

598 lines
19 KiB
Plaintext
Raw Blame History

(define-library (web adapter-sx)
(export
render-to-sx
aser
aser-list
aser-reserialize
aser-fragment
aser-call
aser-expand-component
SPECIAL_FORM_NAMES
HO_FORM_NAMES
special-form?
ho-form?
aser-special
eval-case-aser)
(begin
(define
render-to-sx
:effects (render)
(fn
(expr (env :as dict))
(let
((result (aser expr env)))
(cond
(= (type-of result) "sx-expr")
(sx-expr-source result)
(= (type-of result) "string")
result
:else (serialize result)))))
(define
aser
:effects (render)
(fn
((expr :as any) (env :as dict))
(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" (do (scope-emit! "element-attrs" (spread-attrs expr)) nil) :else expr)))
(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
(= name "<>")
(aser-fragment args env)
(= name "raw!")
(aser-call "raw!" args env)
(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"))
(not (= (component-affinity comp) "client")))
(aser-expand-component comp args env)
:else (aser-call name args env)))
(= name "lake")
(aser-call name args env)
(= name "marsh")
(aser-call name args env)
(= name "error-boundary")
(let
((has-fallback (> (len args) 1)))
(let
((body-exprs (if has-fallback (rest args) args))
(err-str nil))
(let
((rendered (try-catch (fn () (join "" (map (fn (x) (let ((v (aser x env))) (cond (= (type-of v) "sx-expr") (sx-expr-source v) (nil? v) "" :else (serialize v)))) body-exprs))) (fn (err) (set! err-str (str err)) nil))))
(if
rendered
(make-sx-expr (str "(error-boundary " rendered ")"))
(make-sx-expr
(str
"(div :data-sx-boundary \"true\" "
"(div :class \"sx-render-error\" "
":style \"color:red;font-size:0.875rem;padding:0.5rem;border:1px solid red;border-radius:0.25rem;margin:0.5rem 0;\" "
"\"Render error: "
(replace (replace err-str "\"" "'") "\\" "\\\\")
"\"))"))))))
(contains? HTML_TAGS name)
(aser-call name args env)
(or (special-form? name) (ho-form? name))
(aser-special name expr env)
(and (env-has? env name) (macro? (env-get env name)))
(aser (expand-macro (env-get env name) args env) env)
: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-reserialize
:effects ()
(fn
(val)
(if
(not (= (type-of val) "list"))
(serialize val)
(if
(empty? val)
"()"
(let
((head (first val)))
(if
(not (= (type-of head) "symbol"))
(serialize val)
(let
((tag (symbol-name head))
(parts (list tag))
(args (rest val))
(skip false)
(i 0))
(for-each
(fn
(arg)
(if
skip
(do (set! skip false) (set! i (inc i)))
(if
(and
(= (type-of arg) "string")
(< (inc i) (len args))
(not (contains? arg " "))
(or
(starts-with? arg "class")
(starts-with? arg "id")
(starts-with? arg "sx-")
(starts-with? arg "data-")
(starts-with? arg "style")
(starts-with? arg "href")
(starts-with? arg "src")
(starts-with? arg "type")
(starts-with? arg "name")
(starts-with? arg "value")
(starts-with? arg "placeholder")
(starts-with? arg "action")
(starts-with? arg "method")
(starts-with? arg "target")
(starts-with? arg "role")
(starts-with? arg "for")
(starts-with? arg "on")))
(do
(append! parts (str ":" arg))
(append! parts (serialize (nth args (inc i))))
(set! skip true)
(set! i (inc i)))
(do
(append! parts (aser-reserialize arg))
(set! i (inc i))))))
args)
(str "(" (join " " parts) ")"))))))))
(define
aser-fragment
:effects (render)
(fn
((children :as list) (env :as dict))
(let
((parts (list)))
(for-each
(fn
(c)
(let
((result (aser c env)))
(cond
(nil? result)
nil
(= (type-of result) "sx-expr")
(append! parts (sx-expr-source result))
(= (type-of result) "list")
(for-each
(fn
(item)
(when
(not (nil? item))
(if
(= (type-of item) "sx-expr")
(append! parts (sx-expr-source item))
(append! parts (aser-reserialize item)))))
result)
:else (append! parts (serialize result)))))
children)
(if
(empty? parts)
""
(if
(= (len parts) 1)
(make-sx-expr (first parts))
(make-sx-expr (str "(<> " (join " " parts) ")")))))))
(define
aser-call
:effects (render)
(fn
((name :as string) (args :as list) (env :as dict))
(let
((attr-parts (list)) (child-parts (list)) (skip false) (i 0))
(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
(= (type-of val) "sx-expr")
(append! attr-parts (sx-expr-source val))
(append! attr-parts (serialize val))))
(set! skip true)
(set! i (inc i)))
(let
((val (aser arg env)))
(when
(not (nil? val))
(cond
(= (type-of val) "sx-expr")
(append! child-parts (sx-expr-source val))
(= (type-of val) "list")
(for-each
(fn
(item)
(when
(not (nil? item))
(if
(= (type-of item) "sx-expr")
(append! child-parts (sx-expr-source item))
(append! child-parts (serialize item)))))
val)
:else (append! child-parts (serialize val))))
(set! i (inc i))))))
args)
(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)))
(make-sx-expr (str "(" (join " " parts) ")"))))))
(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)))
(for-each (fn (p) (env-bind! local p nil)) params)
(for-each
(fn
(arg)
(if
skip
(do (set! skip false) (set! i (inc i)))
(if
(and (= (type-of arg) "keyword") (< (inc i) (len args)))
(do
(env-bind!
local
(keyword-name arg)
(aser (nth args (inc i)) env))
(set! skip true)
(set! i (inc i)))
(do (append! children arg) (set! i (inc i))))))
args)
(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 (component-body comp) local))))
(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"
"context"
"emit!"
"emitted"))
(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)))
(define
aser-special
:effects (render)
(fn
((name :as string) (expr :as list) (env :as dict))
(let
((args (rest expr)))
(cond
(= name "if")
(if
(trampoline (eval-expr (first args) env))
(aser (nth args 1) env)
(if (> (len args) 2) (aser (nth args 2) env) nil))
(= 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))
(= name "cond")
(let
((branch (eval-cond args env)))
(if branch (aser branch env) nil))
(= name "case")
(let
((match-val (trampoline (eval-expr (first args) env)))
(clauses (rest args)))
(eval-case-aser match-val clauses env))
(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)
(or (= name "begin") (= name "do"))
(let
((result nil))
(for-each (fn (body) (set! result (aser body env))) args)
result)
(= name "and")
(let
((result true))
(some
(fn
(arg)
(set! result (trampoline (eval-expr arg env)))
(not result))
args)
result)
(= name "or")
(let
((result false))
(some
(fn
(arg)
(set! result (trampoline (eval-expr arg env)))
result)
args)
result)
(= name "map")
(let
((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env))))
(let
((results (map (fn (item) (if (lambda? f) (let ((local (env-extend (lambda-closure f)))) (env-bind! local (first (lambda-params f)) item) (aser (lambda-body f) local)) (cek-call f (list item)))) coll)))
(aser-fragment results env)))
(= 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))
(= 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))
(= name "defisland")
(do (trampoline (eval-expr expr env)) (serialize expr))
(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)
(= name "scope")
(let
((scope-name (trampoline (eval-expr (first args) env)))
(rest-args (rest args))
(scope-val nil)
(body-args nil))
(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))
(= 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)
(= name "context")
(let
((ctx-name (trampoline (eval-expr (first args) env)))
(default-val
(if
(>= (len args) 2)
(trampoline (eval-expr (nth args 1) env))
nil)))
(let
((val (scope-peek ctx-name)))
(if (nil? val) default-val val)))
(= name "emit!")
(let
((emit-name (trampoline (eval-expr (first args) env)))
(emit-val (trampoline (eval-expr (nth args 1) env))))
(scope-emit! emit-name emit-val)
nil)
(= name "emitted")
(let
((emit-name (trampoline (eval-expr (first args) env))))
(or (scope-peek emit-name) (list)))
:else (trampoline (eval-expr expr env))))))
(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)))))))
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (web adapter-sx))
Reference in New Issue View Git Blame Copy Permalink