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/bin/dune Normal file
View File

@@ -0,0 +1,3 @@
(executable
(name sx_native_app)
(libraries sx sx_native cairo2 tsdl unix))

276
hosts/native/bin/sx_native_app.ml Normal file
View File

@@ -0,0 +1,276 @@
(** SX Native Browser -- renders s-expressions directly to pixels.
A proof-of-concept desktop browser that parses .sx files and
renders them using SDL2 + Cairo, with no HTML/CSS/JS engine. *)
open Tsdl
open Sx_native
open Sx_native_types
(* -- Helpers for SDL result handling -- *)
let sdl_ok = function
| Ok v -> v
| Error (`Msg e) -> failwith ("SDL error: " ^ e)
(* -- State -- *)
type app_state = {
mutable current_url : string;
mutable root : node;
mutable needs_repaint : bool;
mutable win_w : int;
mutable win_h : int;
mutable scroll_y : float;
}
(* -- Parse and build render tree -- *)
let load_content (state : app_state) (source : string) (cr : Cairo.context) =
let values = Sx_parser.parse_all source in
let navigate href =
(* Simple navigation: if href starts with / or is a relative path, reload *)
Printf.printf "[navigate] %s\n%!" href;
state.current_url <- href;
(* In a full implementation, this would trigger a re-fetch and re-render *)
in
let root = Sx_native_render.render_page ~navigate values in
Sx_native_layout.measure cr root;
let w = float_of_int state.win_w in
let h = float_of_int state.win_h -. 36. in (* subtract URL bar *)
Sx_native_layout.layout root 0. 0. w h;
state.root <- root;
state.needs_repaint <- true
(* -- Hit testing -- *)
let rec hit_test (node : node) (x : float) (y : float) : node option =
let b = node.box in
if x >= b.x && x <= b.x +. b.w && y >= b.y && y <= b.y +. b.h then begin
(* Check children in reverse order (topmost first) *)
let child_hit = List.fold_left (fun acc child ->
match acc with
| Some _ -> acc
| None -> hit_test child x y
) None (List.rev node.children) in
match child_hit with
| Some _ -> child_hit
| None -> Some node
end
else None
let handle_click (state : app_state) (root : node) (x : float) (y : float) =
(* Offset y by URL bar height for hit testing *)
let adjusted_y = y -. 36. -. state.scroll_y in
match hit_test root x adjusted_y with
| Some node ->
(match node.on_click with
| Some f -> f ()
| None ->
match node.href with
| Some href ->
Printf.printf "[click] link: %s\n%!" href;
state.current_url <- href
| None ->
Printf.printf "[click] %s at (%.0f, %.0f)\n%!" node.tag x y)
| None ->
Printf.printf "[click] miss at (%.0f, %.0f)\n%!" x y
(* -- Default demo content -- *)
let demo_sx = {|
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div :class "flex gap-4 items-center"
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div :class "p-6 rounded-lg bg-violet-600"
(p :class "text-white text-lg font-bold" "5,000 lines of OCaml instead of 35 million lines of browser engine")))
|}
(* -- Main -- *)
let () =
(* Parse command line *)
let source = ref "" in
let url = ref "sx://demo" in
let args = Array.to_list Sys.argv in
(match args with
| _ :: file :: _ when Sys.file_exists file ->
source := Sx_native_fetch.read_file file;
url := "file://" ^ file
| _ :: path :: _ when String.length path > 0 ->
(try
source := Sx_native_fetch.fetch_page path;
url := path
with _ ->
Printf.eprintf "Failed to fetch %s, using demo content\n%!" path;
source := demo_sx;
url := "sx://demo")
| _ ->
source := demo_sx);
(* Initialize SDL2 *)
sdl_ok (Sdl.init Sdl.Init.(video + events));
at_exit Sdl.quit;
let initial_w = 1024 in
let initial_h = 768 in
let window = sdl_ok (Sdl.create_window "SX Browser"
~x:Sdl.Window.pos_centered ~y:Sdl.Window.pos_centered
~w:initial_w ~h:initial_h
Sdl.Window.(shown + resizable + allow_highdpi)) in
let renderer = sdl_ok (Sdl.create_renderer window
~flags:Sdl.Renderer.(accelerated + presentvsync)) in
(* Create SDL texture for Cairo to draw into *)
let create_texture w h =
sdl_ok (Sdl.create_texture renderer Sdl.Pixel.format_argb8888
Sdl.Texture.access_streaming ~w ~h)
in
let texture = ref (create_texture initial_w initial_h) in
(* Create Cairo surface *)
let create_cairo_surface w h =
Cairo.Image.create Cairo.Image.ARGB32 ~w ~h
in
let surface = ref (create_cairo_surface initial_w initial_h) in
let cr = ref (Cairo.create !surface) in
(* App state *)
let state = {
current_url = !url;
root = { tag = "root"; style = default_style; children = [];
text = None; box = make_box (); href = None; on_click = None };
needs_repaint = true;
win_w = initial_w;
win_h = initial_h;
scroll_y = 0.;
} in
(* Initial load *)
load_content state !source !cr;
(* Main event loop *)
let event = Sdl.Event.create () in
let running = ref true in
while !running do
(* Process all pending events *)
while Sdl.poll_event (Some event) do
let typ = Sdl.Event.get event Sdl.Event.typ in
if typ = Sdl.Event.quit then
running := false
else if typ = Sdl.Event.key_down then begin
let scancode = Sdl.Event.get event Sdl.Event.keyboard_scancode in
if scancode = Sdl.Scancode.escape then
running := false
else if scancode = Sdl.Scancode.up then begin
state.scroll_y <- Float.min 0. (state.scroll_y +. 40.);
state.needs_repaint <- true
end
else if scancode = Sdl.Scancode.down then begin
state.scroll_y <- state.scroll_y -. 40.;
state.needs_repaint <- true
end
else if scancode = Sdl.Scancode.home then begin
state.scroll_y <- 0.;
state.needs_repaint <- true
end
end
else if typ = Sdl.Event.mouse_button_down then begin
let mx = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_x) in
let my = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_y) in
handle_click state state.root mx my
end
else if typ = Sdl.Event.mouse_wheel then begin
let wy = Sdl.Event.get event Sdl.Event.mouse_wheel_y in
state.scroll_y <- state.scroll_y +. (float_of_int wy *. 40.);
if state.scroll_y > 0. then state.scroll_y <- 0.;
state.needs_repaint <- true
end
else if typ = Sdl.Event.window_event then begin
let wev = Sdl.Event.get event Sdl.Event.window_event_id in
if wev = Sdl.Event.window_event_resized
|| wev = Sdl.Event.window_event_size_changed
|| wev = Sdl.Event.window_event_exposed then begin
let (new_w, new_h) = Sdl.get_window_size window in
if new_w <> state.win_w || new_h <> state.win_h then begin
state.win_w <- new_w;
state.win_h <- new_h;
(* Recreate texture and surface at new size *)
Sdl.destroy_texture !texture;
texture := create_texture new_w new_h;
Cairo.Surface.finish !surface;
surface := create_cairo_surface new_w new_h;
cr := Cairo.create !surface;
(* Re-layout *)
Sx_native_layout.measure !cr state.root;
let w = float_of_int new_w in
let h = float_of_int new_h -. 36. in
Sx_native_layout.layout state.root 0. 0. w h
end;
state.needs_repaint <- true
end
end
done;
(* Paint if needed *)
if state.needs_repaint then begin
state.needs_repaint <- false;
let w = float_of_int state.win_w in
let h = float_of_int state.win_h in
(* Apply scroll offset to root *)
state.root.box.y <- state.scroll_y;
Sx_native_paint.paint_scene !cr state.root state.current_url w h;
Cairo.Surface.flush !surface;
(* Restore root position *)
state.root.box.y <- 0.;
(* Copy Cairo surface data to SDL texture *)
let data = Cairo.Image.get_data8 !surface in
let stride = Bigarray.Array1.dim data / state.win_h in
(* Lock texture, copy data, unlock *)
(match Sdl.lock_texture !texture None Bigarray.int8_unsigned with
| Ok (pixels, _pitch) ->
let src_len = Bigarray.Array1.dim data in
let dst_len = Bigarray.Array1.dim pixels in
let copy_len = min src_len dst_len in
for i = 0 to copy_len - 1 do
Bigarray.Array1.set pixels i (Bigarray.Array1.get data i)
done;
ignore stride;
Sdl.unlock_texture !texture
| Error (`Msg e) ->
Printf.eprintf "lock_texture error: %s\n%!" e);
(* Present *)
ignore (Sdl.render_clear renderer);
ignore (Sdl.render_copy renderer !texture);
Sdl.render_present renderer
end;
Sdl.delay 16l (* ~60 fps cap *)
done;
(* Cleanup *)
Sdl.destroy_texture !texture;
Sdl.destroy_renderer renderer;
Sdl.destroy_window window

25
hosts/native/demo/counter.sx Normal file
View File

@@ -0,0 +1,25 @@
(div
:class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div
:class "flex gap-4 items-center"
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p
:class "text-sm text-stone-500"
"Tailwind classes parsed to native styles"))
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div
:class "p-6 rounded-lg bg-violet-600"
(p
:class "text-white text-lg font-bold"
"5,000 lines of OCaml instead of 35 million lines of browser engine")))

2
hosts/native/dune-project Normal file
View File

@@ -0,0 +1,2 @@
(lang dune 3.19)
(name sx_native)

2
hosts/native/dune-workspace Normal file
View File

@@ -0,0 +1,2 @@
(lang dune 3.19)
(context default)

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. }

1
hosts/native/lib_sx Symbolic link
View File

@@ -0,0 +1 @@
../../hosts/ocaml/lib

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

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

75
hosts/native/test/test_render.ml Normal file
View File

@@ -0,0 +1,75 @@
(** Smoke test: parse SX, render to node tree, measure, layout, paint to PNG. *)
open Sx_native.Sx_native_types
let demo_sx = {|
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div :class "flex gap-4 items-center"
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div :class "p-6 rounded-lg bg-violet-600"
(p :class "text-white text-lg font-bold" "5000 lines of OCaml instead of 35 million lines of browser engine")))
|}
let rec count_nodes (node : node) : int =
1 + List.fold_left (fun acc c -> acc + count_nodes c) 0 node.children
let rec print_tree indent (node : node) =
let prefix = String.make (indent * 2) ' ' in
let text_info = match node.text with
| Some t -> Printf.sprintf " \"%s\"" (if String.length t > 30 then String.sub t 0 30 ^ "..." else t)
| None -> ""
in
let size_info = Printf.sprintf " [%.0fx%.0f @ (%.0f,%.0f)]" node.box.w node.box.h node.box.x node.box.y in
Printf.printf "%s<%s>%s%s\n" prefix node.tag text_info size_info;
List.iter (print_tree (indent + 1)) node.children
let () =
Printf.printf "=== SX Native Browser Smoke Test ===\n\n";
(* 1. Parse *)
let values = Sx_parser.parse_all demo_sx in
Printf.printf "1. Parsed %d top-level form(s)\n" (List.length values);
(* 2. Render to node tree *)
let root = Sx_native.Sx_native_render.render_page values in
let n = count_nodes root in
Printf.printf "2. Render tree: %d nodes, root tag=%s\n" n root.tag;
(* 3. Create Cairo surface for measurement *)
let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w:1024 ~h:768 in
let cr = Cairo.create surface in
(* 4. Measure *)
Sx_native.Sx_native_layout.measure cr root;
Printf.printf "3. Measured intrinsic size: %.0f x %.0f\n" root.box.w root.box.h;
(* 5. Layout *)
Sx_native.Sx_native_layout.layout root 0. 0. 1024. 732.;
Printf.printf "4. Layout complete, root positioned at (%.0f, %.0f) size %.0f x %.0f\n"
root.box.x root.box.y root.box.w root.box.h;
(* 6. Paint *)
Sx_native.Sx_native_paint.paint_scene cr root "sx://demo" 1024. 768.;
Cairo.Surface.flush surface;
(* 7. Write PNG *)
let png_path = "/tmp/sx_browser_test.png" in
Cairo.PNG.write surface png_path;
Printf.printf "5. Rendered to %s\n\n" png_path;
(* Print tree *)
Printf.printf "=== Render Tree ===\n";
print_tree 0 root;
Cairo.Surface.finish surface;
Printf.printf "\n=== All OK! ===\n"