rose-ash/hosts/ocaml/lib/sx_render.ml

(** 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 "&lt;"
    | '>' -> Buffer.add_string buf "&gt;"
    | '"' -> Buffer.add_string buf "&quot;"
    | 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 "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 _ -> render_component v args env
       | Island i ->
         (* Islands: render initial HTML server-side (like React SSR).
            Log failures so we can fix them. *)
         (try
           let c = { c_name = i.i_name; c_params = i.i_params;
                     c_has_children = i.i_has_children; c_body = i.i_body;
                     c_closure = i.i_closure; c_affinity = "client";
                     c_compiled = None } in
           render_component (Component c) args env
         with e ->
           Printf.eprintf "[ssr-island] ~%s FAILED: %s\n%!" i.i_name (Printexc.to_string e);
           "")
       | 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 "")