rose-ash/hosts/native/lib/sx_native_render.ml

(** Convert an [Sx_types.value] tree into a native [node] render tree.

    Walks the parsed SX AST and produces nodes for HTML-like tags
    (div, p, h1-h6, span, etc.), extracting :class attributes for
    styling and string content for text nodes. Unknown forms are
    rendered as gray placeholders. *)

open Sx_native_types
open Sx_native_style

(* -- Tag default styles -- *)

let tag_base_style (tag : string) : style =
  match tag with
  | "h1" -> { default_style with font_size = 36.; font_weight = `Bold }
  | "h2" -> { default_style with font_size = 30.; font_weight = `Bold }
  | "h3" -> { default_style with font_size = 24.; font_weight = `Bold }
  | "h4" -> { default_style with font_size = 20.; font_weight = `Bold }
  | "h5" -> { default_style with font_size = 18.; font_weight = `Bold }
  | "h6" -> { default_style with font_size = 16.; font_weight = `Bold }
  | "p"  -> { default_style with flex_direction = `Row }
  | "span" -> { default_style with flex_direction = `Row }
  | "div" -> default_style
  | "section" -> default_style
  | "article" -> default_style
  | "main" -> default_style
  | "header" -> default_style
  | "footer" -> default_style
  | "nav" -> { default_style with flex_direction = `Row }
  | "button" ->
    { default_style with
      flex_direction = `Row;
      padding = { top = 8.; right = 16.; bottom = 8.; left = 16. };
      bg_color = Some violet_600;
      text_color = white;
      border_radius = 6.;
      align_items = `Center;
      justify_content = `Center }
  | "a" -> { default_style with flex_direction = `Row; text_color = violet_600 }
  | "code" ->
    { default_style with
      font_family = `Mono;
      font_size = 14.;
      bg_color = Some stone_100;
      padding = { top = 2.; right = 4.; bottom = 2.; left = 4. };
      border_radius = 4. }
  | "pre" ->
    { default_style with
      font_family = `Mono;
      font_size = 14.;
      bg_color = Some stone_100;
      padding = { top = 12.; right = 16.; bottom = 12.; left = 16. };
      border_radius = 8. }
  | "strong" | "b" -> { default_style with font_weight = `Bold; flex_direction = `Row }
  | "em" | "i" -> { default_style with font_style = `Italic; flex_direction = `Row }
  | "ul" -> { default_style with padding = { zero_edges with left = 16. } }
  | "ol" -> { default_style with padding = { zero_edges with left = 16. } }
  | "li" -> { default_style with flex_direction = `Row; gap = 4. }
  | "table" -> default_style
  | "thead" | "tbody" -> default_style
  | "tr" -> { default_style with flex_direction = `Row; gap = 0. }
  | "th" -> { default_style with font_weight = `Bold; padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
  | "td" -> { default_style with padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
  | "hr" ->
    { default_style with
      height = `Px 1.;
      bg_color = Some stone_200;
      width = `Full }
  | "br" -> { default_style with height = `Px 16. }
  | "img" ->
    { default_style with
      width = `Px 200.;
      height = `Px 150.;
      bg_color = Some stone_200;
      border_radius = 4. }
  | _ -> default_style

(* -- Known HTML tags -- *)

let is_html_tag = function
  | "div" | "span" | "p" | "section" | "article" | "main" | "header"
  | "footer" | "nav" | "aside"
  | "h1" | "h2" | "h3" | "h4" | "h5" | "h6"
  | "button" | "a" | "input" | "form" | "label" | "select" | "textarea"
  | "ul" | "ol" | "li"
  | "table" | "thead" | "tbody" | "tr" | "th" | "td"
  | "strong" | "b" | "em" | "i" | "u" | "s"
  | "code" | "pre" | "blockquote"
  | "img" | "video" | "audio" | "source"
  | "hr" | "br"
  | "head" | "body" | "html" | "title" | "meta" | "link" | "script" | "style"
  | "small" | "mark" | "sup" | "sub" | "abbr" | "time"
  | "figure" | "figcaption" | "details" | "summary"
  | "dl" | "dt" | "dd" -> true
  | _ -> false

(* Void/skip tags -- don't render these *)
let is_skip_tag = function
  | "head" | "meta" | "link" | "script" | "style" | "title"
  | "source" | "input" -> true
  | _ -> false

(* -- Extract keyword args from SX list -- *)

(** Extract keyword arguments and children from an SX element's argument list.
    Returns [(attrs, children)] where attrs is a (key, value) list. *)
let extract_attrs (items : Sx_types.value list) : (string * Sx_types.value) list * Sx_types.value list =
  let rec go attrs children = function
    | [] -> (List.rev attrs, List.rev children)
    | Sx_types.Keyword k :: v :: rest ->
      go ((k, v) :: attrs) children rest
    | other :: rest ->
      go attrs (other :: children) rest
  in
  go [] [] items

(** Get a string attribute from keyword args. *)
let get_string_attr (attrs : (string * Sx_types.value) list) (key : string) : string option =
  match List.assoc_opt key attrs with
  | Some (Sx_types.String s) -> Some s
  | _ -> None

(* -- Render SX values to native nodes -- *)

(** Make a text leaf node with inherited style. *)
let make_text_node (style : style) (text : string) : node =
  { tag = "#text"; style; children = []; text = Some text;
    box = make_box (); href = None; on_click = None }

(** Render an SX value tree to a native node tree.
    [~navigate] callback is invoked when a link is clicked. *)
let rec render ?(navigate : (string -> unit) option) (value : Sx_types.value) : node option =
  match value with
  | Sx_types.String s ->
    Some (make_text_node default_style s)
  | Sx_types.Number n ->
    let s = if Float.is_integer n then string_of_int (int_of_float n)
            else Printf.sprintf "%g" n in
    Some (make_text_node default_style s)
  | Sx_types.Bool true -> Some (make_text_node default_style "true")
  | Sx_types.Bool false -> Some (make_text_node default_style "false")
  | Sx_types.Nil -> None
  | Sx_types.Keyword _ -> None  (* bare keywords are attr markers *)
  | Sx_types.Symbol _ -> None   (* bare symbols are not renderable *)

  | Sx_types.List (Sx_types.Symbol tag :: rest) when is_html_tag tag ->
    if is_skip_tag tag then None
    else begin
      let (attrs, children_sx) = extract_attrs rest in
      let class_str = get_string_attr attrs "class" in
      let href = get_string_attr attrs "href" in

      (* Build style: tag defaults + class overrides *)
      let base = tag_base_style tag in
      let style = match class_str with
        | Some cls -> parse_classes ~base cls
        | None -> base
      in

      (* Special: li gets a bullet prefix *)
      let extra_children = if tag = "li" then
        [make_text_node { style with flex_direction = `Row } "\xe2\x80\xa2 "]
      else [] in

      (* Render children *)
      let children = extra_children @ List.filter_map (render ?navigate) children_sx in

      (* For link nodes, set up navigation *)
      let on_click = match href, navigate with
        | Some h, Some nav -> Some (fun () -> nav h)
        | _ -> None
      in

      Some { tag; style; children; text = None;
             box = make_box (); href; on_click }
    end

  (* Component calls (~name ...) -- render as placeholder *)
  | Sx_types.List (Sx_types.Symbol name :: rest) when String.length name > 0 && name.[0] = '~' ->
    let (attrs, children_sx) = extract_attrs rest in
    let class_str = get_string_attr attrs "class" in
    let base = { default_style with
                 border_width = 1.;
                 border_color = Some violet_200;
                 border_radius = 4.;
                 padding = { top = 8.; right = 8.; bottom = 8.; left = 8. } } in
    let style = match class_str with
      | Some cls -> parse_classes ~base cls
      | None -> base
    in
    let label = make_text_node
      { default_style with font_size = 12.; text_color = violet_500; font_family = `Mono }
      name in
    let children = label :: List.filter_map (render ?navigate) children_sx in
    Some { tag = "component"; style; children; text = None;
           box = make_box (); href = None; on_click = None }

  (* Unknown list forms -- try to render children *)
  | Sx_types.List items ->
    let children = List.filter_map (render ?navigate) items in
    if children = [] then None
    else if List.length children = 1 then Some (List.hd children)
    else
      Some { tag = "group"; style = default_style; children; text = None;
             box = make_box (); href = None; on_click = None }

  | _ -> None  (* Lambda, Dict, etc. -- skip *)

(** Render a list of top-level SX values into a single root node. *)
let render_page ?(navigate : (string -> unit) option) (values : Sx_types.value list) : node =
  let children = List.filter_map (render ?navigate) values in
  (* Wrap everything in a root container *)
  { tag = "root";
    style = { default_style with
              width = `Full;
              padding = { top = 0.; right = 0.; bottom = 0.; left = 0. } };
    children;
    text = None;
    box = make_box ();
    href = None;
    on_click = None }