(** 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 }