From cfc697821fda76c379eb267f10c418fd16d3fb00 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 3 Apr 2026 20:16:26 +0000 Subject: [PATCH] Step 5.5 phase 3: transpile HTML renderer from SX spec Replaces 753 lines of hand-written sx_render.ml with 380 lines (17 transpiled functions from spec/render.sx + web/adapter-html.sx, plus native PREAMBLE and FIXUPS). Source of truth is now the SX spec files: - spec/render.sx: registries, helpers (parse-element-args, definition-form?, eval-cond, process-bindings, merge-spread-attrs, is-render-expr?) - web/adapter-html.sx: dispatch (render-to-html, render-list-to-html, dispatch-html-form, render-html-element, render-html-component, render-lambda-html, render-value-to-html) Native OCaml retained in PREAMBLE/FIXUPS for: - Tag registries (dual string list / value List) - Buffer-based escape_html_raw and render_attrs - expand_macro, try_catch, set_render_active platform functions - Forward refs for lake/marsh/island (web-specific) - setup_render_env, buffer renderer, streaming renderer New bootstrap: hosts/ocaml/bootstrap_render.py Transpiler: added eval-expr, expand-macro, try-catch, set-render-active!, scope-emitted to ml-runtime-names. 2598/2598 tests passing. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bootstrap_render.py | 480 +++++++++++++++++ hosts/ocaml/lib/sx_render.ml | 919 ++++++++++---------------------- hosts/ocaml/transpiler.sx | 5 + 3 files changed, 758 insertions(+), 646 deletions(-) create mode 100644 hosts/ocaml/bootstrap_render.py diff --git a/hosts/ocaml/bootstrap_render.py b/hosts/ocaml/bootstrap_render.py new file mode 100644 index 00000000..fc9ef4f2 --- /dev/null +++ b/hosts/ocaml/bootstrap_render.py @@ -0,0 +1,480 @@ +#!/usr/bin/env python3 +""" +Bootstrap the SX HTML renderer to native OCaml. + +Reads spec/render.sx (helpers) and web/adapter-html.sx (dispatch), +combines them, and transpiles to sx_render.ml. + +Performance-critical functions (escape_html, render_attrs) are provided +as native OCaml in the PREAMBLE. Web-specific renderers (lake, marsh, +island) are appended in FIXUPS. + +Usage: + python3 hosts/ocaml/bootstrap_render.py +""" +from __future__ import annotations + +import os +import sys + +_HERE = os.path.dirname(os.path.abspath(__file__)) +_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..")) +sys.path.insert(0, _PROJECT) + +from shared.sx.parser import parse_all, serialize +from shared.sx.types import Symbol, Keyword + + +def extract_defines(source: str) -> list[tuple[str, list]]: + """Parse .sx source, return list of (name, define-expr) for top-level defines.""" + exprs = parse_all(source) + defines = [] + for expr in exprs: + if isinstance(expr, list) and expr and isinstance(expr[0], Symbol): + if expr[0].name == "define": + name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1]) + defines.append((name, expr)) + return defines + + +def strip_type_annotations(expr): + """Recursively strip :as type annotations from param lists. + Transforms (name :as type) → name in function parameter positions.""" + if isinstance(expr, list): + # Check if this is a typed param: (name :as type) + if (len(expr) == 3 and isinstance(expr[0], Symbol) + and isinstance(expr[1], Keyword) and expr[1].name == "as"): + return expr[0] # just the name + + # Check for param list patterns — list where first element is a symbol + # and contains :as keywords + new = [] + for item in expr: + new.append(strip_type_annotations(item)) + return new + return expr + + +PREAMBLE = """\ +(* sx_render.ml — Auto-generated from spec/render.sx + web/adapter-html.sx *) +(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_render.py *) + +[@@@warning "-26-27"] + +open Sx_types +open Sx_runtime + +(* ====================================================================== *) +(* Platform bindings — native OCaml for performance and type access *) +(* ====================================================================== *) + +let eval_expr expr env = Sx_ref.eval_expr expr env +let cond_scheme_p = Sx_ref.cond_scheme_p + +(* Primitive wrappers needed as direct OCaml functions *) +let raw_html_content v = match v with RawHTML s -> String s | _ -> String "" +let make_raw_html v = match v with String s -> RawHTML s | _ -> Nil +let scope_emit v1 v2 = prim_call "scope-emit!" [v1; v2] +let init v = prim_call "init" [v] +let dict_has a b = prim_call "dict-has?" [a; b] +let dict_get a b = prim_call "dict-get" [a; b] +let is_component v = prim_call "component?" [v] +let is_island v = prim_call "island?" [v] +let is_macro v = prim_call "macro?" [v] +let is_lambda v = prim_call "lambda?" [v] +let is_nil v = prim_call "nil?" [v] + +(* Forward refs for web-specific renderers — set in FIXUPS or by caller *) +let render_html_lake_ref : (value -> value -> value) ref = ref (fun _ _ -> String "") +let render_html_marsh_ref : (value -> value -> value) ref = ref (fun _ _ -> String "") +let render_html_island_ref : (value -> value -> value -> value) ref = ref (fun _ _ _ -> String "") + +let render_html_lake args env = !render_html_lake_ref args env +let render_html_marsh args env = !render_html_marsh_ref args env +let render_html_island comp args env = !render_html_island_ref comp args env +let cek_call = Sx_ref.cek_call + +let trampoline v = match v with + | Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env) + | other -> other + +let expand_macro m args_val _env = match m with + | Macro mac -> + let args = match args_val with List l | ListRef { contents = l } -> l | _ -> [] in + let local = env_extend (Env mac.m_closure) in + let rec bind_params ps as' = match ps, as' with + | [], rest -> + (match mac.m_rest_param with + | Some rp -> ignore (env_bind local (String rp) (List rest)) + | None -> ()) + | p :: ps_rest, a :: as_rest -> + ignore (env_bind local p a); + bind_params ps_rest as_rest + | _ :: _, [] -> + List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps) + in + bind_params (List.map (fun p -> String p) mac.m_params) args; + Sx_ref.eval_expr mac.m_body local + | _ -> Nil + +(** try-catch: wraps a try body fn and catch handler fn. + Maps to OCaml exception handling. *) +let try_catch try_fn catch_fn = + try sx_call try_fn [] + with + | Eval_error msg -> sx_call catch_fn [String msg] + | e -> sx_call catch_fn [String (Printexc.to_string e)] + +(** set-render-active! — no-op on OCaml (always active). *) +let set_render_active_b _v = Nil + +(* ====================================================================== *) +(* Performance-critical: native Buffer-based HTML escaping *) +(* ====================================================================== *) + +(* ====================================================================== *) +(* Tag registries — native string lists for callers, value Lists for SX *) +(* ====================================================================== *) + +let boolean_attrs_set = [ + "async"; "autofocus"; "autoplay"; "checked"; "controls"; "default"; + "defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap"; + "loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open"; + "playsinline"; "readonly"; "required"; "reversed"; "selected" +] +let is_boolean_attr name = List.mem name boolean_attrs_set + +let html_tags_list = [ + "html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript"; + "header"; "nav"; "main"; "section"; "article"; "aside"; "footer"; + "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup"; + "div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr"; + "ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu"; "details"; "summary"; "dialog"; + "a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup"; + "mark"; "abbr"; "cite"; "code"; "kbd"; "samp"; "var"; "time"; "br"; "wbr"; + "table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col"; + "form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label"; + "fieldset"; "legend"; "datalist"; "output"; + "img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; + "svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse"; + "g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern"; + "linearGradient"; "radialGradient"; "stop"; "filter"; + "feGaussianBlur"; "feOffset"; "feBlend"; "feColorMatrix"; "feComposite"; + "feMerge"; "feMergeNode"; "feTurbulence"; "feComponentTransfer"; + "feFuncR"; "feFuncG"; "feFuncB"; "feFuncA"; "feDisplacementMap"; "feFlood"; + "feImage"; "feMorphology"; "feSpecularLighting"; "feDiffuseLighting"; + "fePointLight"; "feSpotLight"; "feDistantLight"; + "animate"; "animateTransform"; "foreignObject"; "template"; "slot" +] +let html_tags = html_tags_list (* callers expect string list *) +let html_tags_val = List (List.map (fun s -> String s) html_tags_list) + +let void_elements_list = [ + "area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input"; + "link"; "meta"; "param"; "source"; "track"; "wbr" +] +let void_elements = void_elements_list (* callers expect string list *) +let void_elements_val = List (List.map (fun s -> String s) void_elements_list) + +let boolean_attrs = boolean_attrs_set (* callers expect string list *) +let boolean_attrs_val = List (List.map (fun s -> String s) boolean_attrs_set) + +(* Native escape for internal use — returns raw OCaml string *) +let escape_html_raw s = + let buf = Buffer.create (String.length s) in + String.iter (function + | '&' -> Buffer.add_string buf "&" + | '<' -> Buffer.add_string buf "<" + | '>' -> Buffer.add_string buf ">" + | '"' -> Buffer.add_string buf """ + | c -> Buffer.add_char buf c) s; + Buffer.contents buf + +(* escape_html: native string -> string for callers *) +let escape_html = escape_html_raw + +(* escape_html_val / escape_attr_val — take a value, return String value (for transpiled code) *) +let escape_html_val v = + let s = match v with String s -> s | v -> value_to_string v in + String (escape_html_raw s) + +let escape_attr_val v = escape_html_val v + +(* ====================================================================== *) +(* Performance-critical: native attribute rendering *) +(* ====================================================================== *) + +let render_attrs attrs = match attrs with + | Dict d -> + let buf = Buffer.create 64 in + Hashtbl.iter (fun k v -> + if is_boolean_attr k then begin + if sx_truthy v then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k + end + end else if v <> Nil then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k; + Buffer.add_string buf "=\\""; + Buffer.add_string buf (escape_html_raw (value_to_string v)); + Buffer.add_char buf '"' + end) d; + String (Buffer.contents buf) + | _ -> String "" + +(* ====================================================================== *) +(* Forward ref — used by setup_render_env and buffer renderer *) +(* ====================================================================== *) + +let render_to_html_ref : (value -> value -> value) ref = + ref (fun _expr _env -> String "") + +(* scope-emitted is a prim alias *) +let scope_emitted name = prim_call "scope-emitted" [name] + +(* RENDER_HTML_FORMS — list of special form names handled by dispatch-html-form *) +let render_html_forms = List [ + String "if"; String "when"; String "cond"; String "case"; + String "let"; String "let*"; String "letrec"; + String "begin"; String "do"; + String "define"; String "defcomp"; String "defmacro"; String "defisland"; + String "defpage"; String "defhandler"; String "defquery"; String "defaction"; + String "defrelation"; String "deftype"; String "defeffect"; String "defstyle"; + String "map"; String "map-indexed"; String "filter"; String "for-each"; + String "scope"; String "provide" +] + +""" + + +FIXUPS = """ + +(* ====================================================================== *) +(* Wire up forward ref *) +(* ====================================================================== *) + +let () = render_to_html_ref := render_to_html + +(* ====================================================================== *) +(* Buffer-based streaming renderer — zero intermediate string allocation *) +(* ====================================================================== *) + +(** Escape HTML directly into a buffer. *) +let escape_html_buf buf s = + for i = 0 to String.length s - 1 do + match String.unsafe_get s i with + | '&' -> Buffer.add_string buf "&" + | '<' -> Buffer.add_string buf "<" + | '>' -> Buffer.add_string buf ">" + | '"' -> Buffer.add_string buf """ + | c -> Buffer.add_char buf c + done + +let render_attrs_buf buf attrs = + Hashtbl.iter (fun k v -> + if is_boolean_attr k then begin + if sx_truthy v then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k + end + end else if v <> Nil then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k; + Buffer.add_string buf "=\\""; + escape_html_buf buf (value_to_string v); + Buffer.add_char buf '"' + end) attrs + +(** Render to pre-allocated buffer — delegates to transpiled render_to_html + and extracts the string result. *) +let render_to_buf buf expr (env : env) = + match !render_to_html_ref expr (Env env) with + | String s -> Buffer.add_string buf s + | RawHTML s -> Buffer.add_string buf s + | v -> Buffer.add_string buf (value_to_str v) + +(** Public API: render to a pre-allocated buffer. *) +let render_to_buffer buf expr env = render_to_buf buf expr env + +(** Convenience: render to string. *) +let render_to_html_streaming expr (env : env) = + match !render_to_html_ref expr (Env env) with + | String s -> s + | RawHTML s -> s + | v -> value_to_str v + +(** The native OCaml renderer — used by sx_server when SX adapter isn't loaded. *) +let do_render_to_html expr (env_val : value) = + match !render_to_html_ref expr env_val with + | String s -> s + | RawHTML s -> s + | v -> value_to_str v + +(** Render via the SX adapter (render-to-html from adapter-html.sx). + Falls back to the native ref if the SX adapter isn't loaded. *) +let sx_render_to_html (render_env : env) expr (eval_env : env) = + if Sx_types.env_has render_env "render-to-html" then + let fn = Sx_types.env_get render_env "render-to-html" in + let result = Sx_ref.cek_call fn (List [expr; Env eval_env]) in + match result with String s -> s | RawHTML s -> s | _ -> value_to_str result + else + do_render_to_html expr (Env eval_env) + + +(* ====================================================================== *) +(* Setup — bind render primitives in an env and wire up the ref *) +(* ====================================================================== *) + +let is_html_tag name = List.mem name html_tags_list +let is_void name = List.mem name void_elements_list + +(* escape_html_str: takes raw OCaml string, returns raw string — for callers *) +let escape_html_str = escape_html_raw + +let setup_render_env (raw_env : env) = + let env = Env raw_env in + let bind name fn = + ignore (Sx_types.env_bind raw_env name (NativeFn (name, fn))) + in + + bind "render-html" (fun args -> + match args with + | [String src] -> + let exprs = Sx_parser.parse_all src in + let expr = match exprs with + | [e] -> e + | [] -> Nil + | _ -> List (Symbol "do" :: exprs) + in + !render_to_html_ref expr env + | [expr] -> + !render_to_html_ref expr env + | [expr; Env e] -> + !render_to_html_ref expr (Env e) + | _ -> String ""); + + bind "render-to-html" (fun args -> + match args with + | [String src] -> + let exprs = Sx_parser.parse_all src in + let expr = match exprs with + | [e] -> e + | [] -> Nil + | _ -> List (Symbol "do" :: exprs) + in + !render_to_html_ref expr env + | [expr] -> + !render_to_html_ref expr env + | [expr; Env e] -> + !render_to_html_ref expr (Env e) + | _ -> String "") +""" + + +def main(): + import tempfile + from shared.sx.ocaml_sync import OcamlSync + + # Load the transpiler into OCaml kernel + bridge = OcamlSync() + transpiler_path = os.path.join(_HERE, "transpiler.sx") + bridge.load(transpiler_path) + + # Read source files + spec_path = os.path.join(_PROJECT, "spec", "render.sx") + adapter_path = os.path.join(_PROJECT, "web", "adapter-html.sx") + + with open(spec_path) as f: + spec_src = f.read() + with open(adapter_path) as f: + adapter_src = f.read() + + spec_defines = extract_defines(spec_src) + adapter_defines = extract_defines(adapter_src) + + # Skip: performance-critical (native in PREAMBLE) and web-specific (in FIXUPS) + skip = { + # Native in PREAMBLE for performance + "escape-html", "escape-attr", "render-attrs", + # OCaml can't have uppercase let bindings; registries need dual types + "RENDER_HTML_FORMS", + "HTML_TAGS", "VOID_ELEMENTS", "BOOLEAN_ATTRS", + # Web-specific — provided as stubs or in FIXUPS + "render-html-lake", "render-html-marsh", + "render-html-island", "serialize-island-state", + } + + # Combine: spec helpers first (dependency order), then adapter dispatch + all_defines = [] + for name, expr in spec_defines: + if name not in skip: + all_defines.append((name, expr)) + for name, expr in adapter_defines: + if name not in skip: + all_defines.append((name, expr)) + + # Deduplicate — keep last definition for each name + seen = {} + for i, (n, e) in enumerate(all_defines): + seen[n] = i + all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i] + + # Strip type annotations from params: (name :as type) → name + all_defines = [(name, strip_type_annotations(expr)) for name, expr in all_defines] + + print(f"Transpiling {len(all_defines)} defines from render spec + adapter...", + file=sys.stderr) + + # Build the defines list and known names for the transpiler + defines_list = [[name, expr] for name, expr in all_defines] + known_names = [name for name, _ in all_defines] + # Add PREAMBLE-provided names so transpiler emits them as direct calls + known_names.extend([ + "escape-html", "escape-attr", "render-attrs", + "eval-expr", "trampoline", "expand-macro", + "try-catch", "set-render-active!", + "render-html-lake", "render-html-marsh", + "render-html-island", "serialize-island-state", + "scope-emitted", + "RENDER_HTML_FORMS", + "cond-scheme?", + ]) + + # Serialize to temp file, load into kernel + defines_sx = serialize(defines_list) + known_sx = serialize(known_names) + with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp: + tmp.write(f"(define _defines '{defines_sx})\n") + tmp.write(f"(define _known_defines '{known_sx})\n") + tmp_path = tmp.name + try: + bridge.load(tmp_path) + finally: + os.unlink(tmp_path) + + # Add renames for uppercase constants and dual-form registries + bridge.eval('(dict-set! ml-renames "RENDER_HTML_FORMS" "render_html_forms")') + bridge.eval('(dict-set! ml-renames "HTML_TAGS" "html_tags_val")') + bridge.eval('(dict-set! ml-renames "VOID_ELEMENTS" "void_elements_val")') + bridge.eval('(dict-set! ml-renames "BOOLEAN_ATTRS" "boolean_attrs_val")') + bridge.eval('(dict-set! ml-renames "escape-html" "escape_html_val")') + bridge.eval('(dict-set! ml-renames "escape-attr" "escape_attr_val")') + + # Call ml-translate-file — emits as single let rec block + result = bridge.eval("(ml-translate-file _defines)") + + bridge.stop() + + output = PREAMBLE + "\n(* === Transpiled from render spec + adapter === *)\n" + result + "\n" + FIXUPS + + # Write output + output_path = os.path.join(_HERE, "lib", "sx_render.ml") + with open(output_path, "w") as f: + f.write(output) + print(f"Wrote {len(output)} bytes to {output_path}", file=sys.stderr) + print(f" {len(all_defines)} functions transpiled", file=sys.stderr) + + +if __name__ == "__main__": + main() diff --git a/hosts/ocaml/lib/sx_render.ml b/hosts/ocaml/lib/sx_render.ml index bcdb7662..7063d55e 100644 --- a/hosts/ocaml/lib/sx_render.ml +++ b/hosts/ocaml/lib/sx_render.ml @@ -1,60 +1,128 @@ -(** HTML renderer for SX values. +(* sx_render.ml — Auto-generated from spec/render.sx + web/adapter-html.sx *) +(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_render.py *) - Extracted from run_tests.ml — renders an SX expression tree to an - HTML string, expanding components and macros along the way. - - Depends on [Sx_ref.eval_expr] for evaluating sub-expressions - during rendering (keyword arg values, conditionals, etc.). *) +[@@@warning "-26-27"] open Sx_types +open Sx_runtime (* ====================================================================== *) -(* Tag / attribute registries *) +(* Platform bindings — native OCaml for performance and type access *) (* ====================================================================== *) -let html_tags = [ - "html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript"; - "header"; "nav"; "main"; "section"; "article"; "aside"; "footer"; - "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup"; - "div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr"; - "ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu"; - "a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup"; - "mark"; "del"; "ins"; "q"; "cite"; "dfn"; "abbr"; "code"; "var"; "samp"; - "kbd"; "data"; "time"; "ruby"; "rt"; "rp"; "bdi"; "bdo"; "wbr"; "br"; - "table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col"; - "form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label"; - "fieldset"; "legend"; "datalist"; "output"; "progress"; "meter"; - "details"; "summary"; "dialog"; - "img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; "embed"; "object"; "param"; - "svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse"; - "g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern"; - "linearGradient"; "radialGradient"; "stop"; "filter"; "feBlend"; "feFlood"; - "feGaussianBlur"; "feOffset"; "feMerge"; "feMergeNode"; "feComposite"; - "template"; "slot"; -] +let eval_expr expr env = Sx_ref.eval_expr expr env +let cond_scheme_p = Sx_ref.cond_scheme_p -let void_elements = [ - "area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input"; - "link"; "meta"; "param"; "source"; "track"; "wbr" -] +(* Primitive wrappers needed as direct OCaml functions *) +let raw_html_content v = match v with RawHTML s -> String s | _ -> String "" +let make_raw_html v = match v with String s -> RawHTML s | _ -> Nil +let scope_emit v1 v2 = prim_call "scope-emit!" [v1; v2] +let init v = prim_call "init" [v] +let dict_has a b = prim_call "dict-has?" [a; b] +let dict_get a b = prim_call "dict-get" [a; b] +let is_component v = prim_call "component?" [v] +let is_island v = prim_call "island?" [v] +let is_macro v = prim_call "macro?" [v] +let is_lambda v = prim_call "lambda?" [v] +let is_nil v = prim_call "nil?" [v] -let boolean_attrs = [ +(* Forward refs for web-specific renderers — set in FIXUPS or by caller *) +let render_html_lake_ref : (value -> value -> value) ref = ref (fun _ _ -> String "") +let render_html_marsh_ref : (value -> value -> value) ref = ref (fun _ _ -> String "") +let render_html_island_ref : (value -> value -> value -> value) ref = ref (fun _ _ _ -> String "") + +let render_html_lake args env = !render_html_lake_ref args env +let render_html_marsh args env = !render_html_marsh_ref args env +let render_html_island comp args env = !render_html_island_ref comp args env +let cek_call = Sx_ref.cek_call + +let trampoline v = match v with + | Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env) + | other -> other + +let expand_macro m args_val _env = match m with + | Macro mac -> + let args = match args_val with List l | ListRef { contents = l } -> l | _ -> [] in + let local = env_extend (Env mac.m_closure) in + let rec bind_params ps as' = match ps, as' with + | [], rest -> + (match mac.m_rest_param with + | Some rp -> ignore (env_bind local (String rp) (List rest)) + | None -> ()) + | p :: ps_rest, a :: as_rest -> + ignore (env_bind local p a); + bind_params ps_rest as_rest + | _ :: _, [] -> + List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps) + in + bind_params (List.map (fun p -> String p) mac.m_params) args; + Sx_ref.eval_expr mac.m_body local + | _ -> Nil + +(** try-catch: wraps a try body fn and catch handler fn. + Maps to OCaml exception handling. *) +let try_catch try_fn catch_fn = + try sx_call try_fn [] + with + | Eval_error msg -> sx_call catch_fn [String msg] + | e -> sx_call catch_fn [String (Printexc.to_string e)] + +(** set-render-active! — no-op on OCaml (always active). *) +let set_render_active_b _v = Nil + +(* ====================================================================== *) +(* Performance-critical: native Buffer-based HTML escaping *) +(* ====================================================================== *) + +(* ====================================================================== *) +(* Tag registries — native string lists for callers, value Lists for SX *) +(* ====================================================================== *) + +let boolean_attrs_set = [ "async"; "autofocus"; "autoplay"; "checked"; "controls"; "default"; "defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap"; "loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open"; "playsinline"; "readonly"; "required"; "reversed"; "selected" ] +let is_boolean_attr name = List.mem name boolean_attrs_set -let is_html_tag name = List.mem name html_tags -let is_void name = List.mem name void_elements -let is_boolean_attr name = List.mem name boolean_attrs +let html_tags_list = [ + "html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript"; + "header"; "nav"; "main"; "section"; "article"; "aside"; "footer"; + "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup"; + "div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr"; + "ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu"; "details"; "summary"; "dialog"; + "a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup"; + "mark"; "abbr"; "cite"; "code"; "kbd"; "samp"; "var"; "time"; "br"; "wbr"; + "table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col"; + "form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label"; + "fieldset"; "legend"; "datalist"; "output"; + "img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; + "svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse"; + "g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern"; + "linearGradient"; "radialGradient"; "stop"; "filter"; + "feGaussianBlur"; "feOffset"; "feBlend"; "feColorMatrix"; "feComposite"; + "feMerge"; "feMergeNode"; "feTurbulence"; "feComponentTransfer"; + "feFuncR"; "feFuncG"; "feFuncB"; "feFuncA"; "feDisplacementMap"; "feFlood"; + "feImage"; "feMorphology"; "feSpecularLighting"; "feDiffuseLighting"; + "fePointLight"; "feSpotLight"; "feDistantLight"; + "animate"; "animateTransform"; "foreignObject"; "template"; "slot" +] +let html_tags = html_tags_list (* callers expect string list *) +let html_tags_val = List (List.map (fun s -> String s) html_tags_list) +let void_elements_list = [ + "area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input"; + "link"; "meta"; "param"; "source"; "track"; "wbr" +] +let void_elements = void_elements_list (* callers expect string list *) +let void_elements_val = List (List.map (fun s -> String s) void_elements_list) -(* ====================================================================== *) -(* HTML escaping *) -(* ====================================================================== *) +let boolean_attrs = boolean_attrs_set (* callers expect string list *) +let boolean_attrs_val = List (List.map (fun s -> String s) boolean_attrs_set) -let escape_html s = +(* Native escape for internal use — returns raw OCaml string *) +let escape_html_raw s = let buf = Buffer.create (String.length s) in String.iter (function | '&' -> Buffer.add_string buf "&" @@ -64,360 +132,138 @@ let escape_html s = | c -> Buffer.add_char buf c) s; Buffer.contents buf +(* escape_html: native string -> string for callers *) +let escape_html = escape_html_raw + +(* escape_html_val / escape_attr_val — take a value, return String value (for transpiled code) *) +let escape_html_val v = + let s = match v with String s -> s | v -> value_to_string v in + String (escape_html_raw s) + +let escape_attr_val v = escape_html_val v (* ====================================================================== *) -(* Attribute rendering *) +(* Performance-critical: native attribute rendering *) (* ====================================================================== *) -let render_attrs attrs = - let buf = Buffer.create 64 in - Hashtbl.iter (fun k v -> - if is_boolean_attr k then begin - if sx_truthy v then begin +let render_attrs attrs = match attrs with + | Dict d -> + let buf = Buffer.create 64 in + Hashtbl.iter (fun k v -> + if is_boolean_attr k then begin + if sx_truthy v then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k + end + end else if v <> Nil then begin Buffer.add_char buf ' '; - Buffer.add_string buf k - end - end else if not (is_nil v) then begin - Buffer.add_char buf ' '; - Buffer.add_string buf k; - Buffer.add_string buf "=\""; - Buffer.add_string buf (escape_html (value_to_string v)); - Buffer.add_char buf '"' - end) attrs; - Buffer.contents buf + Buffer.add_string buf k; + Buffer.add_string buf "=\""; + Buffer.add_string buf (escape_html_raw (value_to_string v)); + Buffer.add_char buf '"' + end) d; + String (Buffer.contents buf) + | _ -> String "" + +(* ====================================================================== *) +(* Forward ref — used by setup_render_env and buffer renderer *) +(* ====================================================================== *) + +let render_to_html_ref : (value -> value -> value) ref = + ref (fun _expr _env -> String "") + +(* scope-emitted is a prim alias *) +let scope_emitted name = prim_call "scope-emitted" [name] + +(* RENDER_HTML_FORMS — list of special form names handled by dispatch-html-form *) +let render_html_forms = List [ + String "if"; String "when"; String "cond"; String "case"; + String "let"; String "let*"; String "letrec"; + String "begin"; String "do"; + String "define"; String "defcomp"; String "defmacro"; String "defisland"; + String "defpage"; String "defhandler"; String "defquery"; String "defaction"; + String "defrelation"; String "deftype"; String "defeffect"; String "defstyle"; + String "map"; String "map-indexed"; String "filter"; String "for-each"; + String "scope"; String "provide" +] + + +(* === Transpiled from render spec + adapter === *) +(* *definition-form-extensions* *) +let rec _definition_form_extensions_ = + (List []) + +(* definition-form? *) +and definition_form_p name = + (let _or = (prim_call "=" [name; (String "define")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "defcomp")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "defisland")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "defmacro")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "defstyle")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "deftype")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "defeffect")]) in if sx_truthy _or then _or else (prim_call "contains?" [_definition_form_extensions_; name])))))))) + +(* parse-element-args *) +and parse_element_args args env = + (let attrs = (Dict (Hashtbl.create 0)) in let children = ref ((List [])) in (let () = ignore ((List.fold_left (fun state arg -> (let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [(get (state) ((String "i")))])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [(get (state) ((String "i")))]); (len (args))]))) then (let val' = (trampoline ((eval_expr ((nth (args) ((prim_call "inc" [(get (state) ((String "i")))])))) (env)))) in (let () = ignore ((sx_dict_set_b attrs (keyword_name (arg)) val')) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [(get (state) ((String "i")))])]))) else (let () = ignore ((children := sx_append_b !children arg; Nil)) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [(get (state) ((String "i")))])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false); Dict _d) (sx_to_list args))) in (List [attrs; !children]))) + +(* eval-cond *) +and eval_cond clauses env = + (if sx_truthy ((cond_scheme_p (clauses))) then (eval_cond_scheme (clauses) (env)) else (eval_cond_clojure (clauses) (env))) + +(* eval-cond-scheme *) +and eval_cond_scheme clauses env = + (if sx_truthy ((empty_p (clauses))) then Nil else (let clause = (first (clauses)) in let test = (first (clause)) in let body = (nth (clause) ((Number 1.0))) in (if sx_truthy ((is_else_clause (test))) then body else (if sx_truthy ((trampoline ((eval_expr (test) (env))))) then body else (eval_cond_scheme ((rest (clauses))) (env)))))) + +(* eval-cond-clojure *) +and eval_cond_clojure clauses env = + (if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then Nil else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in (if sx_truthy ((is_else_clause (test))) then body else (if sx_truthy ((trampoline ((eval_expr (test) (env))))) then body else (eval_cond_clojure ((prim_call "slice" [clauses; (Number 2.0)])) (env)))))) + +(* process-bindings *) +and process_bindings bindings env = + (let local = (env_extend (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (pair)); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call ">=" [(len (pair)); (Number 2.0)]))) then (let name = (if sx_truthy ((prim_call "=" [(type_of ((first (pair)))); (String "symbol")])) then (symbol_name ((first (pair)))) else (String (sx_str [(first (pair))]))) in (env_bind local (sx_to_string name) (trampoline ((eval_expr ((nth (pair) ((Number 1.0)))) (local)))))) else Nil))) (sx_to_list bindings); Nil)) in local)) + +(* is-render-expr? *) +and is_render_expr_p expr = + (if sx_truthy ((let _or = (Bool (not (sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")]))))) in if sx_truthy _or then _or else (empty_p (expr)))) then (Bool false) else (let h = (first (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (h)); (String "symbol")])))))) then (Bool false) else (let n = (symbol_name (h)) in (let _or = (prim_call "=" [n; (String "<>")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [n; (String "raw!")]) in if sx_truthy _or then _or else (let _or = (prim_call "starts-with?" [n; (String "~")]) in if sx_truthy _or then _or else (let _or = (prim_call "starts-with?" [n; (String "html:")]) in if sx_truthy _or then _or else (let _or = (prim_call "contains?" [html_tags_val; n]) in if sx_truthy _or then _or else (let _and = (prim_call ">" [(prim_call "index-of" [n; (String "-")]); (Number 0.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">" [(len (expr)); (Number 1.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((nth (expr) ((Number 1.0))))); (String "keyword")])))))))))))) + +(* merge-spread-attrs *) +and merge_spread_attrs target spread_dict = + (List.iter (fun key -> ignore ((let val' = (dict_get (spread_dict) (key)) in (if sx_truthy ((prim_call "=" [key; (String "class")])) then (let existing = (dict_get (target) ((String "class"))) in (sx_dict_set_b target (String "class") (if sx_truthy ((let _and = existing in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [existing; (String "")]))))))) then (String (sx_str [existing; (String " "); val'])) else val'))) else (if sx_truthy ((prim_call "=" [key; (String "style")])) then (let existing = (dict_get (target) ((String "style"))) in (sx_dict_set_b target (String "style") (if sx_truthy ((let _and = existing in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [existing; (String "")]))))))) then (String (sx_str [existing; (String ";"); val'])) else val'))) else (sx_dict_set_b target key val')))))) (sx_to_list (prim_call "keys" [spread_dict])); Nil) + +(* render-to-html *) +and render_to_html expr env = + (let () = ignore ((set_render_active_b ((Bool true)))) in (let _match_val = (type_of (expr)) in (if _match_val = (String "nil") then (String "") else (if _match_val = (String "string") then (escape_html_val (expr)) else (if _match_val = (String "number") then (String (sx_str [expr])) else (if _match_val = (String "boolean") then (if sx_truthy (expr) then (String "true") else (String "false")) else (if _match_val = (String "list") then (if sx_truthy ((empty_p (expr))) then (String "") else (render_list_to_html (expr) (env))) else (if _match_val = (String "symbol") then (render_value_to_html ((trampoline ((eval_expr (expr) (env))))) (env)) else (if _match_val = (String "keyword") then (escape_html_val ((keyword_name (expr)))) else (if _match_val = (String "raw-html") then (raw_html_content (expr)) else (if _match_val = (String "spread") then (let () = ignore ((scope_emit ((String "element-attrs")) ((spread_attrs (expr))))) in (String "")) else (if _match_val = (String "thunk") then (render_to_html ((thunk_expr (expr))) ((thunk_env (expr)))) else (render_value_to_html ((trampoline ((eval_expr (expr) (env))))) (env)))))))))))))) + +(* render-value-to-html *) +and render_value_to_html val' env = + (let _match_val = (type_of (val')) in (if _match_val = (String "nil") then (String "") else (if _match_val = (String "string") then (escape_html_val (val')) else (if _match_val = (String "number") then (String (sx_str [val'])) else (if _match_val = (String "boolean") then (if sx_truthy (val') then (String "true") else (String "false")) else (if _match_val = (String "list") then (render_list_to_html (val') (env)) else (if _match_val = (String "raw-html") then (raw_html_content (val')) else (if _match_val = (String "spread") then (let () = ignore ((scope_emit ((String "element-attrs")) ((spread_attrs (val'))))) in (String "")) else (if _match_val = (String "thunk") then (render_to_html ((thunk_expr (val'))) ((thunk_env (val')))) else (escape_html_val ((String (sx_str [val']))))))))))))) + +(* render-html-form? *) +and render_html_form_p name = + (prim_call "contains?" [render_html_forms; name]) + +(* render-list-to-html *) +and render_list_to_html expr env = + (if sx_truthy ((empty_p (expr))) then (String "") else (let head = (first (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])))))) then (prim_call "join" [(String ""); (List (List.map (fun x -> (render_value_to_html (x) (env))) (sx_to_list expr)))]) else (let name = (symbol_name (head)) in let args = (rest (expr)) in (if sx_truthy ((prim_call "=" [name; (String "<>")])) then (prim_call "join" [(String ""); (List (List.map (fun x -> (render_to_html (x) (env))) (sx_to_list args)))]) else (if sx_truthy ((prim_call "=" [name; (String "raw!")])) then (prim_call "join" [(String ""); (List (List.map (fun x -> (String (sx_str [(trampoline ((eval_expr (x) (env))))]))) (sx_to_list args)))]) else (if sx_truthy ((prim_call "=" [name; (String "lake")])) then (render_html_lake (args) (env)) else (if sx_truthy ((prim_call "=" [name; (String "marsh")])) then (render_html_marsh (args) (env)) else (if sx_truthy ((prim_call "=" [name; (String "error-boundary")])) then (let has_fallback = (prim_call ">" [(len (args)); (Number 1.0)]) in (let body_exprs = (if sx_truthy (has_fallback) then (rest (args)) else args) in let fallback_expr = (if sx_truthy (has_fallback) then (first (args)) else Nil) in (String (sx_str [(String "
"); (try_catch ((NativeFn ("\206\187", fun _args -> (fun () -> (prim_call "join" [(String ""); (List (List.map (fun x -> (render_to_html (x) (env))) (sx_to_list body_exprs)))])) ()))) ((NativeFn ("\206\187", fun _args -> match _args with [err] -> (fun err -> (let safe_err = (prim_call "replace" [(prim_call "replace" [(String (sx_str [err])); (String "<"); (String "<")]); (String ">"); (String ">")]) in (if sx_truthy ((let _and = fallback_expr in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (fallback_expr)))))))) then (try_catch ((NativeFn ("\206\187", fun _args -> (fun () -> (render_to_html ((List [(trampoline ((eval_expr (fallback_expr) (env)))); err; Nil])) (env))) ()))) ((NativeFn ("\206\187", fun _args -> match _args with [e2] -> (fun e2 -> (String (sx_str [(String "
Render error: "); safe_err; (String "
")]))) e2 | _ -> Nil)))) else (String (sx_str [(String "
Render error: "); safe_err; (String "
")]))))) err | _ -> Nil)))); (String "
")])))) else (if sx_truthy ((let _or = (prim_call "=" [name; (String "portal")]) in if sx_truthy _or then _or else (prim_call "=" [name; (String "promise-delayed")]))) then (prim_call "join" [(String ""); (List (List.map (fun x -> (render_to_html (x) (env))) (sx_to_list args)))]) else (if sx_truthy ((prim_call "contains?" [html_tags_val; name])) then (render_html_element (name) (args) (env)) else (if sx_truthy ((let _and = (prim_call "starts-with?" [name; (String "~")]) in if not (sx_truthy _and) then _and else (let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_island ((env_get (env) (name))))))) then (render_html_island ((env_get (env) (name))) (args) (env)) else (if sx_truthy ((prim_call "starts-with?" [name; (String "~")])) then (let val' = (env_get (env) (name)) in (if sx_truthy ((is_component (val'))) then (render_html_component (val') (args) (env)) else (if sx_truthy ((is_macro (val'))) then (render_to_html ((expand_macro (val') (args) (env))) (env)) else (String (sx_str [(String "")]))))) else (if sx_truthy ((render_html_form_p (name))) then (dispatch_html_form (name) (expr) (env)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (render_to_html ((expand_macro ((env_get (env) (name))) (args) (env))) (env)) else (render_value_to_html ((trampoline ((eval_expr (expr) (env))))) (env))))))))))))))))) + +(* dispatch-html-form *) +and dispatch_html_form name expr env = + (if sx_truthy ((prim_call "=" [name; (String "if")])) then (let cond_val = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in (if sx_truthy (cond_val) then (render_to_html ((nth (expr) ((Number 2.0)))) (env)) else (if sx_truthy ((prim_call ">" [(len (expr)); (Number 3.0)])) then (render_to_html ((nth (expr) ((Number 3.0)))) (env)) else (String "")))) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (if sx_truthy ((Bool (not (sx_truthy ((trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env))))))))) then (String "") else (if sx_truthy ((prim_call "=" [(len (expr)); (Number 3.0)])) then (render_to_html ((nth (expr) ((Number 2.0)))) (env)) else (prim_call "join" [(String ""); (List (List.map (fun i -> (render_to_html ((nth (expr) (i))) (env))) (sx_to_list (prim_call "range" [(Number 2.0); (len (expr))]))))]))) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (let branch = (eval_cond ((rest (expr))) (env)) in (if sx_truthy (branch) then (render_to_html (branch) (env)) else (String ""))) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (render_to_html ((trampoline ((eval_expr (expr) (env))))) (env)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (let bindings = (nth (expr) ((Number 1.0))) in let body = (prim_call "slice" [expr; (Number 2.0)]) in let local = (env_extend (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((let pname = (if sx_truthy ((prim_call "=" [(type_of ((first (pair)))); (String "symbol")])) then (symbol_name ((first (pair)))) else (String (sx_str [(first (pair))]))) in (env_bind local (sx_to_string pname) Nil)))) (sx_to_list bindings); Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((let pname = (if sx_truthy ((prim_call "=" [(type_of ((first (pair)))); (String "symbol")])) then (symbol_name ((first (pair)))) else (String (sx_str [(first (pair))]))) in (env_set local (sx_to_string pname) (trampoline ((eval_expr ((nth (pair) ((Number 1.0)))) (local)))))))) (sx_to_list bindings); Nil)) in (let () = ignore ((if sx_truthy ((prim_call ">" [(len (body)); (Number 1.0)])) then (List.iter (fun e -> ignore ((trampoline ((eval_expr (e) (local)))))) (sx_to_list (init (body))); Nil) else Nil)) in (render_to_html ((last (body))) (local)))))) else (if sx_truthy ((let _or = (prim_call "=" [name; (String "let")]) in if sx_truthy _or then _or else (prim_call "=" [name; (String "let*")]))) then (let local = (process_bindings ((nth (expr) ((Number 1.0)))) (env)) in (if sx_truthy ((prim_call "=" [(len (expr)); (Number 3.0)])) then (render_to_html ((nth (expr) ((Number 2.0)))) (local)) else (prim_call "join" [(String ""); (List (List.map (fun i -> (render_to_html ((nth (expr) (i))) (local))) (sx_to_list (prim_call "range" [(Number 2.0); (len (expr))]))))]))) else (if sx_truthy ((let _or = (prim_call "=" [name; (String "begin")]) in if sx_truthy _or then _or else (prim_call "=" [name; (String "do")]))) then (if sx_truthy ((prim_call "=" [(len (expr)); (Number 2.0)])) then (render_to_html ((nth (expr) ((Number 1.0)))) (env)) else (prim_call "join" [(String ""); (List (List.map (fun i -> (render_to_html ((nth (expr) (i))) (env))) (sx_to_list (prim_call "range" [(Number 1.0); (len (expr))]))))])) else (if sx_truthy ((definition_form_p (name))) then (let () = ignore ((trampoline ((eval_expr (expr) (env))))) in (String "")) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (let f = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in let coll = (trampoline ((eval_expr ((nth (expr) ((Number 2.0)))) (env)))) in (prim_call "join" [(String ""); (List (List.map (fun item -> (if sx_truthy ((is_lambda (f))) then (render_lambda_html (f) ((List [item])) (env)) else (render_to_html ((sx_apply f (List [item]))) (env)))) (sx_to_list coll)))])) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (let f = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in let coll = (trampoline ((eval_expr ((nth (expr) ((Number 2.0)))) (env)))) in (prim_call "join" [(String ""); (List (List.mapi (fun i item -> let i = Number (float_of_int i) in (if sx_truthy ((is_lambda (f))) then (render_lambda_html (f) ((List [i; item])) (env)) else (render_to_html ((sx_apply f (List [i; item]))) (env)))) (sx_to_list coll)))])) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (render_to_html ((trampoline ((eval_expr (expr) (env))))) (env)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (let f = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in let coll = (trampoline ((eval_expr ((nth (expr) ((Number 2.0)))) (env)))) in (prim_call "join" [(String ""); (List (List.map (fun item -> (if sx_truthy ((is_lambda (f))) then (render_lambda_html (f) ((List [item])) (env)) else (render_to_html ((sx_apply f (List [item]))) (env)))) (sx_to_list coll)))])) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (let scope_name = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in let rest_args = (prim_call "slice" [expr; (Number 2.0)]) in let scope_val = ref (Nil) in let body_exprs = ref (Nil) in (let () = ignore ((if sx_truthy ((let _and = (prim_call ">=" [(len (rest_args)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((first (rest_args)))); (String "value")])))) then (let () = ignore ((scope_val := (trampoline ((eval_expr ((nth (rest_args) ((Number 1.0)))) (env)))); Nil)) in (body_exprs := (prim_call "slice" [rest_args; (Number 2.0)]); Nil)) else (body_exprs := rest_args; Nil))) in (let () = ignore ((scope_push (scope_name) (!scope_val))) in (let result' = (if sx_truthy ((prim_call "=" [(len (!body_exprs)); (Number 1.0)])) then (render_to_html ((first (!body_exprs))) (env)) else (prim_call "join" [(String ""); (List (List.map (fun e -> (render_to_html (e) (env))) (sx_to_list !body_exprs)))])) in (let () = ignore ((scope_pop (scope_name))) in result'))))) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (let prov_name = (trampoline ((eval_expr ((nth (expr) ((Number 1.0)))) (env)))) in let prov_val = (trampoline ((eval_expr ((nth (expr) ((Number 2.0)))) (env)))) in let body_start = (Number 3.0) in let body_count = (prim_call "-" [(len (expr)); (Number 3.0)]) in (let () = ignore ((scope_push (prov_name) (prov_val))) in (let result' = (if sx_truthy ((prim_call "=" [body_count; (Number 1.0)])) then (render_to_html ((nth (expr) (body_start))) (env)) else (prim_call "join" [(String ""); (List (List.map (fun i -> (render_to_html ((nth (expr) (i))) (env))) (sx_to_list (prim_call "range" [body_start; (prim_call "+" [body_start; body_count])]))))])) in (let () = ignore ((scope_pop (prov_name))) in result')))) else (render_value_to_html ((trampoline ((eval_expr (expr) (env))))) (env)))))))))))))))) + +(* render-lambda-html *) +and render_lambda_html f args env = + (let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [i; p] -> (fun i p -> (env_bind local (sx_to_string p) (nth (args) (i)))) i p | _ -> Nil))) ((lambda_params (f))))) in (render_to_html ((lambda_body (f))) (local)))) + +(* render-html-component *) +and render_html_component comp args env = + (let kwargs = (Dict (Hashtbl.create 0)) in let children = ref ((List [])) in (let () = ignore ((List.fold_left (fun state arg -> (let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [(get (state) ((String "i")))])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [(get (state) ((String "i")))]); (len (args))]))) then (let val' = (trampoline ((eval_expr ((nth (args) ((prim_call "inc" [(get (state) ((String "i")))])))) (env)))) in (let () = ignore ((sx_dict_set_b kwargs (keyword_name (arg)) val')) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [(get (state) ((String "i")))])]))) else (let () = ignore ((children := sx_append_b !children arg; Nil)) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [(get (state) ((String "i")))])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false); Dict _d) (sx_to_list args))) in (let local = (env_merge ((component_closure (comp))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (if sx_truthy ((dict_has (kwargs) (p))) then (dict_get (kwargs) (p)) else Nil)))) (sx_to_list (component_params (comp))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (comp))) then (env_bind local (sx_to_string (String "children")) (make_raw_html ((prim_call "join" [(String ""); (List (List.map (fun c -> (render_to_html (c) (env))) (sx_to_list !children)))])))) else Nil)) in (render_to_html ((component_body (comp))) (local))))))) + +(* render-html-element *) +and render_html_element tag args env = + (let parsed = (parse_element_args (args) (env)) in let attrs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let is_void = (prim_call "contains?" [void_elements_val; tag]) in (if sx_truthy (is_void) then (String (sx_str [(String "<"); tag; (render_attrs (attrs)); (String " />")])) else (let () = ignore ((scope_push ((String "element-attrs")) (Nil))) in (let content = (prim_call "join" [(String ""); (List (List.map (fun c -> (render_to_html (c) (env))) (sx_to_list children)))]) in (let () = ignore ((List.iter (fun spread_dict -> ignore ((merge_spread_attrs (attrs) (spread_dict)))) (sx_to_list (scope_emitted ((String "element-attrs")))); Nil)) in (let () = ignore ((scope_pop ((String "element-attrs")))) in (String (sx_str [(String "<"); tag; (render_attrs (attrs)); (String ">"); content; (String "")])))))))) + (* ====================================================================== *) -(* HTML renderer *) +(* Wire up forward ref *) (* ====================================================================== *) -(* Forward ref — resolved at setup time *) -let render_to_html_ref : (value -> env -> string) ref = - ref (fun _expr _env -> "") - -let render_to_html expr env = !render_to_html_ref expr env - -(** Render via the SX adapter (render-to-html from adapter-html.sx). - Falls back to the native ref if the SX adapter isn't loaded. *) -let sx_render_to_html render_env expr eval_env = - if env_has render_env "render-to-html" then - let fn = env_get render_env "render-to-html" in - let result = Sx_ref.cek_call fn (List [expr; Env eval_env]) in - match result with String s -> s | RawHTML s -> s | _ -> Sx_runtime.value_to_str result - else - render_to_html expr eval_env - -let render_children children env = - String.concat "" (List.map (fun c -> render_to_html c env) children) - -(** Parse keyword attrs and positional children from an element call's args. - Attrs are evaluated; children are returned UNEVALUATED for render dispatch. *) -let parse_element_args args env = - let attrs = Hashtbl.create 8 in - let children = ref [] in - let skip = ref false in - let len = List.length args in - List.iteri (fun idx arg -> - if !skip then skip := false - else match arg with - | Keyword k when idx + 1 < len -> - let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in - Hashtbl.replace attrs k v; - skip := true - | Spread pairs -> - List.iter (fun (k, v) -> Hashtbl.replace attrs k v) pairs - | _ -> - children := arg :: !children - ) args; - (attrs, List.rev !children) - -let render_html_element tag args env = - let (attrs, children) = parse_element_args args env in - let attr_str = render_attrs attrs in - if is_void tag then - "<" ^ tag ^ attr_str ^ " />" - else - let content = String.concat "" - (List.map (fun c -> render_to_html c env) children) in - "<" ^ tag ^ attr_str ^ ">" ^ content ^ "" - -let render_component comp args env = - match comp with - | Component c -> - let kwargs = Hashtbl.create 8 in - let children_exprs = ref [] in - let skip = ref false in - let len = List.length args in - List.iteri (fun idx arg -> - if !skip then skip := false - else match arg with - | Keyword k when idx + 1 < len -> - let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in - Hashtbl.replace kwargs k v; - skip := true - | _ -> - children_exprs := arg :: !children_exprs - ) args; - let children = List.rev !children_exprs in - let local = env_merge c.c_closure env in - List.iter (fun p -> - let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in - ignore (env_bind local p v) - ) c.c_params; - if c.c_has_children then begin - let rendered_children = String.concat "" - (List.map (fun c -> render_to_html c env) children) in - ignore (env_bind local "children" (RawHTML rendered_children)) - end; - render_to_html c.c_body local - | _ -> "" - -let expand_macro (m : macro) args _env = - let local = env_extend m.m_closure in - let params = m.m_params in - let rec bind_params ps as' = - match ps, as' with - | [], rest -> - (match m.m_rest_param with - | Some rp -> ignore (env_bind local rp (List rest)) - | None -> ()) - | p :: ps_rest, a :: as_rest -> - ignore (env_bind local p a); - bind_params ps_rest as_rest - | _ :: _, [] -> - List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps) - in - bind_params params args; - Sx_ref.eval_expr m.m_body (Env local) - -let rec do_render_to_html (expr : value) (env : env) : string = - match expr with - | Nil -> "" - | Bool true -> "true" - | Bool false -> "false" - | Number n -> - if Float.is_integer n then string_of_int (int_of_float n) - else Printf.sprintf "%g" n - | String s -> escape_html s - | Keyword k -> escape_html k - | RawHTML s -> s - | SxExpr s -> s - | Symbol s -> - let v = Sx_ref.eval_expr (Symbol s) (Env env) in - do_render_to_html v env - | List [] | ListRef { contents = [] } -> "" - | List (head :: args) | ListRef { contents = head :: args } -> - render_list_to_html head args env - | _ -> - let v = Sx_ref.eval_expr expr (Env env) in - do_render_to_html v env - -and render_list_to_html head args env = - match head with - | Symbol "<>" -> - render_children args env - | Symbol "raw!" -> - (* Inject pre-rendered HTML without escaping *) - let v = Sx_ref.eval_expr (List.hd args) (Env env) in - (match v with - | String s | RawHTML s -> s - | _ -> value_to_string v) - | Symbol tag when is_html_tag tag -> - render_html_element tag args env - | Symbol "if" -> - let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in - if sx_truthy cond_val then - (if List.length args > 1 then do_render_to_html (List.nth args 1) env else "") - else - (if List.length args > 2 then do_render_to_html (List.nth args 2) env else "") - | Symbol "when" -> - let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in - if sx_truthy cond_val then - String.concat "" (List.map (fun e -> do_render_to_html e env) (List.tl args)) - else "" - | Symbol "cond" -> - render_cond args env - | Symbol "case" -> - let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in - do_render_to_html v env - | Symbol ("let" | "let*") -> - render_let args env - | Symbol ("begin" | "do") -> - let rec go = function - | [] -> "" - | [last] -> do_render_to_html last env - | e :: rest -> - ignore (Sx_ref.eval_expr e (Env env)); - go rest - in go args - | Symbol ("define" | "defcomp" | "defmacro" | "defisland") -> - ignore (Sx_ref.eval_expr (List (head :: args)) (Env env)); - "" - | Symbol "map" -> - render_map args env false - | Symbol "map-indexed" -> - render_map args env true - | Symbol "filter" -> - let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in - do_render_to_html v env - | Symbol "for-each" -> - render_for_each args env - | Symbol name -> - (try - let v = env_get env name in - (match v with - | Component c when c.c_affinity = "client" -> "" (* skip client-only *) - | Component _ -> render_component v args env - | Island _i -> - let call_sx = "(" ^ String.concat " " (List.map (fun v -> - match v with - | Symbol s -> s | Keyword k -> ":" ^ k | String s -> "\"" ^ s ^ "\"" - | _ -> Sx_runtime.value_to_str v - ) (Symbol name :: args)) ^ ")" in - Printf.sprintf "%s" _i.i_name call_sx - | Macro m -> - let expanded = expand_macro m args env in - do_render_to_html expanded env - | _ -> - let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in - do_render_to_html result env) - with Eval_error _ -> - (* Primitive or special form — not in env, delegate to CEK *) - (try - let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in - do_render_to_html result env - with Eval_error _ -> "")) - | _ -> - let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in - do_render_to_html result env - -and render_cond args env = - let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in - let is_scheme = List.for_all (fun a -> match as_list a with - | Some items when List.length items = 2 -> true - | _ -> false) args - in - if is_scheme then begin - let rec go = function - | [] -> "" - | clause :: rest -> - (match as_list clause with - | Some [test; body] -> - let is_else = match test with - | Keyword "else" -> true - | Symbol "else" | Symbol ":else" -> true - | _ -> false - in - if is_else then do_render_to_html body env - else - let v = Sx_ref.eval_expr test (Env env) in - if sx_truthy v then do_render_to_html body env - else go rest - | _ -> "") - in go args - end else begin - let rec go = function - | [] -> "" - | [_] -> "" - | test :: body :: rest -> - let is_else = match test with - | Keyword "else" -> true - | Symbol "else" | Symbol ":else" -> true - | _ -> false - in - if is_else then do_render_to_html body env - else - let v = Sx_ref.eval_expr test (Env env) in - if sx_truthy v then do_render_to_html body env - else go rest - in go args - end - -and render_let args env = - let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in - let bindings_expr = List.hd args in - let body = List.tl args in - let local = env_extend env in - let bindings = match as_list bindings_expr with Some l -> l | None -> [] in - let is_scheme = match bindings with - | (List _ :: _) | (ListRef _ :: _) -> true - | _ -> false - in - if is_scheme then - List.iter (fun b -> - match as_list b with - | Some [Symbol name; expr] | Some [String name; expr] -> - let v = Sx_ref.eval_expr expr (Env local) in - ignore (env_bind local name v) - | _ -> () - ) bindings - else begin - let rec go = function - | [] -> () - | (Symbol name) :: expr :: rest | (String name) :: expr :: rest -> - let v = Sx_ref.eval_expr expr (Env local) in - ignore (env_bind local name v); - go rest - | _ -> () - in go bindings - end; - let rec render_body = function - | [] -> "" - | [last] -> do_render_to_html last local - | e :: rest -> - ignore (Sx_ref.eval_expr e (Env local)); - render_body rest - in render_body body - -and render_map args env indexed = - let (fn_val, coll_val) = match args with - | [a; b] -> - let va = Sx_ref.eval_expr a (Env env) in - let vb = Sx_ref.eval_expr b (Env env) in - (match va, vb with - | (Lambda _ | NativeFn _), _ -> (va, vb) - | _, (Lambda _ | NativeFn _) -> (vb, va) - | _ -> (va, vb)) - | _ -> (Nil, Nil) - in - let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in - String.concat "" (List.mapi (fun i item -> - let call_args = if indexed then [Number (float_of_int i); item] else [item] in - match fn_val with - | Lambda l -> - let local = env_extend l.l_closure in - List.iter2 (fun p a -> ignore (env_bind local p a)) - l.l_params call_args; - do_render_to_html l.l_body local - | _ -> - let result = Sx_runtime.sx_call fn_val call_args in - do_render_to_html result env - ) items) - -and render_for_each args env = - let (fn_val, coll_val) = match args with - | [a; b] -> - let va = Sx_ref.eval_expr a (Env env) in - let vb = Sx_ref.eval_expr b (Env env) in - (match va, vb with - | (Lambda _ | NativeFn _), _ -> (va, vb) - | _, (Lambda _ | NativeFn _) -> (vb, va) - | _ -> (va, vb)) - | _ -> (Nil, Nil) - in - let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in - String.concat "" (List.map (fun item -> - match fn_val with - | Lambda l -> - let local = env_extend l.l_closure in - List.iter2 (fun p a -> ignore (env_bind local p a)) - l.l_params [item]; - do_render_to_html l.l_body local - | _ -> - let result = Sx_runtime.sx_call fn_val [item] in - do_render_to_html result env - ) items) - +let () = render_to_html_ref := render_to_html (* ====================================================================== *) (* Buffer-based streaming renderer — zero intermediate string allocation *) @@ -434,7 +280,6 @@ let escape_html_buf buf s = | c -> Buffer.add_char buf c done -(** Render attributes directly into a buffer. *) let render_attrs_buf buf attrs = Hashtbl.iter (fun k v -> if is_boolean_attr k then begin @@ -442,7 +287,7 @@ let render_attrs_buf buf attrs = Buffer.add_char buf ' '; Buffer.add_string buf k end - end else if not (is_nil v) then begin + end else if v <> Nil then begin Buffer.add_char buf ' '; Buffer.add_string buf k; Buffer.add_string buf "=\""; @@ -450,274 +295,56 @@ let render_attrs_buf buf attrs = Buffer.add_char buf '"' end) attrs -(** Buffer-based render_to_html — writes directly, no intermediate strings. *) -let rec render_to_buf buf (expr : value) (env : env) : unit = - match expr with - | Nil -> () - | Bool true -> Buffer.add_string buf "true" - | Bool false -> Buffer.add_string buf "false" - | Number n -> - if Float.is_integer n then Buffer.add_string buf (string_of_int (int_of_float n)) - else Buffer.add_string buf (Printf.sprintf "%g" n) - | String s -> escape_html_buf buf s - | Keyword k -> escape_html_buf buf k +(** Render to pre-allocated buffer — delegates to transpiled render_to_html + and extracts the string result. *) +let render_to_buf buf expr (env : env) = + match !render_to_html_ref expr (Env env) with + | String s -> Buffer.add_string buf s | RawHTML s -> Buffer.add_string buf s - | SxExpr s -> Buffer.add_string buf s - | Symbol s -> - let v = Sx_ref.eval_expr (Symbol s) (Env env) in - render_to_buf buf v env - | List [] | ListRef { contents = [] } -> () - | List (head :: args) | ListRef { contents = head :: args } -> - render_list_buf buf head args env - | _ -> - let v = Sx_ref.eval_expr expr (Env env) in - render_to_buf buf v env - -and render_list_buf buf head args env = - match head with - | Symbol "<>" -> - List.iter (fun c -> render_to_buf buf c env) args - | Symbol "raw!" -> - let v = Sx_ref.eval_expr (List.hd args) (Env env) in - (match v with - | String s | RawHTML s -> Buffer.add_string buf s - | _ -> Buffer.add_string buf (value_to_string v)) - | Symbol tag when is_html_tag tag -> - render_element_buf buf tag args env - | Symbol "if" -> - let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in - if sx_truthy cond_val then - (if List.length args > 1 then render_to_buf buf (List.nth args 1) env) - else - (if List.length args > 2 then render_to_buf buf (List.nth args 2) env) - | Symbol "when" -> - let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in - if sx_truthy cond_val then - List.iter (fun e -> render_to_buf buf e env) (List.tl args) - | Symbol "cond" -> - render_cond_buf buf args env - | Symbol "case" -> - let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in - render_to_buf buf v env - | Symbol ("let" | "let*") -> - render_let_buf buf args env - | Symbol ("begin" | "do") -> - let rec go = function - | [] -> () - | [last] -> render_to_buf buf last env - | e :: rest -> ignore (Sx_ref.eval_expr e (Env env)); go rest - in go args - | Symbol ("define" | "defcomp" | "defmacro" | "defisland") -> - ignore (Sx_ref.eval_expr (List (head :: args)) (Env env)) - | Symbol "map" -> render_map_buf buf args env false - | Symbol "map-indexed" -> render_map_buf buf args env true - | Symbol "filter" -> - let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in - render_to_buf buf v env - | Symbol "for-each" -> render_for_each_buf buf args env - | Symbol name -> - (try - let v = env_get env name in - (match v with - | Component c when c.c_affinity = "client" -> () - | Component _ -> render_component_buf buf v args env - | Island _i -> - (* Islands are client-rendered — emit placeholder with SX call - expression so the client can hydrate from source. *) - let call_sx = "(" ^ String.concat " " (List.map (fun v -> - match v with - | Symbol s -> s | Keyword k -> ":" ^ k | String s -> "\"" ^ s ^ "\"" - | _ -> Sx_runtime.value_to_str v - ) (Symbol name :: args)) ^ ")" in - Buffer.add_string buf (Printf.sprintf "%s" - _i.i_name call_sx) - | Macro m -> - let expanded = expand_macro m args env in - render_to_buf buf expanded env - | _ -> - let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in - render_to_buf buf result env) - with Eval_error msg -> - (* Unknown symbol/component — skip silently during SSR. - The client will render from page-sx. *) - Printf.eprintf "[ssr-skip] %s\n%!" msg) - | _ -> - (try - let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in - render_to_buf buf result env - with Eval_error msg -> - Printf.eprintf "[ssr-skip] %s\n%!" msg) - -and render_element_buf buf tag args env = - let (attrs, children) = parse_element_args args env in - Buffer.add_char buf '<'; - Buffer.add_string buf tag; - render_attrs_buf buf attrs; - if is_void tag then - Buffer.add_string buf " />" - else begin - Buffer.add_char buf '>'; - List.iter (fun c -> render_to_buf buf c env) children; - Buffer.add_string buf "' - end - -and render_component_buf buf comp args env = - match comp with - | Component c -> - let kwargs = Hashtbl.create 8 in - let children_exprs = ref [] in - let skip = ref false in - let len = List.length args in - List.iteri (fun idx arg -> - if !skip then skip := false - else match arg with - | Keyword k when idx + 1 < len -> - let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in - Hashtbl.replace kwargs k v; - skip := true - | _ -> children_exprs := arg :: !children_exprs - ) args; - let children = List.rev !children_exprs in - let local = env_merge c.c_closure env in - List.iter (fun p -> - let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in - ignore (env_bind local p v) - ) c.c_params; - if c.c_has_children then begin - let child_buf = Buffer.create 256 in - List.iter (fun c -> render_to_buf child_buf c env) children; - ignore (env_bind local "children" (RawHTML (Buffer.contents child_buf))) - end; - render_to_buf buf c.c_body local - | _ -> () - -and render_cond_buf buf args env = - let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in - let is_scheme = List.for_all (fun a -> match as_list a with - | Some items when List.length items = 2 -> true | _ -> false) args in - if is_scheme then begin - let rec go = function - | [] -> () - | clause :: rest -> - (match as_list clause with - | Some [test; body] -> - let is_else = match test with - | Keyword "else" | Symbol "else" | Symbol ":else" -> true | _ -> false in - if is_else then render_to_buf buf body env - else let v = Sx_ref.eval_expr test (Env env) in - if sx_truthy v then render_to_buf buf body env else go rest - | _ -> ()) - in go args - end else begin - let rec go = function - | [] -> () | [_] -> () - | test :: body :: rest -> - let is_else = match test with - | Keyword "else" | Symbol "else" | Symbol ":else" -> true | _ -> false in - if is_else then render_to_buf buf body env - else let v = Sx_ref.eval_expr test (Env env) in - if sx_truthy v then render_to_buf buf body env else go rest - in go args - end - -and render_let_buf buf args env = - let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in - let bindings_expr = List.hd args in - let body = List.tl args in - let local = env_extend env in - let bindings = match as_list bindings_expr with Some l -> l | None -> [] in - let is_scheme = match bindings with (List _ :: _) | (ListRef _ :: _) -> true | _ -> false in - if is_scheme then - List.iter (fun b -> - match as_list b with - | Some [Symbol name; expr] | Some [String name; expr] -> - let v = Sx_ref.eval_expr expr (Env local) in - ignore (env_bind local name v) - | _ -> () - ) bindings - else begin - let rec go = function - | [] -> () - | (Symbol name) :: expr :: rest | (String name) :: expr :: rest -> - let v = Sx_ref.eval_expr expr (Env local) in - ignore (env_bind local name v); go rest - | _ -> () - in go bindings - end; - let rec render_body = function - | [] -> () - | [last] -> render_to_buf buf last local - | e :: rest -> ignore (Sx_ref.eval_expr e (Env local)); render_body rest - in render_body body - -and render_map_buf buf args env indexed = - let (fn_val, coll_val) = match args with - | [a; b] -> - let va = Sx_ref.eval_expr a (Env env) in - let vb = Sx_ref.eval_expr b (Env env) in - (match va, vb with - | (Lambda _ | NativeFn _), _ -> (va, vb) - | _, (Lambda _ | NativeFn _) -> (vb, va) - | _ -> (va, vb)) - | _ -> (Nil, Nil) - in - let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in - List.iteri (fun i item -> - let call_args = if indexed then [Number (float_of_int i); item] else [item] in - match fn_val with - | Lambda l -> - let local = env_extend l.l_closure in - List.iter2 (fun p a -> ignore (env_bind local p a)) l.l_params call_args; - render_to_buf buf l.l_body local - | _ -> - let result = Sx_runtime.sx_call fn_val call_args in - render_to_buf buf result env - ) items - -and render_for_each_buf buf args env = - let (fn_val, coll_val) = match args with - | [a; b] -> - let va = Sx_ref.eval_expr a (Env env) in - let vb = Sx_ref.eval_expr b (Env env) in - (match va, vb with - | (Lambda _ | NativeFn _), _ -> (va, vb) - | _, (Lambda _ | NativeFn _) -> (vb, va) - | _ -> (va, vb)) - | _ -> (Nil, Nil) - in - let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in - List.iter (fun item -> - match fn_val with - | Lambda l -> - let local = env_extend l.l_closure in - List.iter2 (fun p a -> ignore (env_bind local p a)) l.l_params [item]; - render_to_buf buf l.l_body local - | _ -> - let result = Sx_runtime.sx_call fn_val [item] in - render_to_buf buf result env - ) items + | v -> Buffer.add_string buf (value_to_str v) (** Public API: render to a pre-allocated buffer. *) let render_to_buffer buf expr env = render_to_buf buf expr env -(** Convenience: render to string using the buffer renderer. *) -let render_to_html_streaming expr env = - let buf = Buffer.create 65536 in - render_to_buf buf expr env; - Buffer.contents buf +(** Convenience: render to string. *) +let render_to_html_streaming expr (env : env) = + match !render_to_html_ref expr (Env env) with + | String s -> s + | RawHTML s -> s + | v -> value_to_str v + +(** The native OCaml renderer — used by sx_server when SX adapter isn't loaded. *) +let do_render_to_html expr (env_val : value) = + match !render_to_html_ref expr env_val with + | String s -> s + | RawHTML s -> s + | v -> value_to_str v + +(** Render via the SX adapter (render-to-html from adapter-html.sx). + Falls back to the native ref if the SX adapter isn't loaded. *) +let sx_render_to_html (render_env : env) expr (eval_env : env) = + if Sx_types.env_has render_env "render-to-html" then + let fn = Sx_types.env_get render_env "render-to-html" in + let result = Sx_ref.cek_call fn (List [expr; Env eval_env]) in + match result with String s -> s | RawHTML s -> s | _ -> value_to_str result + else + do_render_to_html expr (Env eval_env) (* ====================================================================== *) (* Setup — bind render primitives in an env and wire up the ref *) (* ====================================================================== *) -let setup_render_env env = - render_to_html_ref := do_render_to_html; +let is_html_tag name = List.mem name html_tags_list +let is_void name = List.mem name void_elements_list +(* escape_html_str: takes raw OCaml string, returns raw string — for callers *) +let escape_html_str = escape_html_raw + +let setup_render_env (raw_env : env) = + let env = Env raw_env in let bind name fn = - ignore (env_bind env name (NativeFn (name, fn))) + ignore (Sx_types.env_bind raw_env name (NativeFn (name, fn))) in bind "render-html" (fun args -> @@ -729,11 +356,11 @@ let setup_render_env env = | [] -> Nil | _ -> List (Symbol "do" :: exprs) in - String (render_to_html expr env) + !render_to_html_ref expr env | [expr] -> - String (render_to_html expr env) + !render_to_html_ref expr env | [expr; Env e] -> - String (render_to_html expr e) + !render_to_html_ref expr (Env e) | _ -> String ""); bind "render-to-html" (fun args -> @@ -745,9 +372,9 @@ let setup_render_env env = | [] -> Nil | _ -> List (Symbol "do" :: exprs) in - String (render_to_html expr env) + !render_to_html_ref expr env | [expr] -> - String (render_to_html expr env) + !render_to_html_ref expr env | [expr; Env e] -> - String (render_to_html expr e) + !render_to_html_ref expr (Env e) | _ -> String "") diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index c7bf8ece..c25dd3a6 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -262,6 +262,11 @@ "parse-comp-params" "parse-macro-params" "parse-keyword-args" + "eval-expr" + "expand-macro" + "try-catch" + "set-render-active!" + "scope-emitted" "jit-try-call")) (define