diff --git a/platform/native/lui_window/lui_window.ml b/platform/native/lui_window/lui_window.ml index 91e6aaf7..1136712c 100644 --- a/platform/native/lui_window/lui_window.ml +++ b/platform/native/lui_window/lui_window.ml @@ -1743,6 +1743,86 @@ module Frame = struct t.last_present_ms <- now_ms end +module Renderer_ladder = struct + (* The renderer-ladder walk shared by the platform drivers. A ladder + is an ordered list of backend rungs (Vulkan/Gl/Cpu/Noop on Linux, + D3d11/Gl/Cpu/Noop on Windows): [walk] tries each rung's init left + to right — [try_rung] returning [None] steps down — and records + the untried tail so a mid-render failure can [demote] the active + rung and resume the walk below it. The platform supplies the + per-rung init (SDL/GL/Vulkan/D3D11 specifics), a [release] for + the dropped rung's resources and an optional [before_walk] hook + (the SDL driver re-creates its window there when the next rung + needs different flags); the sequencing, loss logging and the + exception-catching [renderer_live] wrapper live here once so the + fallback path can be exercised off-device. *) + + type 'a attempt = { + renderer : Lui_host.renderer; + state : 'a; + (** rung payload the driver reads back — e.g. the live-GL flag + or the D3D11 device held for shutdown *) + } + + type ('rung, 'a) t = { + warn : string -> unit; + release : 'a attempt -> unit; + before_walk : 'rung list -> unit; + exhausted_msg : string; + noop : 'a attempt; + try_rung : 'rung -> rest:'rung list -> 'a attempt option; + mutable remaining : 'rung list; + mutable active : 'a attempt; + } + + let rec walk t = function + | [] -> + t.remaining <- []; + t.warn t.exhausted_msg; + t.noop + | rung :: rest -> + (* The tail lands in [remaining] before the try so a later + demote resumes strictly below the active rung — a backend + that already lost its device is never retried. *) + t.remaining <- rest; + (match t.try_rung rung ~rest with + | Some a -> a + | None -> walk t rest) + + let create ~warn ~release ?(before_walk = fun _ -> ()) + ?(exhausted_msg = + "all renderer rungs failed; using no-op loop renderer") + ~noop ~try_rung rungs = + let t = + { warn; release; before_walk; exhausted_msg; noop; try_rung; + remaining = []; active = noop } + in + t.active <- walk t rungs; + t + + let active t = t.active + let remaining t = t.remaining + + let demote t ~reason = + t.warn + (Printf.sprintf "renderer %s lost (%s); stepping down the ladder" + t.active.renderer.Lui_host.name reason); + t.release t.active; + t.before_walk t.remaining; + t.active <- walk t t.remaining + + (* The host owns a stable record whose render delegates to the live + rung, so a demote needs no host rebuild. *) + let renderer_live t = + { Lui_host.name = "lui (resilient)"; + render = + (fun s -> + try t.active.renderer.Lui_host.render s + with exn -> + demote t ~reason:(Printexc.to_string exn); + t.active.renderer.Lui_host.render s) } +end + module Multi = struct (* Multi-window manager: a registry of independent surfaces. Each surface owns a full pipeline — host (store, layout, scene, diff --git a/platform/native/lui_window/lui_window.mli b/platform/native/lui_window/lui_window.mli index 94f407dd..6a88b9b6 100644 --- a/platform/native/lui_window/lui_window.mli +++ b/platform/native/lui_window/lui_window.mli @@ -523,6 +523,59 @@ module Frame : sig interval. *) end +(** The renderer-ladder walk shared by the platform drivers. + + A ladder is an ordered list of backend rungs; {!create} tries each + rung's init left to right — [try_rung] returning [None] steps + down — and records the untried tail so a mid-render failure can + {!demote} the active rung and resume the walk below it. The + platform supplies the per-rung init, a [release] for the dropped + rung's resources and an optional [before_walk] hook (used to + re-create the OS window when the next rung needs different + flags); the sequencing, loss logging and the exception-catching + {!renderer_live} wrapper live here once so the fallback path can + be exercised with injected rung failures off-device. *) +module Renderer_ladder : sig + type 'a attempt = { + renderer : Lui_host.renderer; + state : 'a; + (** rung payload the driver reads back — e.g. the live-GL flag + or the D3D11 device held for shutdown *) + } + + type ('rung, 'a) t + + val create : + warn:(string -> unit) -> + release:('a attempt -> unit) -> + ?before_walk:('rung list -> unit) -> + ?exhausted_msg:string -> + noop:'a attempt -> + try_rung:('rung -> rest:'rung list -> 'a attempt option) -> + 'rung list -> ('rung, 'a) t + (** [create ~warn ~release ~noop ~try_rung rungs] walks [rungs], + returning the state with the first successful rung active. + [try_rung rung ~rest] is the platform's init for one rung: + [Some attempt] on success, [None] to step down. [noop] is the + terminal attempt used when every rung fails; [release] drops a + demoted rung's resources; [before_walk] runs once per demote + with the remaining rungs (the SDL driver re-creates its window + there); [exhausted_msg] customises the empty-walk warning. *) + + val active : ('rung, 'a) t -> 'a attempt + val remaining : ('rung, 'a) t -> 'rung list + (** Rungs below the active one — what a demote will walk. *) + + val demote : ('rung, 'a) t -> reason:string -> unit + (** Drop the active rung (release + warn) and resume the walk at + {!remaining}. *) + + val renderer_live : ('rung, 'a) t -> Lui_host.renderer + (** A stable renderer record whose render delegates to the active + rung: a render exception demotes once and retries on the next + rung inside the same call, so the host needs no rebuild. *) +end + (** Multi-window manager: a registry of independent surfaces. Each surface owns a full pipeline — {!Lui_host} (store, layout, diff --git a/platform/native/lui_window_linux/main.ml b/platform/native/lui_window_linux/main.ml index ace14cc7..aba5303a 100644 --- a/platform/native/lui_window_linux/main.ml +++ b/platform/native/lui_window_linux/main.ml @@ -182,176 +182,197 @@ let () = (* Walk the ladder: each rung either yields a renderer or warns and the next rung gets its chance. GL needs the opengl-flagged window — when an earlier rung fails into the Gl rung the window - is recreated with the flag. [remaining] keeps the rungs below - the active one so a runtime demotion can re-walk the tail. *) + is recreated with the flag. The walk/demote sequencing lives in + [Lui_window.Renderer_ladder]; this supplies the per-rung init and + the window re-fit the demote path needs. *) let blit_cell = ref None in let vk_cell = ref None in let gctx_cell = ref None in - let remaining = ref [] in - let renderer, gl_live, attempt = - let mk_blit () = + let mk_blit () = + let dw, dh = + match Sdl.gl_get_drawable_size !win with + | 0, 0 -> (cfg.width, cfg.height) + | d -> d + in + match Lui_blit.create !win ~w:dw ~h:dh with + | Error m -> + warn "lui_blit.create failed: %s" m; + None + | Ok b -> + blit_cell := Some b; + Some b + in + let try_rung rung ~rest = + let attempt renderer state = + Some { Renderer_ladder.renderer; state } + in + match rung with + | Lui_linux.Noop -> attempt Lui_linux.noop_renderer false + | Lui_linux.Cpu -> ( + match mk_blit () with + | None -> None + | Some b -> + let rr = Lui_raster.Renderer.create () in + log "renderer: lui_raster+blit"; + attempt + { Lui_host.name = "lui_raster+blit"; + render = + (fun s -> + let dirty = Lui_raster.Renderer.render rr s in + let img = Lui_raster.Renderer.image rr in + let stride = img.Lui_raster.Image.stride / 4 in + if Lui_raster.Renderer.whole rr || dirty = [] then + ignore + (Lui_blit.update b ~pix:img.Lui_raster.Image.pix + ~stride) + else + List.iter + (fun (r : Lui_scene.irect) -> + ignore + (Lui_blit.update_region b ~x0:r.x0 ~y0:r.y0 + ~x1:r.x1 ~y1:r.y1 + ~pix:img.Lui_raster.Image.pix ~stride)) + dirty; + Lui_blit.present b; + img.Lui_raster.Image.pix) } + false) + | Lui_linux.Vulkan -> ( let dw, dh = match Sdl.gl_get_drawable_size !win with | 0, 0 -> (cfg.width, cfg.height) | d -> d in - match Lui_blit.create !win ~w:dw ~h:dh with + match Lui_vulkan.init ~w:dw ~h:dh with | Error m -> - warn "lui_blit.create failed: %s" m; + warn "lui_vulkan.init failed: %s" m; + if List.mem Lui_linux.Gl rest && not headless then begin + (* The GL rung next needs an opengl-flagged window. *) + Sdl.destroy_window !win; + win := + sdl_ok + (Sdl.create_window "lui_window_linux" ~w:cfg.width + ~h:cfg.height (flags true)) + end; None - | Ok b -> - blit_cell := Some b; - Some b - in - let rec attempt = function - | [] -> - remaining := []; - warn "all renderers unavailable; using no-op loop renderer"; - (Lui_linux.noop_renderer, false) - | Lui_linux.Noop :: _ -> - remaining := []; - (Lui_linux.noop_renderer, false) - | Lui_linux.Cpu :: rest -> - remaining := rest; - (match mk_blit () with - | None -> attempt rest - | Some b -> - let rr = Lui_raster.Renderer.create () in - log "renderer: lui_raster+blit"; - ( { Lui_host.name = "lui_raster+blit"; - render = - (fun s -> - let dirty = Lui_raster.Renderer.render rr s in - let img = Lui_raster.Renderer.image rr in - let stride = img.Lui_raster.Image.stride / 4 in - if Lui_raster.Renderer.whole rr || dirty = [] then - ignore - (Lui_blit.update b ~pix:img.Lui_raster.Image.pix - ~stride) - else - List.iter - (fun (r : Lui_scene.irect) -> - ignore - (Lui_blit.update_region b ~x0:r.x0 ~y0:r.y0 - ~x1:r.x1 ~y1:r.y1 - ~pix:img.Lui_raster.Image.pix ~stride)) - dirty; - Lui_blit.present b; - img.Lui_raster.Image.pix) }, - false )) - | Lui_linux.Vulkan :: rest -> - remaining := rest; - let dw, dh = - match Sdl.gl_get_drawable_size !win with - | 0, 0 -> (cfg.width, cfg.height) - | d -> d - in - (match Lui_vulkan.init ~w:dw ~h:dh with - | Error m -> - warn "lui_vulkan.init failed: %s" m; - if List.mem Lui_linux.Gl rest && not headless then begin - (* The GL rung next needs an opengl-flagged window. *) - Sdl.destroy_window !win; - win := - sdl_ok - (Sdl.create_window "lui_window_linux" ~w:cfg.width - ~h:cfg.height (flags true)) - end; - attempt rest - | Ok v -> - log "renderer: lui_vulkan (device %s, dual=%b)" - (Lui_vulkan.driver v) (Lui_vulkan.dual v); - vk_cell := Some v; - let b = mk_blit () in - ( { Lui_host.name = "lui_vulkan+blit"; - render = - (fun s -> - (* The offscreen frame image is sized at init; a - resized scene forces a re-init. On failure the - rung degrades to a zeroed frame — no crash. *) - let v = - match !vk_cell with - | Some v -> Some v - | None -> ( - match - Lui_vulkan.init ~w:s.Lui_scene.width - ~h:s.Lui_scene.height - with - | Ok v' -> vk_cell := Some v'; Some v' - | Error _ -> None) - in - match v with - | None -> - Bytes.create (s.Lui_scene.width * s.Lui_scene.height * 4) - | Some v -> ( - try - Lui_vulkan.render v s; - let pix = - Lui_vulkan.read_frame v ~w:s.Lui_scene.width - ~h:s.Lui_scene.height - in - (match b with - | Some b -> - ignore - (Lui_blit.update b ~pix - ~stride:s.Lui_scene.width); - Lui_blit.present b - | None -> ()); - pix - with - | Lui_vulkan.Error m -> - warn "lui_vulkan.render: %s" m; - Bytes.create - (s.Lui_scene.width * s.Lui_scene.height * 4))) }, - false )) - | Lui_linux.Gl :: rest -> - remaining := rest; - if headless then begin - (* The dummy driver has no GL to give. *) - attempt rest - end - else - (match Sdl.gl_create_context !win with - | Error (`Msg m) -> - warn "gl_create_context failed: %s" m; - Sdl.destroy_window !win; - win := - sdl_ok - (Sdl.create_window "lui_window_linux" ~w:cfg.width - ~h:cfg.height (flags false)); - attempt rest - | Ok c -> - sdl_ok (Sdl.gl_make_current !win c); - (match Lui_gl.init () with - | Ok gl -> - gctx_cell := Some c; - log "renderer: Lui_gl"; - ( { Lui_host.name = "lui_gl"; - render = - (fun s -> - try - Lui_gl.render gl s; - Bytes.empty - with - | Lui_gl.Error m -> - warn "lui_gl.render: %s" m; - Bytes.create - (s.Lui_scene.width * s.Lui_scene.height * 4)) }, - true ) - | Error m -> - warn "lui_gl.init failed: %s" m; - Sdl.gl_delete_context c; - Sdl.destroy_window !win; - win := - sdl_ok - (Sdl.create_window "lui_window_linux" ~w:cfg.width - ~h:cfg.height (flags false)); - attempt rest)) - in - let r, g = attempt ladder in - (r, g, attempt) + | Ok v -> + log "renderer: lui_vulkan (device %s, dual=%b)" + (Lui_vulkan.driver v) (Lui_vulkan.dual v); + vk_cell := Some v; + let b = mk_blit () in + attempt + { Lui_host.name = "lui_vulkan+blit"; + render = + (fun s -> + (* The offscreen frame image is sized at init; a + resized scene forces a re-init. On failure the + rung degrades to a zeroed frame — no crash. *) + let v = + match !vk_cell with + | Some v -> Some v + | None -> ( + match + Lui_vulkan.init ~w:s.Lui_scene.width + ~h:s.Lui_scene.height + with + | Ok v' -> vk_cell := Some v'; Some v' + | Error _ -> None) + in + match v with + | None -> + Bytes.create (s.Lui_scene.width * s.Lui_scene.height * 4) + | Some v -> ( + try + Lui_vulkan.render v s; + let pix = + Lui_vulkan.read_frame v ~w:s.Lui_scene.width + ~h:s.Lui_scene.height + in + (match b with + | Some b -> + ignore + (Lui_blit.update b ~pix + ~stride:s.Lui_scene.width); + Lui_blit.present b + | None -> ()); + pix + with + | Lui_vulkan.Error m -> + warn "lui_vulkan.render: %s" m; + Bytes.create + (s.Lui_scene.width * s.Lui_scene.height * 4))) } + false) + | Lui_linux.Gl -> + if headless then begin + (* The dummy driver has no GL to give. *) + None + end + else + (match Sdl.gl_create_context !win with + | Error (`Msg m) -> + warn "gl_create_context failed: %s" m; + Sdl.destroy_window !win; + win := + sdl_ok + (Sdl.create_window "lui_window_linux" ~w:cfg.width + ~h:cfg.height (flags false)); + None + | Ok c -> + sdl_ok (Sdl.gl_make_current !win c); + (match Lui_gl.init () with + | Ok gl -> + gctx_cell := Some c; + log "renderer: Lui_gl"; + attempt + { Lui_host.name = "lui_gl"; + render = + (fun s -> + try + Lui_gl.render gl s; + Bytes.empty + with + | Lui_gl.Error m -> + warn "lui_gl.render: %s" m; + Bytes.create + (s.Lui_scene.width * s.Lui_scene.height * 4)) } + true + | Error m -> + warn "lui_gl.init failed: %s" m; + Sdl.gl_delete_context c; + Sdl.destroy_window !win; + win := + sdl_ok + (Sdl.create_window "lui_window_linux" ~w:cfg.width + ~h:cfg.height (flags false)); + None)) in let vk_state = vk_cell in + let ladder_t = + Renderer_ladder.create + ~warn:(fun m -> warn "%s" m) + ~release:(fun _ -> + (match !gctx_cell with + | Some c -> Sdl.gl_delete_context c; gctx_cell := None + | None -> ()); + (match !vk_cell with + | Some v -> Lui_vulkan.release v; vk_cell := None + | None -> ()); + blit_cell := None) + ~before_walk:(fun rest -> + (* Re-flag the window for the rung about to be tried. *) + let next_gl = + match rest with Lui_linux.Gl :: _ -> true | _ -> false + in + Sdl.destroy_window !win; + win := + sdl_ok + (Sdl.create_window "lui_window_linux" ~w:cfg.width + ~h:cfg.height (flags (next_gl && not headless)))) + ~exhausted_msg:"all renderers unavailable; using no-op loop renderer" + ~noop:{ Renderer_ladder.renderer = Lui_linux.noop_renderer; + state = false } + ~try_rung ladder + in + let gl_live () = (Renderer_ladder.active ladder_t).state in (* Runtime backend-loss recovery. An SDL render-target/device reset event (0x2000/0x2001) or a render exception demotes the active rung to the next ladder entry — the window is re-flagged for the @@ -359,40 +380,10 @@ let () = scene store is untouched, so the next repaint re-uploads a full scene — identical pixels on the CPU path by the parity contract. *) - let renderer_cell = ref renderer and gl_live_cell = ref gl_live in - let demote reason = - warn "renderer %s lost (%s); stepping down the ladder" - (!renderer_cell).Lui_host.name reason; - (match !gctx_cell with - | Some c -> Sdl.gl_delete_context c; gctx_cell := None - | None -> ()); - (match !vk_cell with - | Some v -> Lui_vulkan.release v; vk_cell := None - | None -> ()); - blit_cell := None; - let next_gl = - match !remaining with Lui_linux.Gl :: _ -> true | _ -> false - in - Sdl.destroy_window !win; - win := - sdl_ok - (Sdl.create_window "lui_window_linux" ~w:cfg.width ~h:cfg.height - (flags (next_gl && not headless))); - let r, g = attempt !remaining in - renderer_cell := r; - gl_live_cell := g - in + let demote reason = Renderer_ladder.demote ladder_t ~reason in (* The host owns a stable record whose render delegates to the live rung, so a demote needs no host rebuild. *) - let renderer_live = - { Lui_host.name = "lui (resilient)"; - render = - (fun s -> - try (!renderer_cell).Lui_host.render s - with exn -> - demote (Printexc.to_string exn); - (!renderer_cell).Lui_host.render s) } - in + let renderer_live = Renderer_ladder.renderer_live ladder_t in let vsync = match !gctx_cell with | Some _ -> (match Sdl.gl_set_swap_interval 1 with @@ -627,7 +618,7 @@ let () = | None -> true) in log "lui_window_linux: %dx%d drawable (scale %.2f), renderer=%s%s" - dw dh scale (!renderer_cell).Lui_host.name + dw dh scale (Renderer_ladder.active ladder_t).renderer.Lui_host.name (if headless then " [headless]" else ""); while continue () do let t0 = perf_s () in @@ -660,16 +651,16 @@ let () = let dirty = headless || Ui.want_frame ui host in if dirty then begin ignore (Assembly.repaint asm); - if !gl_live_cell then Sdl.gl_swap_window !win; + if gl_live () then Sdl.gl_swap_window !win; Ui.frame_done ui; incr frame; Checksum.add_scene checksum (Lui_host.scene host); - if headless && not !gl_live_cell then + if headless && not (gl_live ()) then log "frame=%d ops=%d" !frame (List.length (Lui_host.scene host).Lui_scene.ops); stats_update st ((perf_s () -. t0) *. 1000.); if !frame mod 60 = 0 then - stats_report st (!renderer_cell).Lui_host.name + stats_report st (Renderer_ladder.active ladder_t).renderer.Lui_host.name end; (* No vsync under the dummy driver and possibly none elsewhere: pace the loop explicitly. An idle iteration (no repaint) also @@ -683,7 +674,7 @@ let () = else if not dirty then Sdl.delay 4l end done; - stats_report st (!renderer_cell).Lui_host.name; + stats_report st (Renderer_ladder.active ladder_t).renderer.Lui_host.name; (match frames_target with | Some _ -> log "headless done: frames=%d checksum=%016Lx" !frame diff --git a/platform/native/lui_window_linux/test/lui_window_linux_test.ml b/platform/native/lui_window_linux/test/lui_window_linux_test.ml index 94a764f3..bab76ce9 100644 --- a/platform/native/lui_window_linux/test/lui_window_linux_test.ml +++ b/platform/native/lui_window_linux/test/lui_window_linux_test.ml @@ -81,6 +81,72 @@ let test_ladder () = let pix = Lui_linux.noop_renderer.Lui_host.render scene in Alcotest.(check int) "noop bytes" (5 * 3 * 4) (Bytes.length pix) +(* The real walk/demote path the driver uses: injected init failures + step down the ladder at startup, and a mid-render device loss + demotes inside the same render call — not a CPU->CPU comparison. *) +let test_ladder_demote () = + let module RL = Renderer_ladder in + let scene () = + let s = + Lui_scene.create ~mask_atlas:(Atlas.create ~bpp:1 ~w:8 ~h:8) + ~color_atlas:(Atlas.create ~bpp:4 ~w:8 ~h:8) + in + s.Lui_scene.width <- 2; + s.Lui_scene.height <- 1; + s + in + let tried = ref [] and released = ref [] in + let cpu_live = ref true in + let cpu_pix = Bytes.make 8 '\xAB' in + let cpu = + { RL.renderer = + { Lui_host.name = "mock-cpu"; + render = + (fun _ -> + if !cpu_live then cpu_pix else failwith "device lost") }; + state = `cpu } + in + let noop = + { RL.renderer = Lui_linux.noop_renderer; state = `noop } + in + let try_rung rung ~rest:_ = + tried := rung :: !tried; + match rung with + (* injected GPU init failures: no Vulkan device, no GL context *) + | Lui_linux.Vulkan | Lui_linux.Gl -> None + | Lui_linux.Cpu -> Some cpu + | Lui_linux.Noop -> Some noop + in + let t = + RL.create ~warn:(fun _ -> ()) + ~release:(fun a -> released := a.RL.state :: !released) + ~noop ~try_rung + [ Lui_linux.Vulkan; Lui_linux.Gl; Lui_linux.Cpu; Lui_linux.Noop ] + in + (* the init walk tried Vulkan and Gl, then settled on Cpu with the + Noop tail kept in reserve for a runtime demote *) + Alcotest.(check bool) "walk order" true + (List.rev !tried + = [ Lui_linux.Vulkan; Lui_linux.Gl; Lui_linux.Cpu ]); + Alcotest.(check bool) "cpu active" true + ((RL.active t).RL.state = `cpu); + Alcotest.(check bool) "tail kept" true + (RL.remaining t = [ Lui_linux.Noop ]); + (* the CPU rung wins a frame before dying *) + let live = RL.renderer_live t in + Alcotest.(check bool) "cpu frame" true + (live.Lui_host.render (scene ()) == cpu_pix); + (* a mid-render device loss demotes to Noop inside the same call: + the rung's release ran and the zeroed fallback frame comes back *) + cpu_live := false; + let pix = live.Lui_host.render (scene ()) in + Alcotest.(check bool) "cpu released" true (!released = [ `cpu ]); + Alcotest.(check bool) "noop active" true + ((RL.active t).RL.state = `noop); + Alcotest.(check int) "zeroed frame" (2 * 1 * 4) (Bytes.length pix); + Alcotest.(check bool) "walked on" true + (List.exists (fun r -> r = Lui_linux.Noop) !tried) + let test_tray_icon () = let px = Lui_linux.tray_icon_rgba () in Alcotest.(check int) "rgba bytes" (22 * 22 * 4) (Bytes.length px); @@ -319,42 +385,155 @@ let host_with_app () = let app = Demo_app.create backend in (asm, app) +(* One scripted frame's outcome: the actions [Ui.handle] produced and + the scene checksum after the driver's flush/relayout/repaint. *) +type headless_run = { + checksum : int64; + ops : int; + acted : action list list; + ui : Ui.t; + store : Lui_store.t; +} + +(* Feed the host-level action list back into the app the way the + driver's apply_actions does: only [Dispatch] events reach the + model; the rest are driver-side concerns out of scope here. *) +let apply_to_app app acts = + List.iter + (function + | Dispatch ev -> ( + try ignore (Lui_app.dispatch_event app ev) + with Invalid_argument _ -> ()) + | _ -> ()) + acts + (* Drive [script] input events between frames like the SDL loop does, - accumulating the scene checksum. *) + accumulating the scene checksum and keeping the action list each + event produced so callers can assert on them. *) let run_headless frames script = let asm, app = host_with_app () in let host = Assembly.host asm in + let ui = Assembly.ui asm in + let store = Assembly.store asm in ignore (Lui_app.start app); ignore (Lui_app.flush app); + (* prime the hit-test mirror before the first event — the driver + lays out once before its loop, otherwise frame 1's click tests + against empty rects *) ignore (Assembly.repaint asm); let cs = Checksum.create () in let ops_last = ref 0 in + let acted = ref [] in let scripted = Array.of_list script in for f = 1 to frames do (* one scripted input per frame, then flush + repaint + populate — the same ordering the driver loop uses *) - if f <= Array.length scripted then - ignore (Assembly.handle asm scripted.(f - 1)); + if f <= Array.length scripted then begin + let acts = Assembly.handle asm scripted.(f - 1) in + acted := acts :: !acted; + apply_to_app app acts + end; ignore (Lui_app.flush app); ignore (Assembly.repaint asm); Checksum.add_scene cs (Lui_host.scene host); ops_last := List.length (Lui_host.scene host).Lui_scene.ops done; - (Checksum.value cs, !ops_last) + { checksum = Checksum.value cs; ops = !ops_last; + acted = List.rev !acted; ui; store } + +let headless_script = + [ Input.Button_down (60., 100., Input.Left, 1, Input.mods_none); + Input.Button_up (60., 100., Input.Left, Input.mods_none); + Input.Text_input "hello"; + Input.Key_down (Input.Return, Input.mods_none, false) ] let test_headless_checksum () = let frames = 6 in - let script = - [ Input.Button_down (60., 78., Input.Left, 1, Input.mods_none); - Input.Button_up (60., 78., Input.Left, Input.mods_none); - Input.Text_input "hello"; - Input.Key_down (Input.Return, Input.mods_none, false) ] + let r1 = run_headless frames headless_script in + let r2 = run_headless frames headless_script in + Alcotest.(check bool) "scene painted" true (r1.ops > 0); + Alcotest.(check int64) "deterministic" r1.checksum r2.checksum; + Alcotest.(check int) "same ops" r1.ops r2.ops + +(* The scripted frames are an interaction test, not just a render + determinism check: every event must produce the actions the + driver's apply_actions consumes, and the dispatches must land as + store mutations. *) +let show_event = function + | TextChanged (id, s) -> Printf.sprintf "TextChanged(%d,%S)" id s + | Submit id -> Printf.sprintf "Submit %d" id + | Press id -> Printf.sprintf "Press %d" id + | PointerDown (id, _) -> Printf.sprintf "PointerDown %d" id + | PointerUp (id, _) -> Printf.sprintf "PointerUp %d" id + | PressDetail (id, _) -> Printf.sprintf "PressDetail %d" id + | Appear id -> Printf.sprintf "Appear %d" id + | ToggleChanged (id, b) -> Printf.sprintf "ToggleChanged(%d,%b)" id b + | Change id -> Printf.sprintf "Change %d" id + | Dismiss id -> Printf.sprintf "Dismiss %d" id + | _ -> "event" + +let show_acts acts = + String.concat ", " + (List.map + (function + | Focus_changed id -> Printf.sprintf "Focus_changed %d" id + | Dispatch e -> "Dispatch " ^ show_event e + | Quit -> "Quit" + | Ime_rect _ -> "Ime_rect" + | Resize_host _ -> "Resize_host" + | Clipboard_write s -> Printf.sprintf "Clipboard_write %S" s + | Paste_request -> "Paste_request") + acts) + +let test_headless_actions () = + let r = run_headless 4 headless_script in + let field = + match + List.find_opt + (fun id -> + Lui_store.string_prop r.store id "accessibility-label" + = Some "New item") + (Lui_store.preorder r.store) + with + | Some id -> id + | None -> Alcotest.fail "demo text field not mounted" + in + (match r.acted with + | [ down; up; input; submit ] -> + (* the click claims the autofocus field — the Focus_changed the + driver would use to start text input *) + (match down with + | [ Focus_changed f ] when f = field -> () + | _ -> + Alcotest.failf "click did not focus the field: %s" + (show_acts down)); + (match up with + | [ Dispatch (Press p) ] when p <> 0 -> () + | _ -> Alcotest.failf "release not quiet: %s" (show_acts up)); + (match input with + | [ Dispatch (TextChanged (f, "hello")) ] when f = field -> () + | _ -> + Alcotest.failf "typing did not dispatch TextChanged: %s" + (show_acts input)); + (match submit with + | [ Dispatch (Submit f) ] when f = field -> () + | _ -> + Alcotest.failf "Return did not dispatch Submit: %s" + (show_acts submit)) + | frames -> + Alcotest.failf "expected four action frames, got %d" + (List.length frames)); + (* the dispatches reached the model: "hello" mounts as a new item + and the field's draft is cleared *) + let has_text_node v = + List.exists + (fun id -> Lui_store.string_prop r.store id "text" = Some v) + (Lui_store.preorder r.store) in - let v1, ops1 = run_headless frames script in - let v2, ops2 = run_headless frames script in - Alcotest.(check bool) "scene painted" true (ops1 > 0); - Alcotest.(check int64) "deterministic" v1 v2; - Alcotest.(check int) "same ops" ops1 ops2 + Alcotest.(check bool) "item added" true (has_text_node "hello"); + Alcotest.(check bool) "draft cleared" true + (Lui_store.string_prop r.store field "text" = Some ""); + Alcotest.(check int) "focus kept" field (Ui.focused r.ui) (* ---------- accessibility bridge (offline-safe) ---------- *) @@ -454,6 +633,7 @@ let () = Alcotest.run "lui_window_linux" [ ( "ladder", [ Alcotest.test_case "renderer ladder" `Quick test_ladder; + Alcotest.test_case "demote path" `Quick test_ladder_demote; Alcotest.test_case "tray icon" `Quick test_tray_icon ] ); ( "a11y", [ Alcotest.test_case "action mapping" `Quick test_a11y_actions; @@ -467,7 +647,8 @@ let () = Alcotest.test_case "combining" `Quick test_caret_ops_combining; Alcotest.test_case "vertical" `Quick test_caret_ops_vertical ] ); ( "headless", - [ Alcotest.test_case "checksum" `Quick test_headless_checksum ] ); + [ Alcotest.test_case "checksum" `Quick test_headless_checksum; + Alcotest.test_case "actions" `Quick test_headless_actions ] ); ( "shell", [ Alcotest.test_case "menu model" `Quick test_shell_model; Alcotest.test_case "degraded" `Quick test_shell_degraded ] ) ] diff --git a/platform/native/lui_window_windows/main.ml b/platform/native/lui_window_windows/main.ml index b681f8d9..a0e1ea49 100644 --- a/platform/native/lui_window_windows/main.ml +++ b/platform/native/lui_window_windows/main.ml @@ -90,149 +90,129 @@ let () = in let dw, dh = drawable () in let scale = Float.max 0.01 (Lui_win32.dpi_scale hwnd) in - (* Renderer selection. [d3d_state] keeps the live [Lui_d3d11.t] for - release at shutdown; [present_last] remembers the last blitted - frame so a WM_PAINT can be answered without a full repaint. *) - let d3d_state = ref None in + (* Renderer selection. The ladder attempt's [state] keeps the live + [Lui_d3d11.t] (when a D3D11 rung won) for release at shutdown; + [present_last] remembers the last blitted frame so a WM_PAINT + can be answered without a full repaint. *) let present_last = ref None in (* The ladder walk returns the renderer plus the live [Lui_d3d11.t] - (when a D3D11 rung won) so shutdown can release the device. - [remaining] keeps the rungs below the active one so a runtime - demotion can re-walk the tail. *) - let remaining = ref [] in - let renderer, d3d_live, walk = - let rec walk = function - | [] -> - remaining := []; - warn "all renderer rungs failed; using no-op loop renderer"; - (Lui_window_windows.noop_renderer, None) - | rung :: rest -> - remaining := rest; - ( - match rung with - | Lui_window_windows.Cpu -> ( - (* CPU rung: Lui_raster renders the scene; StretchDIBits - uploads the damaged rects (or the whole frame). *) - match - let rr = Lui_raster.Renderer.create () in - { Lui_host.name = "lui_raster+dib"; + (when a D3D11 rung won) as the attempt state so shutdown can + release the device. The walk/demote sequencing lives in + [Lui_window.Renderer_ladder]; this supplies the per-rung init. *) + let try_rung rung ~rest:_ = + let attempt renderer state = + Some { Renderer_ladder.renderer; state } + in + match rung with + | Lui_window_windows.Cpu -> ( + (* CPU rung: Lui_raster renders the scene; StretchDIBits + uploads the damaged rects (or the whole frame). *) + match + let rr = Lui_raster.Renderer.create () in + { Lui_host.name = "lui_raster+dib"; + render = + (fun s -> + let dirty = Lui_raster.Renderer.render rr s in + let img = Lui_raster.Renderer.image rr in + let pix = img.Lui_raster.Image.pix in + let stride = img.Lui_raster.Image.stride / 4 in + let w = img.Lui_raster.Image.w + and h = img.Lui_raster.Image.h in + if Lui_raster.Renderer.whole rr || dirty = [] then + ignore (Lui_win32.present_frame hwnd pix ~w ~h) + else + List.iter + (fun (r : Lui_scene.irect) -> + ignore + (Lui_win32.present_region hwnd ~x0:r.x0 + ~y0:r.y0 ~x1:r.x1 ~y1:r.y1 ~pix ~stride)) + dirty; + present_last := Some (pix, w, h); + pix) } + with + | r -> attempt r None + | exception e -> + warn "cpu rung init failed: %s" (Printexc.to_string e); + None) + | Lui_window_windows.D3d11 -> ( + (* Default rung: first a swapchain on the window's HWND — + real presentation with GPU rasterization — then an + offscreen render target whose frames are read back and + uploaded through the same DIB path as the CPU rung. + [Lui_d3d11.render] auto-resizes its target to the scene + size, so resizes need no extra plumbing. *) + let try_hwnd () = + match Lui_d3d11.init_hwnd hwnd ~w:dw ~h:dh with + | Ok d -> + attempt + { Lui_host.name = "lui_d3d11 (hwnd)"; render = (fun s -> - let dirty = Lui_raster.Renderer.render rr s in - let img = Lui_raster.Renderer.image rr in - let pix = img.Lui_raster.Image.pix in - let stride = img.Lui_raster.Image.stride / 4 in - let w = img.Lui_raster.Image.w - and h = img.Lui_raster.Image.h in - if Lui_raster.Renderer.whole rr || dirty = [] then - ignore (Lui_win32.present_frame hwnd pix ~w ~h) - else - List.iter - (fun (r : Lui_scene.irect) -> - ignore - (Lui_win32.present_region hwnd ~x0:r.x0 - ~y0:r.y0 ~x1:r.x1 ~y1:r.y1 ~pix ~stride)) - dirty; - present_last := Some (pix, w, h); - pix) } - with - | r -> (r, None) - | exception e -> - warn "cpu rung init failed: %s" (Printexc.to_string e); - walk rest) - | Lui_window_windows.D3d11 -> ( - (* Default rung: first a swapchain on the window's HWND — - real presentation with GPU rasterization — then an - offscreen render target whose frames are read back and - uploaded through the same DIB path as the CPU rung. - [Lui_d3d11.render] auto-resizes its target to the scene - size, so resizes need no extra plumbing. *) - let try_hwnd () = - match Lui_d3d11.init_hwnd hwnd ~w:dw ~h:dh with - | Ok d -> - Some - ( { Lui_host.name = "lui_d3d11 (hwnd)"; - render = - (fun s -> - Lui_d3d11.render d s; - Bytes.empty) }, - Some d ) - | Error e -> - warn "lui_d3d11.init_hwnd failed: %s" e; - None - in - let try_offscreen () = - match Lui_d3d11.init_offscreen ~w:dw ~h:dh with - | Ok d -> - Some - ( { Lui_host.name = "lui_d3d11 (offscreen+blit)"; - render = - (fun s -> - Lui_d3d11.render d s; - let px = - Lui_d3d11.read_frame d ~w:s.Lui_scene.width - ~h:s.Lui_scene.height - in - ignore - (Lui_win32.present_frame hwnd px - ~w:s.Lui_scene.width - ~h:s.Lui_scene.height); - present_last := - Some (px, s.Lui_scene.width, s.Lui_scene.height); - px) }, - Some d ) - | Error e -> - warn "lui_d3d11.init_offscreen failed: %s" e; - None - in - match try_hwnd () with - | Some v -> v - | None -> ( - match try_offscreen () with - | Some v -> v - | None -> walk rest)) - | Lui_window_windows.Gl -> - (* This build carries no GL bindings (tsdl/tgls are not - installed on the VM), so the rung can only report and - yield — a build that links Lui_gl would create a WGL - context on the HWND here. *) - warn "lui_gl unavailable on this build (no GL bindings)"; - walk rest - | Lui_window_windows.Noop -> - (Lui_window_windows.noop_renderer, None)) - in - let r, d = walk rungs in (r, d, walk) + Lui_d3d11.render d s; + Bytes.empty) } + (Some d) + | Error e -> + warn "lui_d3d11.init_hwnd failed: %s" e; + None + in + let try_offscreen () = + match Lui_d3d11.init_offscreen ~w:dw ~h:dh with + | Ok d -> + attempt + { Lui_host.name = "lui_d3d11 (offscreen+blit)"; + render = + (fun s -> + Lui_d3d11.render d s; + let px = + Lui_d3d11.read_frame d ~w:s.Lui_scene.width + ~h:s.Lui_scene.height + in + ignore + (Lui_win32.present_frame hwnd px + ~w:s.Lui_scene.width + ~h:s.Lui_scene.height); + present_last := + Some (px, s.Lui_scene.width, s.Lui_scene.height); + px) } + (Some d) + | Error e -> + warn "lui_d3d11.init_offscreen failed: %s" e; + None + in + match try_hwnd () with + | Some v -> Some v + | None -> try_offscreen ()) + | Lui_window_windows.Gl -> + (* This build carries no GL bindings (tsdl/tgls are not + installed on the VM), so the rung can only report and + yield — a build that links Lui_gl would create a WGL + context on the HWND here. *) + warn "lui_gl unavailable on this build (no GL bindings)"; + None + | Lui_window_windows.Noop -> + attempt Lui_window_windows.noop_renderer None + in + let ladder_t = + Renderer_ladder.create + ~warn:(fun m -> warn "%s" m) + ~release:(fun a -> + (match a.Renderer_ladder.state with + | Some d -> Lui_d3d11.release d + | None -> ()); + present_last := None) + ~noop:{ Renderer_ladder.renderer = + Lui_window_windows.noop_renderer; + state = None } + ~try_rung rungs in - d3d_state := d3d_live; (* Runtime backend-loss recovery: a device-removed or any render exception demotes the active rung to the next ladder entry. The scene store is untouched, so the next repaint re-uploads a full scene — identical pixels on the CPU path by the parity - contract. *) - let renderer_cell = ref renderer in - let demote reason = - warn "renderer %s lost (%s); stepping down the ladder" - (!renderer_cell).Lui_host.name reason; - (match !d3d_state with - | Some d -> Lui_d3d11.release d; d3d_state := None - | None -> ()); - present_last := None; - let r, d = walk !remaining in - renderer_cell := r; - d3d_state := d - in - (* The host owns a stable record whose render delegates to the live - rung, so a demote needs no host rebuild. *) - let renderer_live = - { Lui_host.name = "lui (resilient)"; - render = - (fun s -> - try (!renderer_cell).Lui_host.render s - with exn -> - demote (Printexc.to_string exn); - (!renderer_cell).Lui_host.render s) } - in + contract. The host owns a stable record whose render delegates + to the live rung, so a demote needs no host rebuild. *) + let renderer_live = Renderer_ladder.renderer_live ladder_t in (* Shared host assembly: hooks, the real layout engine, the scroll-shifted hit-test mirror and the scroll caps are all wired @@ -350,7 +330,8 @@ let () = second further down. *) ignore (Lui_app.send app - (Demo_app.Badge (!renderer_cell).Lui_host.name)); + (Demo_app.Badge + (Renderer_ladder.active ladder_t).renderer.Lui_host.name)); Some item end in @@ -472,7 +453,7 @@ let () = if req_hit "clipboard" m.Demo_app.req_clipboard then begin let s = Printf.sprintf "lui_window_windows %dx%d renderer=%s frames=%d" - dw dh (!renderer_cell).Lui_host.name !frame in + dw dh (Renderer_ladder.active ladder_t).renderer.Lui_host.name !frame in log "shell clipboard: wrote %d chars (ok=%b)" (String.length s) (Lui_shell_windows.clipboard_write s) end; @@ -502,7 +483,7 @@ let () = | None -> true) in log "lui_window_windows: %dx%d drawable (scale %.2f), renderer=%s%s" - dw dh scale (!renderer_cell).Lui_host.name + dw dh scale (Renderer_ladder.active ladder_t).renderer.Lui_host.name (if headless then " [headless]" else ""); while continue () do let t0 = perf_s () in @@ -545,13 +526,13 @@ let () = if st.frames > 0 && st.acc_ms > 0. then 1000. /. (st.acc_ms /. float st.frames) else 0. in - stats_report st (!renderer_cell).Lui_host.name; + stats_report st (Renderer_ladder.active ladder_t).renderer.Lui_host.name; if not headless then ignore (Lui_app.send app (Demo_app.Badge (Printf.sprintf "%s — %.0f fps" - (!renderer_cell).Lui_host.name fps))) + (Renderer_ladder.active ladder_t).renderer.Lui_host.name fps))) end end; (* The semantic tree tracks the store every iteration — cheap @@ -570,7 +551,7 @@ let () = else Lui_win32.delay_ms 4 end done; - stats_report st (!renderer_cell).Lui_host.name; + stats_report st (Renderer_ladder.active ladder_t).renderer.Lui_host.name; log "a11y: %d nodes" (Lui_a11y.node_count a11y); (match frames_target with | Some _ -> @@ -582,7 +563,7 @@ let () = (match status_item with | Some item -> Lui_shell_windows.status_item_remove item | None -> ()); - (match !d3d_state with + (match (Renderer_ladder.active ladder_t).state with | Some d -> Lui_d3d11.release d | None -> ()); Lui_win32.destroy_window hwnd diff --git a/platform/native/lui_window_windows/test/lui_window_windows_test.ml b/platform/native/lui_window_windows/test/lui_window_windows_test.ml index 19d0576e..0de0520d 100644 --- a/platform/native/lui_window_windows/test/lui_window_windows_test.ml +++ b/platform/native/lui_window_windows/test/lui_window_windows_test.ml @@ -79,6 +79,74 @@ let test_ladder () = in Alcotest.(check int) "noop bytes" (5 * 3 * 4) (Bytes.length pix) +(* The real walk/demote path the driver uses: injected init failures + step down the ladder at startup, and a mid-render device loss + demotes inside the same render call — not a CPU->CPU comparison. *) +let test_ladder_demote () = + let module RL = Renderer_ladder in + let scene () = + let s = + Lui_scene.create ~mask_atlas:(Atlas.create ~bpp:1 ~w:8 ~h:8) + ~color_atlas:(Atlas.create ~bpp:4 ~w:8 ~h:8) + in + s.Lui_scene.width <- 2; + s.Lui_scene.height <- 1; + s + in + let tried = ref [] and released = ref [] in + let cpu_live = ref true in + let cpu_pix = Bytes.make 8 '\xAB' in + let cpu = + { RL.renderer = + { Lui_host.name = "mock-cpu"; + render = + (fun _ -> + if !cpu_live then cpu_pix else failwith "device lost") }; + state = `cpu } + in + let noop = + { RL.renderer = Lui_window_windows.noop_renderer; state = `noop } + in + let try_rung rung ~rest:_ = + tried := rung :: !tried; + match rung with + (* injected GPU init failures: no D3D11 device, no GL context *) + | Lui_window_windows.D3d11 | Lui_window_windows.Gl -> None + | Lui_window_windows.Cpu -> Some cpu + | Lui_window_windows.Noop -> Some noop + in + let t = + RL.create ~warn:(fun _ -> ()) + ~release:(fun a -> released := a.RL.state :: !released) + ~noop ~try_rung + [ Lui_window_windows.D3d11; Lui_window_windows.Gl; + Lui_window_windows.Cpu; Lui_window_windows.Noop ] + in + (* the init walk tried D3d11 and Gl, then settled on Cpu with the + Noop tail kept in reserve for a runtime demote *) + Alcotest.(check bool) "walk order" true + (List.rev !tried + = [ Lui_window_windows.D3d11; Lui_window_windows.Gl; + Lui_window_windows.Cpu ]); + Alcotest.(check bool) "cpu active" true + ((RL.active t).RL.state = `cpu); + Alcotest.(check bool) "tail kept" true + (RL.remaining t = [ Lui_window_windows.Noop ]); + (* the CPU rung wins a frame before dying *) + let live = RL.renderer_live t in + Alcotest.(check bool) "cpu frame" true + (live.Lui_host.render (scene ()) == cpu_pix); + (* a mid-render device loss demotes to Noop inside the same call: + the rung's release ran and the zeroed fallback frame comes back *) + cpu_live := false; + let pix = live.Lui_host.render (scene ()) in + Alcotest.(check bool) "cpu released" true (!released = [ `cpu ]); + Alcotest.(check bool) "noop active" true + ((RL.active t).RL.state = `noop); + Alcotest.(check int) "zeroed frame" (2 * 1 * 4) (Bytes.length pix); + Alcotest.(check bool) "walked on" true + (List.exists (fun r -> r = Lui_window_windows.Noop) !tried) + let test_tray_icon () = let px = Lui_window_windows.tray_icon_rgba () in Alcotest.(check int) "rgba bytes" (22 * 22 * 4) (Bytes.length px); @@ -320,29 +388,61 @@ let host_with_app () = let app = Demo_app.create backend in (asm, app) -(* Drive [script] input events between frames like the Win32 loop - does, accumulating the scene checksum. *) let dbg fmt = Printf.printf (fmt ^^ " %!") + +(* One scripted run's outcome: the actions [Ui.handle] produced and + the scene checksum after the driver's flush/relayout/repaint. *) +type headless_run = { + checksum : int64; + ops : int; + acted : action list list; + ui : Ui.t; + store : Lui_store.t; +} + +(* Feed the host-level action list back into the app the way the + driver's apply_actions does: only [Dispatch] events reach the + model; the rest are driver-side concerns out of scope here. *) +let apply_to_app app acts = + List.iter + (function + | Dispatch ev -> ( + try ignore (Lui_app.dispatch_event app ev) + with Invalid_argument _ -> ()) + | _ -> ()) + acts + +(* Drive [script] input events between frames like the Win32 loop + does, accumulating the scene checksum and keeping the action list + each event produced so callers can assert on them. *) let run_headless frames script = dbg "stage: host_with_app"; let asm, app = host_with_app () in let host = Assembly.host asm in + let ui = Assembly.ui asm in + let store = Assembly.store asm in dbg "stage: app start"; ignore (Lui_app.start app); dbg "stage: started"; ignore (Lui_app.flush app); dbg "stage: flushed"; + (* prime the hit-test mirror before the first event — the driver + lays out once before its loop, otherwise frame 1's click tests + against empty rects *) ignore (Assembly.repaint asm); dbg "stage: repaint"; let cs = Checksum.create () in let ops_last = ref 0 in + let acted = ref [] in let scripted = Array.of_list script in for f = 1 to frames do (* one scripted input per frame, then flush + repaint + populate — the same ordering the driver loop uses *) if f <= Array.length scripted then begin - ignore (Assembly.handle asm scripted.(f - 1)); + let acts = Assembly.handle asm scripted.(f - 1) in + acted := acts :: !acted; + apply_to_app app acts; dbg "f%d: handled" f end; ignore (Lui_app.flush app); @@ -352,7 +452,8 @@ let run_headless frames script = Checksum.add_scene cs (Lui_host.scene host); ops_last := List.length (Lui_host.scene host).Lui_scene.ops done; - (Checksum.value cs, !ops_last) + { checksum = Checksum.value cs; ops = !ops_last; + acted = List.rev !acted; ui; store } (* Shaped lines rooted for the process: see the comment at [rooted_lines] use below. *) @@ -398,20 +499,135 @@ let test_repaint_min () = ignore (Lui_host.repaint host); dbg "min repaint ok" +let headless_script = + [ Input.Button_down (60., 78., Input.Left, 1, Input.mods_none); + Input.Button_up (60., 78., Input.Left, Input.mods_none); + Input.Text_input "hello"; + Input.Key_down (Input.Return, Input.mods_none, false) ] + let test_headless_checksum () = dbg "entry"; let frames = 6 in - let script = - [ Input.Button_down (60., 78., Input.Left, 1, Input.mods_none); - Input.Button_up (60., 78., Input.Left, Input.mods_none); - Input.Text_input "hello"; - Input.Key_down (Input.Return, Input.mods_none, false) ] + let r1 = run_headless frames headless_script in + let r2 = run_headless frames headless_script in + Alcotest.(check bool) "scene painted" true (r1.ops > 0); + Alcotest.(check int64) "deterministic" r1.checksum r2.checksum; + Alcotest.(check int) "same ops" r1.ops r2.ops; + (* the scripted input is replayed identically: one action list per + scripted event, the same focus and the same resulting store *) + Alcotest.(check (list int)) "same actions per event" + (List.map List.length r1.acted) (List.map List.length r2.acted); + Alcotest.(check int) "one action list per event" + (List.length headless_script) (List.length r1.acted); + Alcotest.(check int) "same focus" (Ui.focused r1.ui) (Ui.focused r2.ui); + let texts st = + List.map (fun id -> Lui_store.string_prop st id "text") + (Lui_store.preorder st) + in + Alcotest.(check (list (option string))) "same store text" + (texts r1.store) (texts r2.store) + +let show_event = function + | TextChanged (id, s) -> Printf.sprintf "TextChanged(%d,%S)" id s + | Submit id -> Printf.sprintf "Submit %d" id + | Press id -> Printf.sprintf "Press %d" id + | PointerDown (id, _) -> Printf.sprintf "PointerDown %d" id + | PointerUp (id, _) -> Printf.sprintf "PointerUp %d" id + | PressDetail (id, _) -> Printf.sprintf "PressDetail %d" id + | Appear id -> Printf.sprintf "Appear %d" id + | ToggleChanged (id, b) -> Printf.sprintf "ToggleChanged(%d,%b)" id b + | Change id -> Printf.sprintf "Change %d" id + | Dismiss id -> Printf.sprintf "Dismiss %d" id + | _ -> "event" + +let show_acts acts = + String.concat ", " + (List.map + (function + | Focus_changed id -> Printf.sprintf "Focus_changed %d" id + | Dispatch e -> "Dispatch " ^ show_event e + | Quit -> "Quit" + | Ime_rect _ -> "Ime_rect" + | Resize_host _ -> "Resize_host" + | Clipboard_write s -> Printf.sprintf "Clipboard_write %S" s + | Paste_request -> "Paste_request") + acts) + +(* The scripted frames are an interaction test, not just a render + determinism check: every event must produce the actions the + driver's apply_actions consumes, and the dispatches must land as + store mutations. The autofocused Name field is addressed by prop + and by its laid-out rect rather than by guessed coordinates. *) +let test_headless_actions () = + let asm, app = host_with_app () in + let ui = Assembly.ui asm in + let store = Assembly.store asm in + let rects = Assembly.rects asm in + ignore (Lui_app.start app); + ignore (Lui_app.flush app); + ignore (Assembly.repaint asm); + let field = + match + List.find_opt + (fun id -> + Lui_store.string_prop store id "accessibility-label" + = Some "Name") + (Lui_store.preorder store) + with + | Some id -> id + | None -> Alcotest.fail "name field not mounted" + in + let handle = Assembly.handle asm in + (* driver startup parity: the loop hands focus to the first + autofocus field before pumping events *) + Ui.set_focused ui store field; + Alcotest.(check int) "autofocus claimed" field (Ui.focused ui); + (* typing dispatches TextChanged for the focused field *) + let input_acts = handle (Input.Text_input "hello") in + (match press_actions input_acts with + | [ TextChanged (f, "hello") ] when f = field -> () + | _ -> + Alcotest.failf "typing did not dispatch TextChanged: %s" + (show_acts input_acts)); + Alcotest.(check string) "shadow" "hello" (Ui.shadow ui); + (* Enter submits *) + let submit_acts = + handle (Input.Key_down (Input.Return, Input.mods_none, false)) + in + (match press_actions submit_acts with + | [ Submit f ] when f = field -> () + | _ -> + Alcotest.failf "Return did not dispatch Submit: %s" + (show_acts submit_acts)); + (* the dispatches reach the model: the field's text prop carries + "hello" and the status line reports the submit *) + apply_to_app app input_acts; + apply_to_app app submit_acts; + ignore (Lui_app.flush app); + let has_text_node v = + List.exists + (fun id -> Lui_store.string_prop store id "text" = Some v) + (Lui_store.preorder store) + in + Alcotest.(check bool) "name stored" true + (Lui_store.string_prop store field "text" = Some "hello"); + Alcotest.(check bool) "submit reported" true + (has_text_node "name submitted"); + (* a click inside the field's laid-out rect keeps focus and lands + the caret inside the typed text *) + let fr = Rects.get rects field in + let cx = fr.Lui_scene.x +. 6. + and cy = fr.Lui_scene.y +. (fr.Lui_scene.h /. 2.) in + let down = + handle (Input.Button_down (cx, cy, Input.Left, 1, Input.mods_none)) in - let v1, ops1 = run_headless frames script in - let v2, ops2 = run_headless frames script in - Alcotest.(check bool) "scene painted" true (ops1 > 0); - Alcotest.(check int64) "deterministic" v1 v2; - Alcotest.(check int) "same ops" ops1 ops2 + Alcotest.(check bool) "no blur" true + (not + (List.exists (function Focus_changed 0 -> true | _ -> false) + down)); + Alcotest.(check int) "focus kept" field (Ui.focused ui); + Alcotest.(check bool) "caret in text" true + (Ui.caret ui >= 0 && Ui.caret ui <= String.length "hello") (* ---------- Win32 window stubs + UIA bridge (real calls) ---------- *) @@ -532,6 +748,7 @@ let () = Alcotest.run "lui_window_windows" [ ( "ladder", [ Alcotest.test_case "renderer ladder" `Quick test_ladder; + Alcotest.test_case "demote path" `Quick test_ladder_demote; Alcotest.test_case "tray icon" `Quick test_tray_icon ] ); ( "a11y", [ Alcotest.test_case "action mapping" `Quick test_a11y_actions; @@ -546,7 +763,8 @@ let () = ( "headless", [ Alcotest.test_case "rast loop" `Quick test_rast_loop; Alcotest.test_case "repaint min" `Quick test_repaint_min; - Alcotest.test_case "checksum" `Quick test_headless_checksum ] ); + Alcotest.test_case "checksum" `Quick test_headless_checksum; + Alcotest.test_case "actions" `Quick test_headless_actions ] ); ( "shell", [ Alcotest.test_case "menu model" `Quick test_shell_model; Alcotest.test_case "guarded" `Quick test_shell_guarded ] ) ]