SX renderer: adapter-html.sx as sole renderer, conditions, pattern matching
Evaluator: conditions/restarts, pattern matching, render-trace support. adapter-html.sx: full SX-defined HTML renderer replacing native OCaml. spec/render.sx: updated render mode helpers. sx_browser.ml: use SX render-to-html instead of native. sx_ref.ml: evaluator updates for conditions + match. Bootstrap + transpiler updates for new forms. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -407,7 +407,7 @@ let () =
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.render_to_html expr env
|
||||
Sx_render.sx_render_to_html env expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
|
||||
@@ -259,7 +259,14 @@ let setup_env () =
|
||||
(* Load eval-rules *)
|
||||
(try load_sx_file e (Filename.concat spec_dir "eval-rules.sx")
|
||||
with exn -> Printf.eprintf "[mcp] Warning: eval-rules.sx load failed: %s\n%!" (Printexc.to_string exn));
|
||||
Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules loaded\n%!";
|
||||
(* Load render pipeline — native OCaml renderer + HTML tag bindings *)
|
||||
Sx_render.setup_render_env e;
|
||||
List.iter (fun tag ->
|
||||
ignore (Sx_types.env_bind e tag
|
||||
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
||||
) Sx_render.html_tags;
|
||||
ignore (Sx_types.env_bind e "island?" (NativeFn ("island?", fun args -> match args with [Island _] -> Bool true | _ -> Bool false)));
|
||||
Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules + render loaded\n%!";
|
||||
env := e
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
@@ -277,7 +284,9 @@ let parse_file path =
|
||||
List exprs
|
||||
|
||||
let parse_path_str s =
|
||||
(* Parse SX path string: "(0 3 2)" or "0 3 2" → SX list of numbers *)
|
||||
(* Parse SX path string: "(0 3 2)" or "(0,3,2)" or "0 3 2" → SX list of numbers.
|
||||
Commas are unquote in SX, so strip them before parsing. *)
|
||||
let s = String.map (fun c -> if c = ',' then ' ' else c) s in
|
||||
let exprs = Sx_parser.parse_all s in
|
||||
match exprs with
|
||||
| [List items] ->
|
||||
@@ -1375,10 +1384,65 @@ let rec handle_tool name args =
|
||||
) Nil exprs in
|
||||
text_result (Sx_runtime.value_to_str result)
|
||||
|
||||
| "sx_guard" ->
|
||||
let expr_str = args |> member "expr" |> to_string in
|
||||
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
||||
let e = !env in
|
||||
(match file with
|
||||
| Some f -> (try load_sx_file e f with _ -> ())
|
||||
| None -> ());
|
||||
let exprs = Sx_parser.parse_all expr_str in
|
||||
let conditions = ref [] in
|
||||
(* Evaluate with error recovery — catch Eval_error, log it, return placeholder *)
|
||||
let result = ref Nil in
|
||||
(try
|
||||
result := List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr (Env e)
|
||||
) Nil exprs
|
||||
with Eval_error msg ->
|
||||
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
||||
conditions := enhanced :: !conditions;
|
||||
result := String ("<error: " ^ msg ^ ">"));
|
||||
let cond_lines = match !conditions with
|
||||
| [] -> ""
|
||||
| cs -> "\n\nConditions signaled:\n" ^
|
||||
String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in
|
||||
text_result (Sx_runtime.value_to_str !result ^ cond_lines)
|
||||
|
||||
| "sx_render_trace" ->
|
||||
let expr_str = args |> member "expr" |> to_string in
|
||||
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
||||
let e = !env in
|
||||
(match file with
|
||||
| Some f -> (try load_sx_file e f with _ -> ())
|
||||
| None -> ());
|
||||
let exprs = Sx_parser.parse_all expr_str in
|
||||
let expr = match exprs with [e] -> e | _ -> List (Symbol "do" :: exprs) in
|
||||
let trace = Buffer.create 2048 in
|
||||
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
|
||||
let expr_str = truncate (Sx_runtime.value_to_str expr) 60 in
|
||||
let kind = match expr with
|
||||
| Nil -> "nil" | Bool _ -> "bool" | Number _ -> "number"
|
||||
| String _ -> "string" | Symbol _ -> "symbol" | Keyword _ -> "keyword"
|
||||
| RawHTML _ -> "raw-html"
|
||||
| List (Symbol s :: _) | ListRef { contents = Symbol s :: _ } ->
|
||||
if List.mem s Sx_render.html_tags then "element:" ^ s
|
||||
else if List.mem s ["if";"when";"cond";"case";"let";"let*";"do";"begin";"map";"filter";"define";"defcomp"] then "form:" ^ s
|
||||
else "call:" ^ s
|
||||
| List _ -> "list" | _ -> "other" in
|
||||
Buffer.add_string trace (Printf.sprintf "→ %s %s\n" kind expr_str);
|
||||
let result = (try
|
||||
Sx_render.sx_render_to_html e expr e
|
||||
with Sx_types.Eval_error msg -> "ERROR: " ^ Sx_ref.enhance_error_with_trace msg) in
|
||||
let result_str = truncate result 60 in
|
||||
Buffer.add_string trace (Printf.sprintf "← %s\n" result_str);
|
||||
text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace))
|
||||
|
||||
| "sx_trace" ->
|
||||
let expr_str = args |> member "expr" |> to_string in
|
||||
let max_steps = (try args |> member "max_steps" |> to_int with _ -> 200) in
|
||||
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
||||
let components_only = (try args |> member "components_only" |> to_bool with _ -> false) in
|
||||
let e = !env in
|
||||
(match file with
|
||||
| Some f -> (try load_sx_file e f with _ -> ())
|
||||
@@ -1389,6 +1453,29 @@ let rec handle_tool name args =
|
||||
let steps = Buffer.create 2048 in
|
||||
let step_count = ref 0 in
|
||||
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
|
||||
(* Track comp-trace depth for component-only mode *)
|
||||
let comp_depth = ref 0 in
|
||||
let prev_comp_depth = ref 0 in
|
||||
let get_frame_type kont = match kont with
|
||||
| List (CekFrame f :: _) -> f.cf_type
|
||||
| List (Dict d :: _) ->
|
||||
(match Hashtbl.find_opt d "type" with Some (String s) -> s | _ -> "?")
|
||||
| _ -> "done" in
|
||||
let count_comp_trace kont =
|
||||
let n = ref 0 in
|
||||
let k = ref kont in
|
||||
(try while true do
|
||||
(match !k with
|
||||
| List (CekFrame f :: rest) ->
|
||||
if f.cf_type = "comp-trace" then incr n;
|
||||
k := List rest
|
||||
| List (Dict d :: rest) ->
|
||||
(match Hashtbl.find_opt d "type" with
|
||||
| Some (String "comp-trace") -> incr n | _ -> ());
|
||||
k := List rest
|
||||
| _ -> raise Exit)
|
||||
done with Exit -> ());
|
||||
!n in
|
||||
(try
|
||||
while !step_count < max_steps do
|
||||
let s = !state in
|
||||
@@ -1396,44 +1483,56 @@ let rec handle_tool name args =
|
||||
| CekState cs ->
|
||||
incr step_count;
|
||||
let n = !step_count in
|
||||
if cs.cs_phase = "eval" then begin
|
||||
let ctrl = cs.cs_control in
|
||||
(match ctrl with
|
||||
| Symbol sym_name ->
|
||||
let resolved = (try
|
||||
let v = Sx_ref.eval_expr ctrl cs.cs_env in
|
||||
truncate (Sx_runtime.value_to_str v) 60
|
||||
with _ -> "???") in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved)
|
||||
| List (hd :: _) ->
|
||||
let head_str = truncate (Sx_runtime.value_to_str hd) 30 in
|
||||
let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d CALL %s\n" n ctrl_str);
|
||||
ignore head_str
|
||||
| _ ->
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d LITERAL %s\n" n
|
||||
(truncate (Sx_runtime.value_to_str ctrl) 60)))
|
||||
if components_only then begin
|
||||
let depth = count_comp_trace cs.cs_kont in
|
||||
(if depth > !prev_comp_depth then begin
|
||||
let indent = String.make (depth * 2) ' ' in
|
||||
let ft = get_frame_type cs.cs_kont in
|
||||
let name = (match cs.cs_kont with
|
||||
| List (CekFrame f :: _) when f.cf_type = "comp-trace" ->
|
||||
(match f.cf_name with String s -> s | _ -> "?")
|
||||
| _ -> "?") in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%s→ ENTER ~%s\n" indent name);
|
||||
ignore ft
|
||||
end else if depth < !prev_comp_depth then begin
|
||||
let indent = String.make ((depth + 1) * 2) ' ' in
|
||||
let val_str = if cs.cs_phase = "continue"
|
||||
then truncate (Sx_runtime.value_to_str cs.cs_value) 60
|
||||
else "..." in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%s← EXIT → %s\n" indent val_str)
|
||||
end);
|
||||
prev_comp_depth := depth
|
||||
end else begin
|
||||
(* continue phase *)
|
||||
let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in
|
||||
let kont = cs.cs_kont in
|
||||
let frame_type = match kont with
|
||||
| List (Dict d :: _) ->
|
||||
(match Hashtbl.find_opt d "type" with
|
||||
| Some (String s) -> s | _ -> "?")
|
||||
| List (CekState ks :: _) ->
|
||||
(match ks.cs_control with
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "type" with
|
||||
| Some (String s) -> s | _ -> "?")
|
||||
| _ -> "?")
|
||||
| _ -> "done" in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d RETURN %s → %s\n" n val_str frame_type)
|
||||
if cs.cs_phase = "eval" then begin
|
||||
let ctrl = cs.cs_control in
|
||||
(match ctrl with
|
||||
| Symbol sym_name ->
|
||||
let resolved = (try
|
||||
let v = Sx_ref.eval_expr ctrl cs.cs_env in
|
||||
truncate (Sx_runtime.value_to_str v) 60
|
||||
with _ -> "???") in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved)
|
||||
| List (hd :: _) ->
|
||||
let head_str = truncate (Sx_runtime.value_to_str hd) 30 in
|
||||
let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d CALL %s\n" n ctrl_str);
|
||||
ignore head_str
|
||||
| _ ->
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d LITERAL %s\n" n
|
||||
(truncate (Sx_runtime.value_to_str ctrl) 60)))
|
||||
end else begin
|
||||
let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in
|
||||
let ft = get_frame_type cs.cs_kont in
|
||||
Buffer.add_string steps
|
||||
(Printf.sprintf "%3d RETURN %s → %s\n" n val_str ft)
|
||||
end
|
||||
end;
|
||||
ignore comp_depth;
|
||||
(match Sx_ref.cek_terminal_p s with
|
||||
| Bool true -> raise Exit
|
||||
| _ -> ());
|
||||
@@ -1443,7 +1542,8 @@ let rec handle_tool name args =
|
||||
with
|
||||
| Exit -> ()
|
||||
| Eval_error msg ->
|
||||
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" msg)
|
||||
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
||||
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" enhanced)
|
||||
| exn ->
|
||||
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" (Printexc.to_string exn)));
|
||||
let final_val = (match !state with
|
||||
@@ -1714,10 +1814,17 @@ let tool_definitions = `List [
|
||||
[file_prop; path_prop; ("wrapper", `Assoc [("type", `String "string"); ("description", `String "Wrapper with _ placeholder")])] ["file"; "path"; "wrapper"];
|
||||
tool "sx_eval" "Evaluate an SX expression. Environment has parser + tree-tools + primitives."
|
||||
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")])] ["expr"];
|
||||
tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Useful for debugging."
|
||||
tool "sx_guard" "Evaluate with error recovery. Catches errors, shows component trace, and continues. Returns result + any conditions signaled."
|
||||
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate with error recovery")]);
|
||||
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
|
||||
tool "sx_render_trace" "Render an SX expression to HTML with full dispatch tracing. Shows which render path each sub-expression takes."
|
||||
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to render with tracing")]);
|
||||
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
|
||||
tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Set components_only=true for component entry/exit only."
|
||||
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to trace")]);
|
||||
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
|
||||
("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")])] ["expr"];
|
||||
("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")]);
|
||||
("components_only", `Assoc [("type", `String "boolean"); ("description", `String "Show only component entry/exit events (default: false)")])] ["expr"];
|
||||
tool "sx_explain" "Explain SX evaluation rules. Pass a form name (if, let, map, ...) or category (literal, special-form, higher-order, ...)."
|
||||
[("name", `Assoc [("type", `String "string"); ("description", `String "Form name or category to explain")])] ["name"];
|
||||
tool "sx_deps" "Dependency analysis for a component or file. Shows all referenced symbols and where they're defined."
|
||||
|
||||
@@ -292,10 +292,15 @@ let make_test_env () =
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] ->
|
||||
(match e with
|
||||
| Dict _ -> Printf.eprintf "[EVAL-EXPR] env is Dict! expr=%s\n%!" (Sx_runtime.value_to_str expr)
|
||||
| Nil -> Printf.eprintf "[EVAL-EXPR] env is Nil! expr=%s\n%!" (Sx_runtime.value_to_str expr)
|
||||
| _ -> ());
|
||||
let ue = Sx_runtime.unwrap_env e in
|
||||
eval_expr expr (Env ue)
|
||||
| [expr] -> eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env)"));
|
||||
bind "set-render-active!" (fun _args -> Nil);
|
||||
(* Scope primitives — use a local scope stacks table.
|
||||
Must match the same pattern as sx_server.ml's _scope_stacks. *)
|
||||
let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
@@ -354,20 +359,62 @@ let make_test_env () =
|
||||
bind "cond-scheme?" (fun args ->
|
||||
match args with
|
||||
| [(List clauses | ListRef { contents = clauses })] ->
|
||||
(match clauses with
|
||||
| (List _ | ListRef _) :: _ -> Bool true
|
||||
| _ -> Bool false)
|
||||
Bool (List.for_all (fun c ->
|
||||
match c with
|
||||
| List l | ListRef { contents = l } -> List.length l = 2
|
||||
| _ -> false
|
||||
) clauses)
|
||||
| _ -> Bool false);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; (List a | ListRef { contents = a }); _] ->
|
||||
let local = Sx_types.env_extend m.m_closure in
|
||||
List.iteri (fun i p ->
|
||||
ignore (Sx_types.env_bind local p (if i < List.length a then List.nth a i else Nil))
|
||||
) m.m_params;
|
||||
let rec bind_params ps as' =
|
||||
match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with
|
||||
| Some rp -> ignore (Sx_types.env_bind local rp (List rest))
|
||||
| None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (Sx_types.env_bind local p a);
|
||||
bind_params ps_rest as_rest
|
||||
| remaining, [] ->
|
||||
List.iter (fun p -> ignore (Sx_types.env_bind local p Nil)) remaining
|
||||
in
|
||||
bind_params m.m_params a;
|
||||
eval_expr m.m_body (Env local)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
|
||||
(* Declarative type/effect forms — no-ops at runtime *)
|
||||
bind "deftype" (fun _args -> Nil);
|
||||
bind "defeffect" (fun _args -> Nil);
|
||||
|
||||
(* --- Primitives for canonical.sx / content tests --- *)
|
||||
bind "contains-char?" (fun args ->
|
||||
match args with
|
||||
| [String s; String c] when String.length c = 1 ->
|
||||
Bool (String.contains s c.[0])
|
||||
| _ -> Bool false);
|
||||
bind "escape-string" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let buf = Buffer.create (String.length s + 4) in
|
||||
String.iter (fun c -> match c with
|
||||
| '"' -> Buffer.add_string buf "\\\""
|
||||
| '\\' -> Buffer.add_string buf "\\\\"
|
||||
| '\n' -> Buffer.add_string buf "\\n"
|
||||
| '\t' -> Buffer.add_string buf "\\t"
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "escape-string: expected string"));
|
||||
bind "sha3-256" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
(* Stub: use a simple hash for testing — not real SHA3 *)
|
||||
let h = Hashtbl.hash s in
|
||||
String (Printf.sprintf "%064x" (abs h))
|
||||
| _ -> raise (Eval_error "sha3-256: expected string"));
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
bind "upcase" (fun args ->
|
||||
@@ -467,6 +514,8 @@ let make_test_env () =
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
bind "component-file" (fun args -> match args with [v] -> component_file v | _ -> Nil);
|
||||
bind "component-set-file!" (fun args -> match args with [v; f] -> component_set_file v f | _ -> Nil);
|
||||
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
|
||||
@@ -226,7 +226,7 @@ let sx_render_to_html expr env =
|
||||
let result = Sx_ref.cek_call fn (List [expr; Env env]) in
|
||||
match result with String s -> s | _ -> Sx_runtime.value_to_str result
|
||||
else
|
||||
Sx_render.render_to_html expr env
|
||||
Sx_render.sx_render_to_html env expr env
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
|
||||
@@ -60,6 +60,9 @@ let _prim_param_types_ref = ref Nil
|
||||
run with hook = None (pure CEK, no compilation dependency). *)
|
||||
let jit_call_hook : (value -> value list -> value option) option ref = ref None
|
||||
|
||||
(* Component trace — captures kont from last CEK error for diagnostics *)
|
||||
let _last_error_kont : value ref = ref Nil
|
||||
|
||||
"""
|
||||
|
||||
|
||||
@@ -75,13 +78,58 @@ let () = trampoline_fn := (fun v ->
|
||||
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
|
||||
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
(* Override recursive cek_run with iterative loop.
|
||||
On error, capture the kont from the last state for comp-trace. *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
(try
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
done;
|
||||
cek_value !s
|
||||
with Eval_error msg ->
|
||||
_last_error_kont := cek_kont !s;
|
||||
raise (Eval_error msg))
|
||||
|
||||
(* Collect component trace from a kont value *)
|
||||
let collect_comp_trace kont =
|
||||
let trace = ref [] in
|
||||
let k = ref kont in
|
||||
while (match !k with List (_::_) -> true | _ -> false) do
|
||||
(match !k with
|
||||
| List (frame :: rest) ->
|
||||
(match frame with
|
||||
| CekFrame f when f.cf_type = "comp-trace" ->
|
||||
let name = match f.cf_name with String s -> s | _ -> "?" in
|
||||
let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in
|
||||
trace := (name, file) :: !trace
|
||||
| Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) ->
|
||||
let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in
|
||||
let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in
|
||||
trace := (name, file) :: !trace
|
||||
| _ -> ());
|
||||
k := List rest
|
||||
| _ -> k := List [])
|
||||
done;
|
||||
cek_value !s
|
||||
List.rev !trace
|
||||
|
||||
(* Format a comp-trace into a human-readable string *)
|
||||
let format_comp_trace trace =
|
||||
match trace with
|
||||
| [] -> ""
|
||||
| entries ->
|
||||
let lines = List.mapi (fun i (name, file) ->
|
||||
let prefix = if i = 0 then " in " else " called from " in
|
||||
if file = "" then prefix ^ "~" ^ name
|
||||
else prefix ^ "~" ^ name ^ " (" ^ file ^ ")"
|
||||
) entries in
|
||||
"\n" ^ String.concat "\n" lines
|
||||
|
||||
(* Enhance an error message with component trace *)
|
||||
let enhance_error_with_trace msg =
|
||||
let trace = collect_comp_trace !_last_error_kont in
|
||||
_last_error_kont := Nil;
|
||||
msg ^ (format_comp_trace trace)
|
||||
|
||||
|
||||
|
||||
@@ -248,6 +296,24 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
import sys
|
||||
print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr)
|
||||
|
||||
# Instrument recursive cek_run to capture kont on error (for comp-trace).
|
||||
# The iterative cek_run_iterative already does this, but cek_call uses
|
||||
# the recursive cek_run.
|
||||
cek_run_old = (
|
||||
'and cek_run state =\n'
|
||||
' (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else (cek_run ((cek_step (state)))))'
|
||||
)
|
||||
cek_run_new = (
|
||||
'and cek_run state =\n'
|
||||
' (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else\n'
|
||||
' try cek_run ((cek_step (state)))\n'
|
||||
' with Eval_error msg ->\n'
|
||||
' (if !_last_error_kont = Nil then _last_error_kont := cek_kont state);\n'
|
||||
' raise (Eval_error msg))'
|
||||
)
|
||||
if cek_run_old in output:
|
||||
output = output.replace(cek_run_old, cek_run_new, 1)
|
||||
|
||||
return output
|
||||
|
||||
|
||||
|
||||
@@ -375,7 +375,7 @@ let api_render_to_html expr_js =
|
||||
let prev = !_sx_render_mode in
|
||||
_sx_render_mode := true;
|
||||
(try
|
||||
let html = Sx_render.render_to_html expr global_env in
|
||||
let html = Sx_render.sx_render_to_html global_env expr global_env in
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string html)
|
||||
with Eval_error msg ->
|
||||
@@ -641,7 +641,7 @@ let () =
|
||||
bind "<>" (fun args ->
|
||||
RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | Nil -> ""
|
||||
| List _ -> Sx_render.render_to_html a global_env
|
||||
| List _ -> Sx_render.sx_render_to_html global_env a global_env
|
||||
| _ -> value_to_string a) args)));
|
||||
bind "raw!" (fun args ->
|
||||
RawHTML (String.concat "" (List.map (fun a ->
|
||||
|
||||
@@ -854,6 +854,10 @@ let () =
|
||||
| [Component c] -> c.c_body
|
||||
| [Island i] -> i.i_body
|
||||
| _ -> Nil);
|
||||
register "component-file" (fun args ->
|
||||
match args with [v] -> component_file v | _ -> Nil);
|
||||
register "component-set-file!" (fun args ->
|
||||
match args with [v; f] -> component_set_file v f | _ -> Nil);
|
||||
register "macro?" (fun args ->
|
||||
match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
register "for-each-indexed" (fun args ->
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -102,7 +102,7 @@ let get_val container key =
|
||||
| "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
|
||||
| "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
|
||||
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
|
||||
| "first-render" -> f.cf_extra2
|
||||
| "first-render" -> f.cf_extra2 | "file" -> f.cf_env
|
||||
| _ -> Nil)
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
|
||||
@@ -111,6 +111,7 @@ and component = {
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
mutable c_file : string option; (** Source file path *)
|
||||
mutable c_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
@@ -120,6 +121,7 @@ and island = {
|
||||
i_has_children : bool;
|
||||
i_body : value;
|
||||
i_closure : env;
|
||||
mutable i_file : string option; (** Source file path *)
|
||||
}
|
||||
|
||||
and macro = {
|
||||
@@ -287,7 +289,7 @@ let make_component name params has_children body closure affinity =
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
c_compiled = None;
|
||||
c_file = None; c_compiled = None;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
@@ -297,6 +299,7 @@ let make_island name params has_children body closure =
|
||||
Island {
|
||||
i_name = n; i_params = ps; i_has_children = hc;
|
||||
i_body = body; i_closure = unwrap_env_val closure;
|
||||
i_file = None;
|
||||
}
|
||||
|
||||
let make_macro params rest_param body closure name =
|
||||
@@ -400,6 +403,19 @@ let component_name = function
|
||||
| Island i -> String i.i_name
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_file = function
|
||||
| Component c -> (match c.c_file with Some f -> String f | None -> Nil)
|
||||
| Island i -> (match i.i_file with Some f -> String f | None -> Nil)
|
||||
| _ -> Nil
|
||||
|
||||
let component_set_file v f =
|
||||
(match v, f with
|
||||
| Component c, String s -> c.c_file <- Some s
|
||||
| Island i, String s -> i.i_file <- Some s
|
||||
| _ -> ()); Nil
|
||||
|
||||
let component_set_file_b = component_set_file
|
||||
|
||||
let component_params = function
|
||||
| Component c -> List (List.map (fun s -> String s) c.c_params)
|
||||
| Island i -> List (List.map (fun s -> String s) i.i_params)
|
||||
|
||||
@@ -202,7 +202,7 @@
|
||||
"notify-subscribers" "flush-subscribers" "dispose-computed"
|
||||
"continuation?" "continuation-data" "make-cek-continuation"
|
||||
"dynamic-wind-call" "strip-prefix"
|
||||
"component-set-param-types!" "parse-comp-params" "parse-macro-params"
|
||||
"component-set-param-types!" "component-file" "component-set-file!" "parse-comp-params" "parse-macro-params"
|
||||
"parse-keyword-args"))
|
||||
|
||||
(define ml-is-known-name?
|
||||
|
||||
@@ -14,7 +14,7 @@
|
||||
// =========================================================================
|
||||
|
||||
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
|
||||
var SX_VERSION = "2026-03-28T12:33:20Z";
|
||||
var SX_VERSION = "2026-03-28T22:04:02Z";
|
||||
|
||||
function isNil(x) { return x === NIL || x === null || x === undefined; }
|
||||
function isSxTruthy(x) { return x !== false && !isNil(x); }
|
||||
@@ -1100,6 +1100,10 @@ PRIMITIVES["make-deref-frame"] = makeDerefFrame;
|
||||
var makeHoSetupFrame = function(hoType, remainingArgs, evaledArgs, env) { return {"ho-type": hoType, "env": env, "evaled": evaledArgs, "type": "ho-setup", "remaining": remainingArgs}; };
|
||||
PRIMITIVES["make-ho-setup-frame"] = makeHoSetupFrame;
|
||||
|
||||
// make-comp-trace-frame
|
||||
var makeCompTraceFrame = function(name, file) { return {"env": file, "type": "comp-trace", "name": name}; };
|
||||
PRIMITIVES["make-comp-trace-frame"] = makeCompTraceFrame;
|
||||
|
||||
// frame-type
|
||||
var frameType = function(f) { return get(f, "type"); };
|
||||
PRIMITIVES["frame-type"] = frameType;
|
||||
@@ -2049,7 +2053,7 @@ PRIMITIVES["step-ho-for-each"] = stepHoForEach;
|
||||
var remaining = get(frame, "remaining");
|
||||
var fenv = get(frame, "env");
|
||||
return (isSxTruthy(!isSxTruthy(value)) ? makeCekValue(false, fenv, restK) : (isSxTruthy(isEmpty(remaining)) ? makeCekValue(true, fenv, restK) : continueWithCall(f, [first(remaining)], fenv, [], kontPush(makeEveryFrame(f, rest(remaining), fenv), restK))));
|
||||
})() : error((String("Unknown frame type: ") + String(ft)))))))))))))))))))))))))))));
|
||||
})() : (isSxTruthy((ft == "comp-trace")) ? makeCekValue(value, env, restK) : error((String("Unknown frame type: ") + String(ft))))))))))))))))))))))))))))));
|
||||
})());
|
||||
})(); };
|
||||
PRIMITIVES["step-continue"] = stepContinue;
|
||||
@@ -2078,7 +2082,7 @@ PRIMITIVES["step-continue"] = stepContinue;
|
||||
if (isSxTruthy(componentHasChildren(f))) {
|
||||
envBind(local, "children", children);
|
||||
}
|
||||
return makeCekState(componentBody(f), local, kont);
|
||||
return makeCekState(componentBody(f), local, kontPush(makeCompTraceFrame(componentName(f), NIL), kont));
|
||||
})() : error((String("Not callable: ") + String(inspect(f)))))))); };
|
||||
PRIMITIVES["continue-with-call"] = continueWithCall;
|
||||
|
||||
|
||||
4082
spec/evaluator.sx
4082
spec/evaluator.sx
File diff suppressed because it is too large
Load Diff
579
spec/render.sx
579
spec/render.sx
@@ -1,101 +1,229 @@
|
||||
;; ==========================================================================
|
||||
;; render.sx — Core rendering specification
|
||||
;;
|
||||
;; Shared registries and utilities used by all rendering adapters.
|
||||
;; This file defines WHAT is renderable (tag registries, attribute rules)
|
||||
;; and HOW arguments are parsed — but not the output format.
|
||||
;;
|
||||
;; Adapters:
|
||||
;; adapter-html.sx — HTML string output (server)
|
||||
;; adapter-sx.sx — SX wire format output (server → client)
|
||||
;; adapter-dom.sx — Live DOM node output (browser)
|
||||
;;
|
||||
;; Each adapter imports these shared definitions and provides its own
|
||||
;; render entry point (render-to-html, render-to-sx, render-to-dom).
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; HTML tag registry
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tags known to the renderer. Unknown names are treated as function calls.
|
||||
;; Void elements self-close (no children). Boolean attrs emit name only.
|
||||
|
||||
(define HTML_TAGS
|
||||
(define
|
||||
HTML_TAGS
|
||||
(list
|
||||
;; Document
|
||||
"html" "head" "body" "title" "meta" "link" "script" "style" "noscript"
|
||||
;; Sections
|
||||
"header" "nav" "main" "section" "article" "aside" "footer"
|
||||
"h1" "h2" "h3" "h4" "h5" "h6" "hgroup"
|
||||
;; Block
|
||||
"div" "p" "blockquote" "pre" "figure" "figcaption" "address" "details" "summary"
|
||||
;; Inline
|
||||
"a" "span" "em" "strong" "small" "b" "i" "u" "s" "mark" "sub" "sup"
|
||||
"abbr" "cite" "code" "kbd" "samp" "var" "time" "br" "wbr" "hr"
|
||||
;; Lists
|
||||
"ul" "ol" "li" "dl" "dt" "dd"
|
||||
;; Tables
|
||||
"table" "thead" "tbody" "tfoot" "tr" "th" "td" "caption" "colgroup" "col"
|
||||
;; Forms
|
||||
"form" "input" "textarea" "select" "option" "optgroup" "button" "label"
|
||||
"fieldset" "legend" "output" "datalist"
|
||||
;; Media
|
||||
"img" "video" "audio" "source" "picture" "canvas" "iframe"
|
||||
;; SVG
|
||||
"svg" "math" "path" "circle" "ellipse" "rect" "line" "polyline" "polygon"
|
||||
"text" "tspan" "g" "defs" "use" "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"
|
||||
;; Other
|
||||
"template" "slot" "dialog" "menu"))
|
||||
"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"
|
||||
"details"
|
||||
"summary"
|
||||
"a"
|
||||
"span"
|
||||
"em"
|
||||
"strong"
|
||||
"small"
|
||||
"b"
|
||||
"i"
|
||||
"u"
|
||||
"s"
|
||||
"mark"
|
||||
"sub"
|
||||
"sup"
|
||||
"abbr"
|
||||
"cite"
|
||||
"code"
|
||||
"kbd"
|
||||
"samp"
|
||||
"var"
|
||||
"time"
|
||||
"br"
|
||||
"wbr"
|
||||
"hr"
|
||||
"ul"
|
||||
"ol"
|
||||
"li"
|
||||
"dl"
|
||||
"dt"
|
||||
"dd"
|
||||
"table"
|
||||
"thead"
|
||||
"tbody"
|
||||
"tfoot"
|
||||
"tr"
|
||||
"th"
|
||||
"td"
|
||||
"caption"
|
||||
"colgroup"
|
||||
"col"
|
||||
"form"
|
||||
"input"
|
||||
"textarea"
|
||||
"select"
|
||||
"option"
|
||||
"optgroup"
|
||||
"button"
|
||||
"label"
|
||||
"fieldset"
|
||||
"legend"
|
||||
"output"
|
||||
"datalist"
|
||||
"img"
|
||||
"video"
|
||||
"audio"
|
||||
"source"
|
||||
"picture"
|
||||
"canvas"
|
||||
"iframe"
|
||||
"svg"
|
||||
"math"
|
||||
"path"
|
||||
"circle"
|
||||
"ellipse"
|
||||
"rect"
|
||||
"line"
|
||||
"polyline"
|
||||
"polygon"
|
||||
"text"
|
||||
"tspan"
|
||||
"g"
|
||||
"defs"
|
||||
"use"
|
||||
"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"
|
||||
"dialog"
|
||||
"menu"))
|
||||
|
||||
(define VOID_ELEMENTS
|
||||
(list "area" "base" "br" "col" "embed" "hr" "img" "input"
|
||||
"link" "meta" "param" "source" "track" "wbr"))
|
||||
(define
|
||||
VOID_ELEMENTS
|
||||
(list
|
||||
"area"
|
||||
"base"
|
||||
"br"
|
||||
"col"
|
||||
"embed"
|
||||
"hr"
|
||||
"img"
|
||||
"input"
|
||||
"link"
|
||||
"meta"
|
||||
"param"
|
||||
"source"
|
||||
"track"
|
||||
"wbr"))
|
||||
|
||||
(define BOOLEAN_ATTRS
|
||||
(list "async" "autofocus" "autoplay" "checked" "controls" "default"
|
||||
"defer" "disabled" "formnovalidate" "hidden" "inert" "ismap"
|
||||
"loop" "multiple" "muted" "nomodule" "novalidate" "open"
|
||||
"playsinline" "readonly" "required" "reversed" "selected"))
|
||||
(define
|
||||
BOOLEAN_ATTRS
|
||||
(list
|
||||
"async"
|
||||
"autofocus"
|
||||
"autoplay"
|
||||
"checked"
|
||||
"controls"
|
||||
"default"
|
||||
"defer"
|
||||
"disabled"
|
||||
"formnovalidate"
|
||||
"hidden"
|
||||
"inert"
|
||||
"ismap"
|
||||
"loop"
|
||||
"multiple"
|
||||
"muted"
|
||||
"nomodule"
|
||||
"novalidate"
|
||||
"open"
|
||||
"playsinline"
|
||||
"readonly"
|
||||
"required"
|
||||
"reversed"
|
||||
"selected"))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Shared utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Extension point for definition forms — modules append names here.
|
||||
;; Survives spec reloads (no function wrapping needed).
|
||||
(define *definition-form-extensions* (list))
|
||||
|
||||
(define definition-form? :effects []
|
||||
(fn ((name :as string))
|
||||
(or (= name "define") (= name "defcomp") (= name "defisland")
|
||||
(= name "defmacro") (= name "defstyle")
|
||||
(= name "deftype") (= name "defeffect")
|
||||
(contains? *definition-form-extensions* name))))
|
||||
(define
|
||||
definition-form?
|
||||
:effects ()
|
||||
(fn
|
||||
((name :as string))
|
||||
(or
|
||||
(= name "define")
|
||||
(= name "defcomp")
|
||||
(= name "defisland")
|
||||
(= name "defmacro")
|
||||
(= name "defstyle")
|
||||
(= name "deftype")
|
||||
(= name "defeffect")
|
||||
(contains? *definition-form-extensions* name))))
|
||||
|
||||
|
||||
(define parse-element-args :effects [render]
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list)
|
||||
(let ((attrs (dict))
|
||||
(children (list)))
|
||||
(define
|
||||
parse-element-args
|
||||
:effects (render)
|
||||
(fn
|
||||
((args :as list) (env :as dict))
|
||||
(let
|
||||
((attrs (dict)) (children (list)))
|
||||
(reduce
|
||||
(fn ((state :as dict) arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(fn
|
||||
((state :as dict) arg)
|
||||
(let
|
||||
((skip (get state "skip")))
|
||||
(if
|
||||
skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(if
|
||||
(and
|
||||
(= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let
|
||||
((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! attrs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
@@ -105,193 +233,168 @@
|
||||
args)
|
||||
(list attrs children))))
|
||||
|
||||
|
||||
(define render-attrs :effects []
|
||||
(fn ((attrs :as dict))
|
||||
;; Render an attrs dict to an HTML attribute string.
|
||||
;; Used by adapter-html.sx and adapter-sx.sx.
|
||||
(join ""
|
||||
(define
|
||||
render-attrs
|
||||
:effects ()
|
||||
(fn
|
||||
((attrs :as dict))
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn ((key :as string))
|
||||
(let ((val (dict-get attrs key)))
|
||||
(fn
|
||||
((key :as string))
|
||||
(let
|
||||
((val (dict-get attrs key)))
|
||||
(cond
|
||||
;; Boolean attrs
|
||||
(and (contains? BOOLEAN_ATTRS key) val)
|
||||
(str " " key)
|
||||
(str " " key)
|
||||
(and (contains? BOOLEAN_ATTRS key) (not val))
|
||||
""
|
||||
;; Nil values — skip
|
||||
(nil? val) ""
|
||||
;; Normal attr
|
||||
""
|
||||
(nil? val)
|
||||
""
|
||||
:else (str " " key "=\"" (escape-attr (str val)) "\""))))
|
||||
(keys attrs)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render adapter helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Shared by HTML and DOM adapters for evaluating control forms during
|
||||
;; rendering. Unlike sf-cond (eval.sx) which returns a thunk for TCO,
|
||||
;; eval-cond returns the unevaluated body expression so the adapter
|
||||
;; can render it in its own mode (HTML string vs DOM nodes).
|
||||
|
||||
;; eval-cond: find matching cond branch, return unevaluated body expr.
|
||||
;; Handles both scheme-style ((test body) ...) and clojure-style
|
||||
;; (test body test body ...).
|
||||
(define eval-cond :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (cond-scheme? clauses)
|
||||
(define
|
||||
eval-cond
|
||||
:effects ()
|
||||
(fn
|
||||
((clauses :as list) (env :as dict))
|
||||
(if
|
||||
(cond-scheme? clauses)
|
||||
(eval-cond-scheme clauses env)
|
||||
(eval-cond-clojure clauses env))))
|
||||
|
||||
(define eval-cond-scheme :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (empty? clauses)
|
||||
(define
|
||||
eval-cond-scheme
|
||||
:effects ()
|
||||
(fn
|
||||
((clauses :as list) (env :as dict))
|
||||
(if
|
||||
(empty? clauses)
|
||||
nil
|
||||
(let ((clause (first clauses))
|
||||
(test (first clause))
|
||||
(body (nth clause 1)))
|
||||
(if (is-else-clause? test)
|
||||
(let
|
||||
((clause (first clauses))
|
||||
(test (first clause))
|
||||
(body (nth clause 1)))
|
||||
(if
|
||||
(is-else-clause? test)
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
(if
|
||||
(trampoline (eval-expr test env))
|
||||
body
|
||||
(eval-cond-scheme (rest clauses) env)))))))
|
||||
|
||||
(define eval-cond-clojure :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (< (len clauses) 2)
|
||||
(define
|
||||
eval-cond-clojure
|
||||
:effects ()
|
||||
(fn
|
||||
((clauses :as list) (env :as dict))
|
||||
(if
|
||||
(< (len clauses) 2)
|
||||
nil
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1)))
|
||||
(if (is-else-clause? test)
|
||||
(let
|
||||
((test (first clauses)) (body (nth clauses 1)))
|
||||
(if
|
||||
(is-else-clause? test)
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
(if
|
||||
(trampoline (eval-expr test env))
|
||||
body
|
||||
(eval-cond-clojure (slice clauses 2) env)))))))
|
||||
|
||||
;; process-bindings: evaluate let-binding pairs, return extended env.
|
||||
;; bindings = ((name1 expr1) (name2 expr2) ...)
|
||||
(define process-bindings :effects [mutation]
|
||||
(fn ((bindings :as list) (env :as dict))
|
||||
;; 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)))
|
||||
(define
|
||||
process-bindings
|
||||
:effects (mutation)
|
||||
(fn
|
||||
((bindings :as list) (env :as dict))
|
||||
(let
|
||||
((local (env-extend env)))
|
||||
(for-each
|
||||
(fn ((pair :as list))
|
||||
(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 (trampoline (eval-expr (nth pair 1) local))))))
|
||||
(fn
|
||||
((pair :as list))
|
||||
(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
|
||||
(trampoline (eval-expr (nth pair 1) local))))))
|
||||
bindings)
|
||||
local)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; is-render-expr? — check if expression is a rendering form
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Used by eval-list to dispatch rendering forms to the active adapter
|
||||
;; (HTML, SX wire, or DOM) rather than evaluating them as function calls.
|
||||
|
||||
(define is-render-expr? :effects []
|
||||
(fn (expr)
|
||||
(if (or (not (= (type-of expr) "list")) (empty? expr))
|
||||
(define
|
||||
is-render-expr?
|
||||
:effects ()
|
||||
(fn
|
||||
(expr)
|
||||
(if
|
||||
(or (not (= (type-of expr) "list")) (empty? expr))
|
||||
false
|
||||
(let ((h (first expr)))
|
||||
(if (not (= (type-of h) "symbol"))
|
||||
(let
|
||||
((h (first expr)))
|
||||
(if
|
||||
(not (= (type-of h) "symbol"))
|
||||
false
|
||||
(let ((n (symbol-name h)))
|
||||
(or (= n "<>")
|
||||
(= n "raw!")
|
||||
(starts-with? n "~")
|
||||
(starts-with? n "html:")
|
||||
(contains? HTML_TAGS n)
|
||||
(and (> (index-of n "-") 0)
|
||||
(> (len expr) 1)
|
||||
(= (type-of (nth expr 1)) "keyword")))))))))
|
||||
(let
|
||||
((n (symbol-name h)))
|
||||
(or
|
||||
(= n "<>")
|
||||
(= n "raw!")
|
||||
(starts-with? n "~")
|
||||
(starts-with? n "html:")
|
||||
(contains? HTML_TAGS n)
|
||||
(and
|
||||
(> (index-of n "-") 0)
|
||||
(> (len expr) 1)
|
||||
(= (type-of (nth expr 1)) "keyword")))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Spread — attribute injection from children into parent elements
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A spread value is a dict of attributes that, when returned as a child
|
||||
;; of an HTML element, merges its attrs onto the parent element.
|
||||
;; This enables components to inject classes/styles/data-attrs onto their
|
||||
;; parent without the parent knowing about the specific attrs.
|
||||
;;
|
||||
;; merge-spread-attrs: merge a spread's attrs into an element's attrs dict.
|
||||
;; Class values are joined (space-separated); others overwrite.
|
||||
;; Mutates the target attrs dict in place.
|
||||
|
||||
(define merge-spread-attrs :effects [mutation]
|
||||
(fn ((target :as dict) (spread-dict :as dict))
|
||||
(define
|
||||
merge-spread-attrs
|
||||
:effects (mutation)
|
||||
(fn
|
||||
((target :as dict) (spread-dict :as dict))
|
||||
(for-each
|
||||
(fn ((key :as string))
|
||||
(let ((val (dict-get spread-dict key)))
|
||||
(if (= key "class")
|
||||
;; Class: join existing + new with space
|
||||
(let ((existing (dict-get target "class")))
|
||||
(dict-set! target "class"
|
||||
(if (and existing (not (= existing "")))
|
||||
(fn
|
||||
((key :as string))
|
||||
(let
|
||||
((val (dict-get spread-dict key)))
|
||||
(if
|
||||
(= key "class")
|
||||
(let
|
||||
((existing (dict-get target "class")))
|
||||
(dict-set!
|
||||
target
|
||||
"class"
|
||||
(if
|
||||
(and existing (not (= existing "")))
|
||||
(str existing " " val)
|
||||
val)))
|
||||
;; Style: join with semicolons
|
||||
(if (= key "style")
|
||||
(let ((existing (dict-get target "style")))
|
||||
(dict-set! target "style"
|
||||
(if (and existing (not (= existing "")))
|
||||
(if
|
||||
(= key "style")
|
||||
(let
|
||||
((existing (dict-get target "style")))
|
||||
(dict-set!
|
||||
target
|
||||
"style"
|
||||
(if
|
||||
(and existing (not (= existing "")))
|
||||
(str existing ";" val)
|
||||
val)))
|
||||
;; Everything else: overwrite
|
||||
(dict-set! target key val)))))
|
||||
(keys spread-dict))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; HTML escaping — library functions (pure text processing)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define escape-html
|
||||
(fn (s)
|
||||
(let ((r (str s)))
|
||||
(define
|
||||
escape-html
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((r (str s)))
|
||||
(set! r (replace r "&" "&"))
|
||||
(set! r (replace r "<" "<"))
|
||||
(set! r (replace r ">" ">"))
|
||||
(set! r (replace r "\"" """))
|
||||
r)))
|
||||
|
||||
(define escape-attr
|
||||
(fn (s)
|
||||
(escape-html s)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface (shared across adapters)
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Raw HTML (marker type for unescaped content):
|
||||
;; (raw-html-content r) → unwrap RawHTML marker to string
|
||||
;;
|
||||
;; Spread (render-time attribute injection):
|
||||
;; (make-spread attrs) → Spread value
|
||||
;; (spread? x) → boolean
|
||||
;; (spread-attrs s) → dict
|
||||
;;
|
||||
;; Render-time accumulators:
|
||||
;; (collect! bucket value) → void
|
||||
;; (collected bucket) → list
|
||||
;; (clear-collected! bucket) → void
|
||||
;;
|
||||
;; Scoped effects (scope/provide/context/emit!):
|
||||
;; (scope-push! name val) → void (general form)
|
||||
;; (scope-pop! name) → void (general form)
|
||||
;; (provide-push! name val) → alias for scope-push!
|
||||
;; (provide-pop! name) → alias for scope-pop!
|
||||
;; (context name &rest def) → value from nearest scope
|
||||
;; (emit! name value) → void (append to scope accumulator)
|
||||
;; (emitted name) → list of emitted values
|
||||
;;
|
||||
;; From parser.sx:
|
||||
;; (sx-serialize val) → SX source string (aliased as serialize above)
|
||||
;; --------------------------------------------------------------------------
|
||||
(define escape-attr (fn (s) (escape-html s)))
|
||||
|
||||
@@ -1,25 +1,554 @@
|
||||
(define render-to-html :effects (render) (fn (expr (env :as dict)) (set-render-active! true) (case (type-of expr) "nil" "" "string" (escape-html expr) "number" (str expr) "boolean" (if expr "true" "false") "list" (if (empty? expr) "" (render-list-to-html expr env)) "symbol" (render-value-to-html (trampoline (eval-expr expr env)) env) "keyword" (escape-html (keyword-name expr)) "raw-html" (raw-html-content expr) "spread" (do (scope-emit! "element-attrs" (spread-attrs expr)) "") "thunk" (render-to-html (thunk-expr expr) (thunk-env expr)) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
(define
|
||||
render-to-html
|
||||
:effects (render)
|
||||
(fn
|
||||
(expr (env :as dict))
|
||||
(set-render-active! true)
|
||||
(case
|
||||
(type-of expr)
|
||||
"nil"
|
||||
""
|
||||
"string"
|
||||
(escape-html expr)
|
||||
"number"
|
||||
(str expr)
|
||||
"boolean"
|
||||
(if expr "true" "false")
|
||||
"list"
|
||||
(if (empty? expr) "" (render-list-to-html expr env))
|
||||
"symbol"
|
||||
(render-value-to-html (trampoline (eval-expr expr env)) env)
|
||||
"keyword"
|
||||
(escape-html (keyword-name expr))
|
||||
"raw-html"
|
||||
(raw-html-content expr)
|
||||
"spread"
|
||||
(do (scope-emit! "element-attrs" (spread-attrs expr)) "")
|
||||
"thunk"
|
||||
(render-to-html (thunk-expr expr) (thunk-env expr))
|
||||
:else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
|
||||
(define render-value-to-html :effects (render) (fn (val (env :as dict)) (case (type-of val) "nil" "" "string" (escape-html val) "number" (str val) "boolean" (if val "true" "false") "list" (render-list-to-html val env) "raw-html" (raw-html-content val) "spread" (do (scope-emit! "element-attrs" (spread-attrs val)) "") "thunk" (render-to-html (thunk-expr val) (thunk-env val)) :else (escape-html (str val)))))
|
||||
(define
|
||||
render-value-to-html
|
||||
:effects (render)
|
||||
(fn
|
||||
(val (env :as dict))
|
||||
(case
|
||||
(type-of val)
|
||||
"nil"
|
||||
""
|
||||
"string"
|
||||
(escape-html val)
|
||||
"number"
|
||||
(str val)
|
||||
"boolean"
|
||||
(if val "true" "false")
|
||||
"list"
|
||||
(render-list-to-html val env)
|
||||
"raw-html"
|
||||
(raw-html-content val)
|
||||
"spread"
|
||||
(do (scope-emit! "element-attrs" (spread-attrs val)) "")
|
||||
"thunk"
|
||||
(render-to-html (thunk-expr val) (thunk-env val))
|
||||
:else (escape-html (str val)))))
|
||||
|
||||
(define RENDER_HTML_FORMS (list "if" "when" "cond" "case" "let" "let*" "letrec" "begin" "do" "define" "defcomp" "defisland" "defmacro" "defstyle" "deftype" "defeffect" "map" "map-indexed" "filter" "for-each" "scope" "provide"))
|
||||
(define
|
||||
RENDER_HTML_FORMS
|
||||
(list
|
||||
"if"
|
||||
"when"
|
||||
"cond"
|
||||
"case"
|
||||
"let"
|
||||
"let*"
|
||||
"letrec"
|
||||
"begin"
|
||||
"do"
|
||||
"define"
|
||||
"defcomp"
|
||||
"defisland"
|
||||
"defmacro"
|
||||
"defstyle"
|
||||
"deftype"
|
||||
"defeffect"
|
||||
"map"
|
||||
"map-indexed"
|
||||
"filter"
|
||||
"for-each"
|
||||
"scope"
|
||||
"provide"))
|
||||
|
||||
(define render-html-form? :effects () (fn ((name :as string)) (contains? RENDER_HTML_FORMS name)))
|
||||
(define
|
||||
render-html-form?
|
||||
:effects ()
|
||||
(fn ((name :as string)) (contains? RENDER_HTML_FORMS name)))
|
||||
|
||||
(define render-list-to-html :effects (render) (fn ((expr :as list) (env :as dict)) (if (empty? expr) "" (let ((head (first expr))) (if (not (= (type-of head) "symbol")) (join "" (map (fn (x) (render-value-to-html x env)) expr)) (let ((name (symbol-name head)) (args (rest expr))) (cond (= name "<>") (join "" (map (fn (x) (render-to-html x env)) args)) (= name "raw!") (join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args)) (= name "lake") (render-html-lake args env) (= name "marsh") (render-html-marsh args env) (or (= name "portal") (= name "error-boundary") (= name "promise-delayed")) (join "" (map (fn (x) (render-to-html x env)) args)) (contains? HTML_TAGS name) (render-html-element name args env) (and (starts-with? name "~") (env-has? env name) (island? (env-get env name))) (render-html-island (env-get env name) args env) (starts-with? name "~") (let ((val (env-get env name))) (cond (component? val) (render-html-component val args env) (macro? val) (render-to-html (expand-macro val args env) env) :else (error (str "Unknown component: " name)))) (render-html-form? name) (dispatch-html-form name expr env) (and (env-has? env name) (macro? (env-get env name))) (render-to-html (expand-macro (env-get env name) args env) env) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))))))
|
||||
(define
|
||||
render-list-to-html
|
||||
:effects (render)
|
||||
(fn
|
||||
((expr :as list) (env :as dict))
|
||||
(if
|
||||
(empty? expr)
|
||||
""
|
||||
(let
|
||||
((head (first expr)))
|
||||
(if
|
||||
(not (= (type-of head) "symbol"))
|
||||
(join "" (map (fn (x) (render-value-to-html x env)) expr))
|
||||
(let
|
||||
((name (symbol-name head)) (args (rest expr)))
|
||||
(cond
|
||||
(= name "<>")
|
||||
(join "" (map (fn (x) (render-to-html x env)) args))
|
||||
(= name "raw!")
|
||||
(join
|
||||
""
|
||||
(map (fn (x) (str (trampoline (eval-expr x env)))) args))
|
||||
(= name "lake")
|
||||
(render-html-lake args env)
|
||||
(= name "marsh")
|
||||
(render-html-marsh args env)
|
||||
(or
|
||||
(= name "portal")
|
||||
(= name "error-boundary")
|
||||
(= name "promise-delayed"))
|
||||
(join "" (map (fn (x) (render-to-html x env)) args))
|
||||
(contains? HTML_TAGS name)
|
||||
(render-html-element name args env)
|
||||
(and
|
||||
(starts-with? name "~")
|
||||
(env-has? env name)
|
||||
(island? (env-get env name)))
|
||||
(render-html-island (env-get env name) args env)
|
||||
(starts-with? name "~")
|
||||
(let
|
||||
((val (env-get env name)))
|
||||
(cond
|
||||
(component? val)
|
||||
(render-html-component val args env)
|
||||
(macro? val)
|
||||
(render-to-html (expand-macro val args env) env)
|
||||
:else (error (str "Unknown component: " name))))
|
||||
(render-html-form? name)
|
||||
(dispatch-html-form name expr env)
|
||||
(and (env-has? env name) (macro? (env-get env name)))
|
||||
(render-to-html (expand-macro (env-get env name) args env) env)
|
||||
:else (render-value-to-html (trampoline (eval-expr expr env)) env))))))))
|
||||
|
||||
(define dispatch-html-form :effects (render) (fn ((name :as string) (expr :as list) (env :as dict)) (cond (= name "if") (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) (if cond-val (render-to-html (nth expr 2) env) (if (> (len expr) 3) (render-to-html (nth expr 3) env) ""))) (= name "when") (if (not (trampoline (eval-expr (nth expr 1) env))) "" (if (= (len expr) 3) (render-to-html (nth expr 2) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 2 (len expr)))))) (= name "cond") (let ((branch (eval-cond (rest expr) env))) (if branch (render-to-html branch env) "")) (= name "case") (render-to-html (trampoline (eval-expr expr env)) env) (= name "letrec") (let ((bindings (nth expr 1)) (body (slice expr 2)) (local (env-extend env))) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-bind! local pname nil))) bindings) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-set! local pname (trampoline (eval-expr (nth pair 1) local))))) bindings) (when (> (len body) 1) (for-each (fn (e) (trampoline (eval-expr e local))) (init body))) (render-to-html (last body) local)) (or (= name "let") (= name "let*")) (let ((local (process-bindings (nth expr 1) env))) (if (= (len expr) 3) (render-to-html (nth expr 2) local) (join "" (map (fn (i) (render-to-html (nth expr i) local)) (range 2 (len expr)))))) (or (= name "begin") (= name "do")) (if (= (len expr) 2) (render-to-html (nth expr 1) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 1 (len expr))))) (definition-form? name) (do (trampoline (eval-expr expr env)) "") (= name "map") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "map-indexed") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map-indexed (fn (i item) (if (lambda? f) (render-lambda-html f (list i item) env) (render-to-html (apply f (list i item)) env))) coll))) (= name "filter") (render-to-html (trampoline (eval-expr expr env)) env) (= name "for-each") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "scope") (let ((scope-name (trampoline (eval-expr (nth expr 1) env))) (rest-args (slice expr 2)) (scope-val nil) (body-exprs 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-exprs (slice rest-args 2))) (set! body-exprs rest-args)) (scope-push! scope-name scope-val) (let ((result (if (= (len body-exprs) 1) (render-to-html (first body-exprs) env) (join "" (map (fn (e) (render-to-html e env)) body-exprs))))) (scope-pop! scope-name) result)) (= name "provide") (let ((prov-name (trampoline (eval-expr (nth expr 1) env))) (prov-val (trampoline (eval-expr (nth expr 2) env))) (body-start 3) (body-count (- (len expr) 3))) (scope-push! prov-name prov-val) (let ((result (if (= body-count 1) (render-to-html (nth expr body-start) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range body-start (+ body-start body-count))))))) (scope-pop! prov-name) result)) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
(define
|
||||
dispatch-html-form
|
||||
:effects (render)
|
||||
(fn
|
||||
((name :as string) (expr :as list) (env :as dict))
|
||||
(cond
|
||||
(= name "if")
|
||||
(let
|
||||
((cond-val (trampoline (eval-expr (nth expr 1) env))))
|
||||
(if
|
||||
cond-val
|
||||
(render-to-html (nth expr 2) env)
|
||||
(if (> (len expr) 3) (render-to-html (nth expr 3) env) "")))
|
||||
(= name "when")
|
||||
(if
|
||||
(not (trampoline (eval-expr (nth expr 1) env)))
|
||||
""
|
||||
(if
|
||||
(= (len expr) 3)
|
||||
(render-to-html (nth expr 2) env)
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn (i) (render-to-html (nth expr i) env))
|
||||
(range 2 (len expr))))))
|
||||
(= name "cond")
|
||||
(let
|
||||
((branch (eval-cond (rest expr) env)))
|
||||
(if branch (render-to-html branch env) ""))
|
||||
(= name "case")
|
||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
||||
(= name "letrec")
|
||||
(let
|
||||
((bindings (nth expr 1))
|
||||
(body (slice expr 2))
|
||||
(local (env-extend env)))
|
||||
(for-each
|
||||
(fn
|
||||
(pair)
|
||||
(let
|
||||
((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair)))))
|
||||
(env-bind! local pname nil)))
|
||||
bindings)
|
||||
(for-each
|
||||
(fn
|
||||
(pair)
|
||||
(let
|
||||
((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair)))))
|
||||
(env-set!
|
||||
local
|
||||
pname
|
||||
(trampoline (eval-expr (nth pair 1) local)))))
|
||||
bindings)
|
||||
(when
|
||||
(> (len body) 1)
|
||||
(for-each (fn (e) (trampoline (eval-expr e local))) (init body)))
|
||||
(render-to-html (last body) local))
|
||||
(or (= name "let") (= name "let*"))
|
||||
(let
|
||||
((local (process-bindings (nth expr 1) env)))
|
||||
(if
|
||||
(= (len expr) 3)
|
||||
(render-to-html (nth expr 2) local)
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn (i) (render-to-html (nth expr i) local))
|
||||
(range 2 (len expr))))))
|
||||
(or (= name "begin") (= name "do"))
|
||||
(if
|
||||
(= (len expr) 2)
|
||||
(render-to-html (nth expr 1) env)
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn (i) (render-to-html (nth expr i) env))
|
||||
(range 1 (len expr)))))
|
||||
(definition-form? name)
|
||||
(do (trampoline (eval-expr expr env)) "")
|
||||
(= name "map")
|
||||
(let
|
||||
((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn
|
||||
(item)
|
||||
(if
|
||||
(lambda? f)
|
||||
(render-lambda-html f (list item) env)
|
||||
(render-to-html (apply f (list item)) env)))
|
||||
coll)))
|
||||
(= name "map-indexed")
|
||||
(let
|
||||
((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join
|
||||
""
|
||||
(map-indexed
|
||||
(fn
|
||||
(i item)
|
||||
(if
|
||||
(lambda? f)
|
||||
(render-lambda-html f (list i item) env)
|
||||
(render-to-html (apply f (list i item)) env)))
|
||||
coll)))
|
||||
(= name "filter")
|
||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
||||
(= name "for-each")
|
||||
(let
|
||||
((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn
|
||||
(item)
|
||||
(if
|
||||
(lambda? f)
|
||||
(render-lambda-html f (list item) env)
|
||||
(render-to-html (apply f (list item)) env)))
|
||||
coll)))
|
||||
(= name "scope")
|
||||
(let
|
||||
((scope-name (trampoline (eval-expr (nth expr 1) env)))
|
||||
(rest-args (slice expr 2))
|
||||
(scope-val nil)
|
||||
(body-exprs 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-exprs (slice rest-args 2)))
|
||||
(set! body-exprs rest-args))
|
||||
(scope-push! scope-name scope-val)
|
||||
(let
|
||||
((result (if (= (len body-exprs) 1) (render-to-html (first body-exprs) env) (join "" (map (fn (e) (render-to-html e env)) body-exprs)))))
|
||||
(scope-pop! scope-name)
|
||||
result))
|
||||
(= name "provide")
|
||||
(let
|
||||
((prov-name (trampoline (eval-expr (nth expr 1) env)))
|
||||
(prov-val (trampoline (eval-expr (nth expr 2) env)))
|
||||
(body-start 3)
|
||||
(body-count (- (len expr) 3)))
|
||||
(scope-push! prov-name prov-val)
|
||||
(let
|
||||
((result (if (= body-count 1) (render-to-html (nth expr body-start) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range body-start (+ body-start body-count)))))))
|
||||
(scope-pop! prov-name)
|
||||
result))
|
||||
:else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
|
||||
(define render-lambda-html :effects (render) (fn ((f :as lambda) (args :as list) (env :as dict)) (let ((local (env-merge (lambda-closure f) env))) (for-each-indexed (fn (i p) (env-bind! local p (nth args i))) (lambda-params f)) (render-to-html (lambda-body f) local))))
|
||||
(define
|
||||
render-lambda-html
|
||||
:effects (render)
|
||||
(fn
|
||||
((f :as lambda) (args :as list) (env :as dict))
|
||||
(let
|
||||
((local (env-merge (lambda-closure f) env)))
|
||||
(for-each-indexed
|
||||
(fn (i p) (env-bind! local p (nth args i)))
|
||||
(lambda-params f))
|
||||
(render-to-html (lambda-body f) local))))
|
||||
|
||||
(define render-html-component :effects (render) (fn ((comp :as component) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (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) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (render-to-html (component-body comp) local)))))
|
||||
(define
|
||||
render-html-component
|
||||
:effects (render)
|
||||
(fn
|
||||
((comp :as component) (args :as list) (env :as dict))
|
||||
(let
|
||||
((kwargs (dict)) (children (list)))
|
||||
(reduce
|
||||
(fn
|
||||
(state arg)
|
||||
(let
|
||||
((skip (get state "skip")))
|
||||
(if
|
||||
skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if
|
||||
(and
|
||||
(= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let
|
||||
((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! kwargs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
(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)
|
||||
(env-bind!
|
||||
local
|
||||
"children"
|
||||
(make-raw-html
|
||||
(join "" (map (fn (c) (render-to-html c env)) children)))))
|
||||
(render-to-html (component-body comp) local)))))
|
||||
|
||||
(define render-html-element :effects (render) (fn ((tag :as string) (args :as list) (env :as dict)) (let ((parsed (parse-element-args args env)) (attrs (first parsed)) (children (nth parsed 1)) (is-void (contains? VOID_ELEMENTS tag))) (if is-void (str "<" tag (render-attrs attrs) " />") (do (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" tag (render-attrs attrs) ">" content "</" tag ">")))))))
|
||||
(define
|
||||
render-html-element
|
||||
:effects (render)
|
||||
(fn
|
||||
((tag :as string) (args :as list) (env :as dict))
|
||||
(let
|
||||
((parsed (parse-element-args args env))
|
||||
(attrs (first parsed))
|
||||
(children (nth parsed 1))
|
||||
(is-void (contains? VOID_ELEMENTS tag)))
|
||||
(if
|
||||
is-void
|
||||
(str "<" tag (render-attrs attrs) " />")
|
||||
(do
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let
|
||||
((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs attrs spread-dict))
|
||||
(scope-emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str "<" tag (render-attrs attrs) ">" content "</" tag ">")))))))
|
||||
|
||||
(define render-html-lake :effects (render) (fn ((args :as list) (env :as dict)) (let ((lake-id nil) (lake-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! lake-id kval) (= kname "tag") (set! lake-tag kval)) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((lake-attrs (dict "data-sx-lake" (or lake-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" lake-tag (render-attrs lake-attrs) ">" content "</" lake-tag ">"))))))
|
||||
(define
|
||||
render-html-lake
|
||||
:effects (render)
|
||||
(fn
|
||||
((args :as list) (env :as dict))
|
||||
(let
|
||||
((lake-id nil) (lake-tag "div") (children (list)))
|
||||
(reduce
|
||||
(fn
|
||||
(state arg)
|
||||
(let
|
||||
((skip (get state "skip")))
|
||||
(if
|
||||
skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if
|
||||
(and
|
||||
(= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let
|
||||
((kname (keyword-name arg))
|
||||
(kval
|
||||
(trampoline
|
||||
(eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(cond
|
||||
(= kname "id")
|
||||
(set! lake-id kval)
|
||||
(= kname "tag")
|
||||
(set! lake-tag kval))
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
(let
|
||||
((lake-attrs (dict "data-sx-lake" (or lake-id ""))))
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let
|
||||
((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict))
|
||||
(scope-emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str
|
||||
"<"
|
||||
lake-tag
|
||||
(render-attrs lake-attrs)
|
||||
">"
|
||||
content
|
||||
"</"
|
||||
lake-tag
|
||||
">"))))))
|
||||
|
||||
(define render-html-marsh :effects (render) (fn ((args :as list) (env :as dict)) (let ((marsh-id nil) (marsh-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! marsh-id kval) (= kname "tag") (set! marsh-tag kval) (= kname "transform") nil) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((marsh-attrs (dict "data-sx-marsh" (or marsh-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" marsh-tag (render-attrs marsh-attrs) ">" content "</" marsh-tag ">"))))))
|
||||
(define
|
||||
render-html-marsh
|
||||
:effects (render)
|
||||
(fn
|
||||
((args :as list) (env :as dict))
|
||||
(let
|
||||
((marsh-id nil) (marsh-tag "div") (children (list)))
|
||||
(reduce
|
||||
(fn
|
||||
(state arg)
|
||||
(let
|
||||
((skip (get state "skip")))
|
||||
(if
|
||||
skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if
|
||||
(and
|
||||
(= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let
|
||||
((kname (keyword-name arg))
|
||||
(kval
|
||||
(trampoline
|
||||
(eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(cond
|
||||
(= kname "id")
|
||||
(set! marsh-id kval)
|
||||
(= kname "tag")
|
||||
(set! marsh-tag kval)
|
||||
(= kname "transform")
|
||||
nil)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
(let
|
||||
((marsh-attrs (dict "data-sx-marsh" (or marsh-id ""))))
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let
|
||||
((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict))
|
||||
(scope-emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str
|
||||
"<"
|
||||
marsh-tag
|
||||
(render-attrs marsh-attrs)
|
||||
">"
|
||||
content
|
||||
"</"
|
||||
marsh-tag
|
||||
">"))))))
|
||||
|
||||
(define render-html-island :effects (render) (fn ((island :as island) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (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)) (when (component-has-children? island) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (let ((body-html (cek-try (fn () (render-to-html (component-body island) local)) (fn (err) ""))) (state-sx (serialize-island-state kwargs))) (str "<span data-sx-island=\"" (escape-attr island-name) "\"" (if state-sx (str " data-sx-state=\"" (escape-attr state-sx) "\"") "") ">" body-html "</span>"))))))
|
||||
(define
|
||||
render-html-island
|
||||
:effects (render)
|
||||
(fn
|
||||
((island :as island) (args :as list) (env :as dict))
|
||||
(let
|
||||
((kwargs (dict)) (children (list)))
|
||||
(reduce
|
||||
(fn
|
||||
(state arg)
|
||||
(let
|
||||
((skip (get state "skip")))
|
||||
(if
|
||||
skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if
|
||||
(and
|
||||
(= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let
|
||||
((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! kwargs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
(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))
|
||||
(when
|
||||
(component-has-children? island)
|
||||
(env-bind!
|
||||
local
|
||||
"children"
|
||||
(make-raw-html
|
||||
(join "" (map (fn (c) (render-to-html c env)) children)))))
|
||||
(let
|
||||
((body-html (cek-try (fn () (render-to-html (component-body island) local)) (fn (err) "")))
|
||||
(state-sx (serialize-island-state kwargs)))
|
||||
(str
|
||||
"<span data-sx-island=\""
|
||||
(escape-attr island-name)
|
||||
"\""
|
||||
(if
|
||||
state-sx
|
||||
(str " data-sx-state=\"" (escape-attr state-sx) "\"")
|
||||
"")
|
||||
">"
|
||||
body-html
|
||||
"</span>"))))))
|
||||
|
||||
(define serialize-island-state :effects () (fn ((kwargs :as dict)) (if (empty-dict? kwargs) nil (sx-serialize kwargs))))
|
||||
(define
|
||||
serialize-island-state
|
||||
:effects ()
|
||||
(fn
|
||||
((kwargs :as dict))
|
||||
(if (empty-dict? kwargs) nil (sx-serialize kwargs))))
|
||||
|
||||
Reference in New Issue
Block a user