coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add native SX desktop browser — renders s-expressions to pixels

Browse Source 
A 5.9MB OCaml binary that renders SX pages directly using SDL2 + Cairo,
bypassing HTML/CSS/JS entirely. Can fetch live pages from sx.rose-ash.com
or render local .sx files.

Architecture (1,387 lines of new code):
  sx_native_types.ml   — render nodes, styles, layout boxes, color palette
  sx_native_style.ml   — ~40 Tailwind classes → native style records
  sx_native_layout.ml  — pure OCaml flexbox (measure + position)
  sx_native_render.ml  — SX value tree → native render nodes
  sx_native_paint.ml   — render nodes → Cairo draw commands
  sx_native_fetch.ml   — HTTP fetch via curl with SX-Request headers
  sx_native_app.ml     — SDL2 window, event loop, navigation, scrolling

Usage:
  dune build                           # from hosts/native/
  ./sx_native_app.exe /sx/             # browse sx.rose-ash.com home
  ./sx_native_app.exe /sx/(applications.(native-browser))
  ./sx_native_app.exe demo/counter.sx  # render local file

Features:
  - Flexbox layout (row/column, gap, padding, alignment, grow)
  - Tailwind color palette (stone, violet, white)
  - Rounded corners, borders, shadows
  - Text rendering with font size/weight
  - Click navigation (links trigger refetch)
  - Scroll with mouse wheel
  - Window resize → re-layout
  - URL bar showing current path

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-27 17:01:22 +00:00
parent 07d1603b2c
commit f0d8db9b68
15 changed files with 1392 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
hosts/native/lib/dune Normal file
View File

@@ -0,0 +1,3 @@
(library
(name sx_native)
(libraries sx cairo2 unix))

37
hosts/native/lib/sx_native_fetch.ml Normal file
View File

@@ -0,0 +1,37 @@
(** HTTP fetcher for SX pages.
Uses curl via Unix.open_process_in for simplicity.
Fetches pages from sx.rose-ash.com with SX-Request headers. *)
let base_url = "https://sx.rose-ash.com"
(** Fetch a URL and return the response body as a string. *)
let fetch_url (url : string) : string =
let cmd = Printf.sprintf
"curl -s -L -H 'Accept: text/sx' -H 'SX-Request: true' '%s'" url in
let ic = Unix.open_process_in cmd in
let buf = Buffer.create 8192 in
(try while true do Buffer.add_char buf (input_char ic) done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
Buffer.contents buf
(** Fetch an SX page by path (e.g. "/sx/" or "/sx/language"). *)
let fetch_page (path : string) : string =
let url = if String.length path > 0 && path.[0] = '/' then
base_url ^ path
else if String.length path > 4 && String.sub path 0 4 = "http" then
path
else
base_url ^ "/" ^ path
in
fetch_url url
(** Read a local .sx file. *)
let read_file (path : string) : string =
let ic = open_in path in
let n = in_channel_length ic in
let buf = Bytes.create n in
really_input ic buf 0 n;
close_in ic;
Bytes.to_string buf

232
hosts/native/lib/sx_native_layout.ml Normal file
View File

@@ -0,0 +1,232 @@
(** Pure flexbox layout engine.
Two-pass algorithm:
1. Measure (bottom-up): compute intrinsic sizes from text extents
and children accumulation.
2. Layout (top-down): allocate space starting from window bounds,
distributing via flex-grow and handling alignment/gap. *)
open Sx_native_types
(* -- Text measurement -- *)
let measure_text (cr : Cairo.context) (family : [`Sans | `Mono]) (weight : [`Normal | `Bold])
(slant : [`Normal | `Italic]) (size : float) (text : string) : float * float =
let font_name = match family with `Sans -> "sans-serif" | `Mono -> "monospace" in
let cairo_weight = match weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
let cairo_slant = match slant with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
Cairo.select_font_face cr ~slant:cairo_slant ~weight:cairo_weight font_name;
Cairo.set_font_size cr size;
let fe = Cairo.font_extents cr in
if String.length text = 0 then (0., fe.ascent +. fe.descent)
else begin
(* Word wrap not needed for POC -- measure as single line *)
let te = Cairo.text_extents cr text in
(te.Cairo.width +. te.Cairo.x_bearing, fe.ascent +. fe.descent)
end
(* -- Measure pass (bottom-up) -- *)
(** Set intrinsic [box.w] and [box.h] on each node based on text extents
and children accumulation. Does NOT set x/y. *)
let rec measure (cr : Cairo.context) (node : node) : unit =
(* Measure children first *)
List.iter (measure cr) node.children;
let pad = node.style.padding in
let pad_h = pad.left +. pad.right in
let pad_v = pad.top +. pad.bottom in
match node.text with
| Some txt ->
(* Leaf text node: measure the text *)
let (tw, th) = measure_text cr node.style.font_family node.style.font_weight
node.style.font_style node.style.font_size txt in
node.box.w <- tw +. pad_h;
node.box.h <- th +. pad_v
| None ->
if node.style.display = `None then begin
node.box.w <- 0.;
node.box.h <- 0.
end else begin
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
let n_children = List.length visible_children in
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
match node.style.flex_direction with
| `Column ->
(* Stack vertically: width = max child width, height = sum of child heights + gaps *)
let max_w = List.fold_left (fun acc c ->
let cm = c.style.margin in
Float.max acc (c.box.w +. cm.left +. cm.right)
) 0. visible_children in
let sum_h = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.h +. cm.top +. cm.bottom
) 0. visible_children in
node.box.w <- max_w +. pad_h;
node.box.h <- sum_h +. total_gap +. pad_v
| `Row ->
(* Stack horizontally: height = max child height, width = sum of child widths + gaps *)
let sum_w = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.w +. cm.left +. cm.right
) 0. visible_children in
let max_h = List.fold_left (fun acc c ->
let cm = c.style.margin in
Float.max acc (c.box.h +. cm.top +. cm.bottom)
) 0. visible_children in
node.box.w <- sum_w +. total_gap +. pad_h;
node.box.h <- max_h +. pad_v
end;
(* Apply explicit width/height constraints *)
(match node.style.width with
| `Px w -> node.box.w <- w
| `Full | `Auto -> ());
(match node.style.height with
| `Px h -> node.box.h <- h
| `Full | `Auto -> ())
(* -- Layout pass (top-down) -- *)
(** Position all nodes within the given bounds [x, y, w, h].
Distributes space according to flex-grow and handles alignment. *)
let rec layout (node : node) (x : float) (y : float) (avail_w : float) (avail_h : float) : unit =
let margin = node.style.margin in
let x = x +. margin.left in
let y = y +. margin.top in
let avail_w = avail_w -. margin.left -. margin.right in
let avail_h = avail_h -. margin.top -. margin.bottom in
node.box.x <- x;
node.box.y <- y;
(* Determine actual width/height.
Container nodes with Auto width stretch to fill available space
(like CSS block-level elements), while text nodes keep intrinsic width. *)
let is_text_node = node.text <> None in
let w = match node.style.width with
| `Full -> avail_w
| `Px pw -> Float.min pw avail_w
| `Auto ->
if is_text_node then Float.min node.box.w avail_w
else avail_w (* containers expand to fill *)
in
let h = match node.style.height with
| `Full -> avail_h
| `Px ph -> Float.min ph avail_h
| `Auto -> node.box.h (* Use intrinsic height *)
in
node.box.w <- w;
node.box.h <- h;
if node.style.display = `None then ()
else begin
let pad = node.style.padding in
let inner_x = x +. pad.left in
let inner_y = y +. pad.top in
let inner_w = w -. pad.left -. pad.right in
let inner_h = h -. pad.top -. pad.bottom in
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
match visible_children with
| [] -> () (* Leaf or empty container *)
| children ->
let n_children = List.length children in
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
match node.style.flex_direction with
| `Column ->
(* Calculate total intrinsic height and flex-grow sum *)
let total_intrinsic = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.h +. cm.top +. cm.bottom
) 0. children in
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
let remaining = Float.max 0. (inner_h -. total_intrinsic -. total_gap) in
(* justify-content: space-between *)
let (start_offset, between_extra) = match node.style.justify_content with
| `Between when n_children > 1 ->
(0., remaining /. float_of_int (n_children - 1))
| `Center -> (remaining /. 2., 0.)
| `End -> (remaining, 0.)
| _ -> (0., 0.)
in
let cur_y = ref (inner_y +. start_offset) in
List.iter (fun child ->
let cm = child.style.margin in
let child_w = match child.style.width with
| `Full -> inner_w -. cm.left -. cm.right
| _ -> Float.min child.box.w (inner_w -. cm.left -. cm.right)
in
let extra_h = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
let child_h = child.box.h +. extra_h in
(* align-items: cross-axis alignment *)
let child_x = match node.style.align_items with
| `Center -> inner_x +. (inner_w -. child_w -. cm.left -. cm.right) /. 2.
| `End -> inner_x +. inner_w -. child_w -. cm.right
| `Stretch ->
(* Stretch: child takes full width *)
layout child (inner_x) !cur_y (inner_w) child_h;
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra;
(* skip the normal layout below *)
inner_x (* dummy, won't be used *)
| _ -> inner_x
in
if node.style.align_items <> `Stretch then begin
layout child child_x !cur_y child_w child_h;
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra
end
) children
| `Row ->
(* Calculate total intrinsic width and flex-grow sum *)
let total_intrinsic = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.w +. cm.left +. cm.right
) 0. children in
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
let remaining = Float.max 0. (inner_w -. total_intrinsic -. total_gap) in
let (start_offset, between_extra) = match node.style.justify_content with
| `Between when n_children > 1 ->
(0., remaining /. float_of_int (n_children - 1))
| `Center -> (remaining /. 2., 0.)
| `End -> (remaining, 0.)
| _ -> (0., 0.)
in
let cur_x = ref (inner_x +. start_offset) in
List.iter (fun child ->
let cm = child.style.margin in
let extra_w = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
let child_w = child.box.w +. extra_w in
let child_h = match child.style.height with
| `Full -> inner_h -. cm.top -. cm.bottom
| _ -> Float.min child.box.h (inner_h -. cm.top -. cm.bottom)
in
(* align-items: cross-axis alignment *)
let child_y = match node.style.align_items with
| `Center -> inner_y +. (inner_h -. child_h -. cm.top -. cm.bottom) /. 2.
| `End -> inner_y +. inner_h -. child_h -. cm.bottom
| `Stretch ->
layout child !cur_x inner_y child_w inner_h;
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra;
inner_y (* dummy *)
| _ -> inner_y
in
if node.style.align_items <> `Stretch then begin
layout child !cur_x child_y child_w child_h;
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra
end
) children
end

156
hosts/native/lib/sx_native_paint.ml Normal file
View File

@@ -0,0 +1,156 @@
(** Walk a positioned node tree and issue Cairo draw commands.
Handles backgrounds with rounded corners, borders, shadows,
and text rendering with proper font face/size/weight. *)
open Sx_native_types
open Sx_native_style
(* -- Rounded rectangle path -- *)
let rounded_rect (cr : Cairo.context) (x : float) (y : float) (w : float) (h : float) (r : float) =
let r = Float.min r (Float.min (w /. 2.) (h /. 2.)) in
if r <= 0. then
Cairo.rectangle cr x y ~w ~h
else begin
let pi = Float.pi in
Cairo.Path.sub cr;
Cairo.arc cr (x +. w -. r) (y +. r) ~r ~a1:(-.pi /. 2.) ~a2:0.;
Cairo.arc cr (x +. w -. r) (y +. h -. r) ~r ~a1:0. ~a2:(pi /. 2.);
Cairo.arc cr (x +. r) (y +. h -. r) ~r ~a1:(pi /. 2.) ~a2:pi;
Cairo.arc cr (x +. r) (y +. r) ~r ~a1:pi ~a2:(-.pi /. 2.);
Cairo.Path.close cr
end
(* -- Shadow painting -- *)
let paint_shadow (cr : Cairo.context) (b : box) (radius : float) (level : [`Sm | `Md]) =
let (offset, blur_passes, alpha) = match level with
| `Sm -> (1., 2, 0.04)
| `Md -> (2., 3, 0.05)
in
for i = 1 to blur_passes do
let spread = float_of_int i *. 2. in
Cairo.save cr;
Cairo.set_source_rgba cr 0. 0. 0. (alpha /. float_of_int i);
rounded_rect cr
(b.x -. spread)
(b.y +. offset -. spread +. float_of_int i)
(b.w +. spread *. 2.)
(b.h +. spread *. 2.)
(radius +. spread);
Cairo.fill cr;
Cairo.restore cr
done
(* -- Main paint function -- *)
(** Paint a positioned node tree to a Cairo context. *)
let rec paint (cr : Cairo.context) (node : node) : unit =
let s = node.style in
let b = node.box in
if s.display = `None then ()
else begin
(* Save state for potential clip *)
Cairo.save cr;
(* Shadow *)
(match s.shadow with
| `None -> ()
| `Sm -> paint_shadow cr b s.border_radius `Sm
| `Md -> paint_shadow cr b s.border_radius `Md);
(* Background *)
(match s.bg_color with
| Some c ->
Cairo.set_source_rgba cr c.r c.g c.b c.a;
rounded_rect cr b.x b.y b.w b.h s.border_radius;
Cairo.fill cr
| None -> ());
(* Border *)
if s.border_width > 0. then begin
let bc = match s.border_color with Some c -> c | None -> stone_800 in
Cairo.set_source_rgba cr bc.r bc.g bc.b bc.a;
Cairo.set_line_width cr s.border_width;
rounded_rect cr
(b.x +. s.border_width /. 2.)
(b.y +. s.border_width /. 2.)
(b.w -. s.border_width)
(b.h -. s.border_width)
(Float.max 0. (s.border_radius -. s.border_width /. 2.));
Cairo.stroke cr
end;
(* Clip for overflow *)
if s.overflow_hidden then begin
rounded_rect cr b.x b.y b.w b.h s.border_radius;
Cairo.clip cr
end;
(* Text *)
(match node.text with
| Some txt when String.length txt > 0 ->
let font_name = match s.font_family with `Sans -> "sans-serif" | `Mono -> "monospace" in
let weight = match s.font_weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
let slant = match s.font_style with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
Cairo.select_font_face cr ~slant ~weight font_name;
Cairo.set_font_size cr s.font_size;
let fe = Cairo.font_extents cr in
Cairo.set_source_rgba cr s.text_color.r s.text_color.g s.text_color.b s.text_color.a;
Cairo.move_to cr (b.x +. s.padding.left) (b.y +. s.padding.top +. fe.ascent);
Cairo.show_text cr txt
| _ -> ());
(* Children *)
List.iter (paint cr) node.children;
Cairo.restore cr
end
(** Paint a horizontal URL bar at the top of the window. *)
let paint_url_bar (cr : Cairo.context) (url : string) (width : float) : float =
let bar_height = 36. in
(* Bar background *)
Cairo.set_source_rgba cr stone_100.r stone_100.g stone_100.b 1.0;
Cairo.rectangle cr 0. 0. ~w:width ~h:bar_height;
Cairo.fill cr;
(* Bottom border *)
Cairo.set_source_rgba cr stone_200.r stone_200.g stone_200.b 1.0;
Cairo.set_line_width cr 1.;
Cairo.move_to cr 0. bar_height;
Cairo.line_to cr width bar_height;
Cairo.stroke cr;
(* URL text *)
Cairo.select_font_face cr ~slant:Cairo.Upright ~weight:Cairo.Normal "monospace";
Cairo.set_font_size cr 13.;
Cairo.set_source_rgba cr stone_600.r stone_600.g stone_600.b 1.0;
Cairo.move_to cr 12. 23.;
Cairo.show_text cr url;
bar_height
(** Paint the entire scene: clear, URL bar, then content. *)
let paint_scene (cr : Cairo.context) (root : node) (url : string) (width : float) (height : float) : unit =
(* Clear to white *)
Cairo.set_source_rgba cr 1. 1. 1. 1.;
Cairo.rectangle cr 0. 0. ~w:width ~h:height;
Cairo.fill cr;
(* URL bar *)
let bar_h = paint_url_bar cr url width in
(* Content area *)
Cairo.save cr;
Cairo.rectangle cr 0. bar_h ~w:width ~h:(height -. bar_h);
Cairo.clip cr;
(* Offset layout by bar height *)
root.box.y <- root.box.y +. bar_h;
paint cr root;
root.box.y <- root.box.y -. bar_h; (* restore for hit testing *)
Cairo.restore cr

221
hosts/native/lib/sx_native_render.ml Normal file
View File

@@ -0,0 +1,221 @@
(** 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 }

277
hosts/native/lib/sx_native_style.ml Normal file
View File

@@ -0,0 +1,277 @@
(** Parse Tailwind CSS class strings into native style records.
Supports ~50 common utility classes covering layout, spacing,
sizing, typography, colors, borders, and effects. *)
open Sx_native_types
(* -- Color palette (Tailwind stone + violet) -- *)
let white = { r = 1.0; g = 1.0; b = 1.0; a = 1.0 }
let black = { r = 0.0; g = 0.0; b = 0.0; a = 1.0 }
let stone_50 = { r = 0.980; g = 0.976; b = 0.973; a = 1.0 }
let stone_100 = { r = 0.961; g = 0.953; b = 0.945; a = 1.0 }
let stone_200 = { r = 0.906; g = 0.890; b = 0.875; a = 1.0 }
let stone_300 = { r = 0.839; g = 0.812; b = 0.788; a = 1.0 }
let stone_400 = { r = 0.659; g = 0.616; b = 0.576; a = 1.0 }
let stone_500 = { r = 0.471; g = 0.431; b = 0.396; a = 1.0 }
let stone_600 = { r = 0.341; g = 0.306; b = 0.275; a = 1.0 }
let stone_700 = { r = 0.267; g = 0.231; b = 0.208; a = 1.0 }
(* stone_800 is already in sx_native_types *)
let stone_900 = { r = 0.106; g = 0.098; b = 0.090; a = 1.0 }
let violet_50 = { r = 0.961; g = 0.953; b = 1.0; a = 1.0 }
let violet_100 = { r = 0.929; g = 0.906; b = 0.996; a = 1.0 }
let violet_200 = { r = 0.867; g = 0.820; b = 0.992; a = 1.0 }
let violet_300 = { r = 0.769; g = 0.686; b = 0.984; a = 1.0 }
let violet_400 = { r = 0.655; g = 0.525; b = 0.969; a = 1.0 }
let violet_500 = { r = 0.545; g = 0.361; b = 0.945; a = 1.0 }
let violet_600 = { r = 0.486; g = 0.227; b = 0.929; a = 1.0 }
let violet_700 = { r = 0.427; g = 0.176; b = 0.831; a = 1.0 }
let violet_800 = { r = 0.357; g = 0.153; b = 0.694; a = 1.0 }
let violet_900 = { r = 0.298; g = 0.133; b = 0.576; a = 1.0 }
let red_500 = { r = 0.937; g = 0.267; b = 0.267; a = 1.0 }
let red_600 = { r = 0.863; g = 0.145; b = 0.145; a = 1.0 }
let blue_500 = { r = 0.231; g = 0.510; b = 0.965; a = 1.0 }
let blue_600 = { r = 0.145; g = 0.388; b = 0.922; a = 1.0 }
let green_500 = { r = 0.133; g = 0.773; b = 0.369; a = 1.0 }
let green_600 = { r = 0.086; g = 0.635; b = 0.290; a = 1.0 }
let amber_500 = { r = 0.961; g = 0.718; b = 0.078; a = 1.0 }
(* -- Spacing scale (Tailwind: 1 unit = 4px) -- *)
let spacing n = float_of_int n *. 4.0
(* -- Font sizes (Tailwind) -- *)
let font_size_of = function
| "text-xs" -> 12.
| "text-sm" -> 14.
| "text-base" -> 16.
| "text-lg" -> 18.
| "text-xl" -> 20.
| "text-2xl" -> 24.
| "text-3xl" -> 30.
| "text-4xl" -> 36.
| "text-5xl" -> 48.
| _ -> 16.
(* -- Parse a single Tailwind class, mutating a style -- *)
let parse_spacing_value s =
(* Extract numeric value from strings like "p-4", "gap-2" *)
match int_of_string_opt s with
| Some n -> spacing n
| None -> 0.
let bg_color_of cls =
match cls with
| "bg-white" -> Some white
| "bg-black" -> Some black
| "bg-stone-50" -> Some stone_50
| "bg-stone-100" -> Some stone_100
| "bg-stone-200" -> Some stone_200
| "bg-stone-300" -> Some stone_300
| "bg-stone-400" -> Some stone_400
| "bg-stone-500" -> Some stone_500
| "bg-stone-600" -> Some stone_600
| "bg-stone-700" -> Some stone_700
| "bg-stone-800" -> Some stone_800
| "bg-stone-900" -> Some stone_900
| "bg-violet-50" -> Some violet_50
| "bg-violet-100" -> Some violet_100
| "bg-violet-200" -> Some violet_200
| "bg-violet-300" -> Some violet_300
| "bg-violet-400" -> Some violet_400
| "bg-violet-500" -> Some violet_500
| "bg-violet-600" -> Some violet_600
| "bg-violet-700" -> Some violet_700
| "bg-violet-800" -> Some violet_800
| "bg-violet-900" -> Some violet_900
| "bg-red-500" -> Some red_500
| "bg-red-600" -> Some red_600
| "bg-blue-500" -> Some blue_500
| "bg-blue-600" -> Some blue_600
| "bg-green-500" -> Some green_500
| "bg-green-600" -> Some green_600
| "bg-amber-500" -> Some amber_500
| _ -> None
let text_color_of cls =
match cls with
| "text-white" -> Some white
| "text-black" -> Some black
| "text-stone-50" -> Some stone_50
| "text-stone-100" -> Some stone_100
| "text-stone-200" -> Some stone_200
| "text-stone-300" -> Some stone_300
| "text-stone-400" -> Some stone_400
| "text-stone-500" -> Some stone_500
| "text-stone-600" -> Some stone_600
| "text-stone-700" -> Some stone_700
| "text-stone-800" -> Some stone_800
| "text-stone-900" -> Some stone_900
| "text-violet-50" -> Some violet_50
| "text-violet-100" -> Some violet_100
| "text-violet-200" -> Some violet_200
| "text-violet-300" -> Some violet_300
| "text-violet-400" -> Some violet_400
| "text-violet-500" -> Some violet_500
| "text-violet-600" -> Some violet_600
| "text-violet-700" -> Some violet_700
| "text-violet-800" -> Some violet_800
| "text-violet-900" -> Some violet_900
| "text-red-500" -> Some red_500
| "text-red-600" -> Some red_600
| "text-blue-500" -> Some blue_500
| "text-blue-600" -> Some blue_600
| "text-green-500" -> Some green_500
| "text-green-600" -> Some green_600
| "text-amber-500" -> Some amber_500
| _ -> None
let border_color_of cls =
match cls with
| "border-stone-100" -> Some stone_100
| "border-stone-200" -> Some stone_200
| "border-stone-300" -> Some stone_300
| "border-violet-200" -> Some violet_200
| "border-violet-300" -> Some violet_300
| "border-white" -> Some white
| _ -> None
(** Apply a single Tailwind class to a style, returning the updated style. *)
let apply_class (s : style) (cls : string) : style =
(* Layout *)
if cls = "flex" then { s with display = `Flex; flex_direction = `Row }
else if cls = "flex-col" then { s with display = `Flex; flex_direction = `Column }
else if cls = "flex-row" then { s with display = `Flex; flex_direction = `Row }
else if cls = "block" then { s with display = `Block }
else if cls = "hidden" then { s with display = `None }
else if cls = "items-center" then { s with align_items = `Center }
else if cls = "items-start" then { s with align_items = `Start }
else if cls = "items-end" then { s with align_items = `End }
else if cls = "items-stretch" then { s with align_items = `Stretch }
else if cls = "justify-center" then { s with justify_content = `Center }
else if cls = "justify-between" then { s with justify_content = `Between }
else if cls = "justify-start" then { s with justify_content = `Start }
else if cls = "justify-end" then { s with justify_content = `End }
else if cls = "flex-grow" || cls = "grow" then { s with flex_grow = 1. }
(* Gap *)
else if String.length cls > 4 && String.sub cls 0 4 = "gap-" then
let n = String.sub cls 4 (String.length cls - 4) in
{ s with gap = parse_spacing_value n }
(* Padding *)
else if String.length cls > 2 && String.sub cls 0 2 = "p-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
let n = String.sub cls 2 (String.length cls - 2) in
let v = parse_spacing_value n in
{ s with padding = { top = v; right = v; bottom = v; left = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "px-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with padding = { s.padding with left = v; right = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "py-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with padding = { s.padding with top = v; bottom = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "pt-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with top = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pb-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with bottom = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pl-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with left = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pr-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with right = parse_spacing_value n } }
(* Margin *)
else if String.length cls > 2 && String.sub cls 0 2 = "m-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
let n = String.sub cls 2 (String.length cls - 2) in
let v = parse_spacing_value n in
{ s with margin = { top = v; right = v; bottom = v; left = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "mx-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with margin = { s.margin with left = v; right = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "my-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with margin = { s.margin with top = v; bottom = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "mt-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with margin = { s.margin with top = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "mb-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with margin = { s.margin with bottom = parse_spacing_value n } }
(* Sizing *)
else if cls = "w-full" then { s with width = `Full }
else if cls = "h-full" then { s with height = `Full }
else if String.length cls > 2 && String.sub cls 0 2 = "w-" then
let n = String.sub cls 2 (String.length cls - 2) in
(match int_of_string_opt n with
| Some v -> { s with width = `Px (float_of_int v *. 4.) }
| None -> s)
else if String.length cls > 2 && String.sub cls 0 2 = "h-" then
let n = String.sub cls 2 (String.length cls - 2) in
(match int_of_string_opt n with
| Some v -> { s with height = `Px (float_of_int v *. 4.) }
| None -> s)
(* Typography *)
else if cls = "font-bold" then { s with font_weight = `Bold }
else if cls = "font-semibold" then { s with font_weight = `Bold }
else if cls = "font-normal" then { s with font_weight = `Normal }
else if cls = "italic" then { s with font_style = `Italic }
else if cls = "font-mono" then { s with font_family = `Mono }
else if String.length cls >= 5 && String.sub cls 0 5 = "text-" then
(* Could be text color or text size *)
let rest = String.sub cls 5 (String.length cls - 5) in
if rest = "xs" || rest = "sm" || rest = "base" || rest = "lg"
|| rest = "xl" || rest = "2xl" || rest = "3xl" || rest = "4xl"
|| rest = "5xl" then
{ s with font_size = font_size_of cls }
else
(match text_color_of cls with
| Some c -> { s with text_color = c }
| None -> s)
(* Background *)
else if String.length cls >= 3 && String.sub cls 0 3 = "bg-" then
(match bg_color_of cls with
| Some c -> { s with bg_color = Some c }
| None -> s)
(* Borders *)
else if cls = "rounded" then { s with border_radius = 4. }
else if cls = "rounded-md" then { s with border_radius = 6. }
else if cls = "rounded-lg" then { s with border_radius = 8. }
else if cls = "rounded-xl" then { s with border_radius = 12. }
else if cls = "rounded-2xl" then { s with border_radius = 16. }
else if cls = "rounded-full" then { s with border_radius = 9999. }
else if cls = "border" then
{ s with border_width = 1.;
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
else if cls = "border-2" then
{ s with border_width = 2.;
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
else if String.length cls >= 7 && String.sub cls 0 7 = "border-" then
(match border_color_of cls with
| Some c -> { s with border_color = Some c;
border_width = (if s.border_width = 0. then 1. else s.border_width) }
| None -> s)
(* Shadow *)
else if cls = "shadow" then { s with shadow = `Sm }
else if cls = "shadow-md" then { s with shadow = `Md }
else if cls = "shadow-lg" then { s with shadow = `Md }
(* Overflow *)
else if cls = "overflow-hidden" then { s with overflow_hidden = true }
else s (* unknown class: ignore *)
(** Parse a space-separated Tailwind class string into a [style]. *)
let parse_classes ?(base = default_style) (classes : string) : style =
let parts = String.split_on_char ' ' classes in
List.fold_left (fun s cls ->
let cls = String.trim cls in
if cls = "" then s else apply_class s cls
) base parts

79
hosts/native/lib/sx_native_types.ml Normal file
View File

@@ -0,0 +1,79 @@
(** Types for the SX native render tree.
Every SX element is converted to a [node] with a [style] record
that the layout engine positions and the painter draws. *)
type color = { r: float; g: float; b: float; a: float }
type edges = { top: float; right: float; bottom: float; left: float }
type style = {
display: [`Flex | `Block | `None];
flex_direction: [`Row | `Column];
gap: float;
padding: edges;
margin: edges;
align_items: [`Start | `Center | `End | `Stretch];
justify_content: [`Start | `Center | `End | `Between];
flex_grow: float;
bg_color: color option;
text_color: color;
font_size: float;
font_weight: [`Normal | `Bold];
font_style: [`Normal | `Italic];
font_family: [`Sans | `Mono];
border_radius: float;
border_width: float;
border_color: color option;
width: [`Auto | `Px of float | `Full];
height: [`Auto | `Px of float | `Full];
shadow: [`None | `Sm | `Md];
overflow_hidden: bool;
}
type box = {
mutable x: float;
mutable y: float;
mutable w: float;
mutable h: float;
}
type node = {
tag: string;
style: style;
children: node list;
text: string option;
box: box;
href: string option;
on_click: (unit -> unit) option;
}
let zero_edges = { top = 0.; right = 0.; bottom = 0.; left = 0. }
let stone_800 = { r = 0.114; g = 0.094; b = 0.082; a = 1.0 }
let default_style = {
display = `Flex;
flex_direction = `Column;
gap = 0.;
padding = zero_edges;
margin = zero_edges;
align_items = `Stretch;
justify_content = `Start;
flex_grow = 0.;
bg_color = None;
text_color = stone_800;
font_size = 16.;
font_weight = `Normal;
font_style = `Normal;
font_family = `Sans;
border_radius = 0.;
border_width = 0.;
border_color = None;
width = `Auto;
height = `Auto;
shadow = `None;
overflow_hidden = false;
}
let make_box () = { x = 0.; y = 0.; w = 0.; h = 0. }