rose-ash/hosts/native/bin/sx_native_app.ml

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