436 lines
15 KiB
OCaml
436 lines
15 KiB
OCaml
(** HTML renderer for SX values.
|
|
|
|
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.). *)
|
|
|
|
open Sx_types
|
|
|
|
(* ====================================================================== *)
|
|
(* Tag / attribute registries *)
|
|
(* ====================================================================== *)
|
|
|
|
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 void_elements = [
|
|
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
|
|
"link"; "meta"; "param"; "source"; "track"; "wbr"
|
|
]
|
|
|
|
let boolean_attrs = [
|
|
"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_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
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* HTML escaping *)
|
|
(* ====================================================================== *)
|
|
|
|
let escape_html 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
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* 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
|
|
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
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* HTML renderer *)
|
|
(* ====================================================================== *)
|
|
|
|
(* 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
|
|
|
|
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 ^ "</" ^ tag ^ ">"
|
|
|
|
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
|
|
| 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 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 _ -> render_component v args env
|
|
| 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 _ ->
|
|
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
|
do_render_to_html result env)
|
|
| _ ->
|
|
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)
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* 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 bind name fn =
|
|
ignore (env_bind 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
|
|
String (render_to_html expr env)
|
|
| [expr] ->
|
|
String (render_to_html expr env)
|
|
| [expr; Env e] ->
|
|
String (render_to_html expr 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
|
|
String (render_to_html expr env)
|
|
| [expr] ->
|
|
String (render_to_html expr env)
|
|
| [expr; Env e] ->
|
|
String (render_to_html expr e)
|
|
| _ -> String "")
|