diff --git a/examples/components/web/dune b/examples/components/web/dune
new file mode 100644
index 00000000..7b42ec3f
--- /dev/null
+++ b/examples/components/web/dune
@@ -0,0 +1,11 @@
+(melange.emit
+ (target lui-components-web)
+ (alias web)
+ (module_systems es6)
+ (modules web_main web_bootstrap)
+ (preprocess (pps melange.ppx))
+ (libraries
+ gallery_app
+ lui.web.dom
+ melange-webapi
+ melange.dom))
diff --git a/examples/components/web/index.html b/examples/components/web/index.html
new file mode 100644
index 00000000..7c0977ba
--- /dev/null
+++ b/examples/components/web/index.html
@@ -0,0 +1,27 @@
+
+
+
+
+
+ LUI Components
+
+
+
+
+
+
+
+
+
diff --git a/examples/components/web/styles.css b/examples/components/web/styles.css
new file mode 100644
index 00000000..3a24735d
--- /dev/null
+++ b/examples/components/web/styles.css
@@ -0,0 +1,266 @@
+* {
+ box-sizing: border-box;
+}
+
+body {
+ min-height: 100vh;
+ margin: 0;
+ color: var(--foreground);
+ background: var(--background);
+ font-family: Inter, ui-sans-serif, -apple-system, BlinkMacSystemFont, "Segoe UI", sans-serif;
+}
+
+#app {
+ min-height: 100vh;
+}
+
+.lui-simulator-toolbar {
+ position: fixed;
+ z-index: 60;
+ top: max(0.75rem, env(safe-area-inset-top));
+ right: max(0.75rem, env(safe-area-inset-right));
+ padding: 0.375rem;
+ border: 1px solid var(--border);
+ border-radius: 0.75rem;
+ background: color-mix(in srgb, var(--background) 92%, transparent);
+ box-shadow: 0 0.5rem 1.5rem color-mix(in srgb, var(--foreground) 10%, transparent);
+ backdrop-filter: blur(1rem);
+ display: flex;
+ align-items: center;
+ gap: 0.375rem;
+}
+
+.lui-simulator-platform-field {
+ display: flex;
+ align-items: center;
+ gap: 0.5rem;
+ padding-left: 0.5rem;
+ color: var(--muted-foreground);
+ font-size: 0.75rem;
+ font-weight: 600;
+}
+
+.lui-simulator-platform-field select {
+ min-height: 2rem;
+ border: 0;
+ border-radius: 0.5rem;
+ background: var(--secondary);
+ color: var(--secondary-foreground);
+ padding: 0 1.75rem 0 0.625rem;
+ font: inherit;
+}
+
+.lui-simulator-toolbar > button {
+ min-height: 2rem;
+ border: 0;
+ border-radius: 0.5rem;
+ background: var(--secondary);
+ color: var(--secondary-foreground);
+ padding: 0 0.625rem;
+ font: inherit;
+ font-size: 0.75rem;
+ font-weight: 600;
+}
+
+.lui-gallery-shell {
+ display: grid;
+ min-height: 100%;
+ grid-template-columns: 16rem minmax(0, 1fr);
+}
+
+.lui-gallery-navigation-bar {
+ display: none;
+}
+
+.lui-gallery-sidebar {
+ position: sticky;
+ top: 0;
+ display: flex;
+ height: 100vh;
+ flex-direction: column;
+ gap: 0.25rem;
+ overflow-y: auto;
+ border-right: 1px solid var(--border);
+ background: var(--background);
+ padding: 1rem 0.75rem;
+}
+
+.lui-gallery-nav-item {
+ min-height: 2.25rem;
+ border: 0;
+ border-radius: 0.5rem;
+ background: transparent;
+ color: var(--muted-foreground);
+ padding: 0.5rem 0.75rem;
+ text-align: left;
+}
+
+.lui-gallery-nav-item:hover,
+.lui-gallery-nav-item[data-selected="true"] {
+ background: var(--accent);
+ color: var(--accent-foreground);
+}
+
+.lui-gallery-nav-item:focus-visible {
+ outline: 2px solid var(--ring);
+ outline-offset: 2px;
+}
+
+.lui-gallery-content {
+ min-width: 0;
+ width: min(56rem, 100%);
+}
+
+.lui-native-card {
+ min-height: 8rem;
+ width: min(28rem, 100%);
+ border: 1px solid var(--border);
+ border-radius: 0.75rem;
+ background: var(--card);
+ color: var(--card-foreground);
+ padding: 1.5rem;
+ font: inherit;
+ text-align: left;
+ transition: transform 150ms ease, box-shadow 150ms ease;
+}
+
+.lui-native-card:hover,
+.lui-native-card[data-active="true"] {
+ box-shadow: 0 0.75rem 2rem color-mix(in srgb, var(--foreground) 12%, transparent);
+ transform: translateY(-2px);
+}
+
+.lui-gallery-accent {
+ @apply rounded-xl border border-sky-200 bg-sky-50 px-3 py-2 text-sky-950 shadow-sm;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-shell {
+ grid-template-columns: minmax(0, 1fr);
+ grid-template-rows: auto minmax(0, 1fr);
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-navigation-bar {
+ z-index: 20;
+ display: grid;
+ min-height: calc(2.75rem + var(--lui-safe-area-top));
+ grid-template-columns: minmax(5rem, 1fr) auto minmax(5rem, 1fr);
+ align-items: end;
+ border-bottom: 1px solid var(--border);
+ background: color-mix(in srgb, var(--background) 92%, transparent);
+ padding: var(--lui-safe-area-top) 0.5rem 0.375rem;
+ backdrop-filter: blur(1rem);
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-navigation-back {
+ min-height: 2.25rem;
+ justify-self: start;
+ border: 0;
+ background: transparent;
+ color: var(--primary);
+ font: inherit;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-navigation-back::before {
+ content: "‹";
+ margin-right: 0.25rem;
+ font-size: 1.5rem;
+ line-height: 0;
+ vertical-align: -0.1rem;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-navigation-title {
+ grid-column: 2;
+ align-self: center;
+ color: var(--foreground);
+ font-weight: 600;
+ white-space: nowrap;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-sidebar {
+ position: static;
+ z-index: 10;
+ height: auto;
+ min-height: 0;
+ flex-direction: column;
+ overflow: auto;
+ border-right: 0;
+ padding: 1rem;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-nav-item {
+ width: 100%;
+ min-height: 2.75rem;
+ flex: 0 0 auto;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-shell[data-lui-navigation="detail"] .lui-gallery-sidebar {
+ display: none;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-content {
+ display: none;
+}
+
+[data-lui-form-factor="phone"] .lui-gallery-shell[data-lui-navigation="detail"] .lui-gallery-content {
+ display: block;
+}
+
+@media (max-width: 44.999rem) {
+ .lui-simulator-toolbar {
+ top: auto;
+ right: 0.5rem;
+ bottom: 0.5rem;
+ left: 0.5rem;
+ justify-content: center;
+ }
+
+ .lui-simulator-platform-field {
+ min-width: 0;
+ flex: 1 1 0;
+ padding-left: 0;
+ }
+
+ .lui-simulator-platform-field > span {
+ display: none;
+ }
+
+ .lui-simulator-platform-field select {
+ width: 100%;
+ min-width: 0;
+ }
+}
+
+.lui-row,
+.lui-column {
+ display: flex;
+}
+
+.lui-row {
+ flex-wrap: wrap;
+ align-items: center;
+}
+
+.lui-column {
+ flex-direction: column;
+}
+
+.lui-column > .lui-text:first-child {
+ font-size: 1.5rem;
+ font-weight: 600;
+ letter-spacing: -0.025em;
+}
+
+.lui-text-field,
+.lui-input,
+.lui-search-field,
+.lui-textarea {
+ width: min(24rem, 100%);
+}
+
+.lui-switch {
+ width: min(24rem, 100%);
+}
+
+.lui-separator-example-row {
+ height: 2rem;
+}
diff --git a/examples/components/web/web_bootstrap.ml b/examples/components/web/web_bootstrap.ml
new file mode 100644
index 00000000..7e58b139
--- /dev/null
+++ b/examples/components/web/web_bootstrap.ml
@@ -0,0 +1,13 @@
+let show_error host message =
+ Webapi.Dom.Element.setTextContent host message;
+ Webapi.Dom.Element.setAttribute "data-error" "true" host
+
+let () =
+ Printexc.record_backtrace true;
+ match Webapi.Dom.Document.querySelector "#app" Webapi.Dom.document with
+ | None -> ()
+ | Some host -> (
+ try ignore (Web_main.main host)
+ with error ->
+ show_error host
+ (Printexc.to_string error ^ "\n" ^ Printexc.get_backtrace ()))
diff --git a/examples/components/web/web_main.ml b/examples/components/web/web_main.ml
new file mode 100644
index 00000000..efacefeb
--- /dev/null
+++ b/examples/components/web/web_main.ml
@@ -0,0 +1,624 @@
+(* Web entry for the component gallery, ported from web_main.cljc: builds
+ the Lui app over the simulator web backend, installs the demo extension
+ adapters, mounts the gallery shell + simulator toolbar, and wires backend
+ events into the reducer loop. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+
+external element_value : W.Element.t -> string = "value" [@@mel.get]
+external set_muted : W.Element.t -> bool -> unit = "muted" [@@mel.set]
+
+(* Extension adapters *)
+
+let native_card_adapter : web_extension_adapter =
+ { web_extension_create =
+ (fun _node document _emit ->
+ let button = W.Document.createElement "button" document in
+ let pressed = ref false in
+ W.Element.setAttribute "type" "button" button;
+ W.Element.setClassName button "lui-native-card";
+ W.Element.addEventListener "click"
+ (fun _event ->
+ pressed := not !pressed;
+ W.Element.setAttribute "data-active"
+ (if !pressed then "true" else "false")
+ button)
+ button;
+ button);
+ web_extension_set_property =
+ (fun node property value ->
+ if property = "title" then
+ match value with
+ | StringValue text -> W.Element.setTextContent node text
+ | _ -> invalid_arg "native-card title must be a string");
+ web_extension_remove_property =
+ (fun node property ->
+ if property = "title" then W.Element.setTextContent node "");
+ web_extension_cleanup = (fun _node -> ());
+ }
+
+let gallery_accent_adapter : web_extension_adapter =
+ { web_extension_create =
+ (fun _node document _emit ->
+ let element = W.Document.createElement "div" document in
+ W.Element.setClassName element "lui-gallery-accent";
+ element);
+ web_extension_set_property = (fun _node _property _value -> ());
+ web_extension_remove_property = (fun _node _property -> ());
+ web_extension_cleanup = (fun _node -> ());
+ }
+
+let append parent child = W.Element.appendChild (W.Element.asNode child) parent
+
+let set_hidden element hidden =
+ if hidden then W.Element.setAttribute "hidden" "" element
+ else W.Element.removeAttribute "hidden" element
+
+let attribute_float element name fallback =
+ match W.Element.getAttribute name element with
+ | Some value -> float_of_string value
+ | None -> fallback
+
+let set_float_attribute element name value =
+ W.Element.setAttribute name (Js.Float.toString value) element
+
+let refresh_map_markers map =
+ let center_latitude = attribute_float map "data-center-latitude" 0.0 in
+ let center_longitude = attribute_float map "data-center-longitude" 0.0 in
+ let latitude_delta = attribute_float map "data-latitude-delta" 1.0 in
+ let longitude_delta = attribute_float map "data-longitude-delta" 1.0 in
+ let markers =
+ W.Element.querySelectorAll ".lui-simulator-map-marker" map
+ in
+ for index = 0 to W.NodeList.length markers - 1 do
+ match W.NodeList.item index markers with
+ | Some node -> (
+ match W.Element.ofNode node with
+ | Some marker ->
+ let latitude = attribute_float marker "data-latitude" 0.0 in
+ let longitude = attribute_float marker "data-longitude" 0.0 in
+ let x =
+ 50.0
+ +. ((longitude -. center_longitude) /. longitude_delta *. 100.0)
+ in
+ let y =
+ 50.0
+ -. ((latitude -. center_latitude) /. latitude_delta *. 100.0)
+ in
+ let style =
+ W.HtmlElement.style (W.Element.unsafeAsHtmlElement marker)
+ in
+ W.CssStyleDeclaration.setProperty "left"
+ (Js.Float.toString x ^ "%") "" style;
+ W.CssStyleDeclaration.setProperty "top"
+ (Js.Float.toString y ^ "%") "" style
+ | None -> ())
+ | None -> ()
+ done
+
+let emit_map_region map emit =
+ emit "region-change"
+ (String_map.empty
+ |> String_map.add "latitude"
+ (FloatValue (attribute_float map "data-center-latitude" 0.0))
+ |> String_map.add "longitude"
+ (FloatValue (attribute_float map "data-center-longitude" 0.0))
+ |> String_map.add "latitude-delta"
+ (FloatValue (attribute_float map "data-latitude-delta" 1.0))
+ |> String_map.add "longitude-delta"
+ (FloatValue (attribute_float map "data-longitude-delta" 1.0)))
+
+let map_control document label text on_press =
+ let button = W.Document.createElement "button" document in
+ W.Element.setAttribute "type" "button" button;
+ W.Element.setAttribute "aria-label" label button;
+ W.Element.setTextContent button text;
+ W.Element.addEventListener "click" (fun _event -> on_press ()) button;
+ button
+
+let recenter_map map emit =
+ List.iter
+ (fun (current, home) ->
+ match W.Element.getAttribute home map with
+ | Some value -> W.Element.setAttribute current value map
+ | None -> ())
+ [ ("data-center-latitude", "data-home-latitude")
+ ; ("data-center-longitude", "data-home-longitude")
+ ; ("data-latitude-delta", "data-home-latitude-delta")
+ ; ("data-longitude-delta", "data-home-longitude-delta")
+ ];
+ refresh_map_markers map;
+ emit_map_region map emit
+
+let update_zoom map emit factor =
+ set_float_attribute map "data-latitude-delta"
+ (attribute_float map "data-latitude-delta" 1.0 *. factor);
+ set_float_attribute map "data-longitude-delta"
+ (attribute_float map "data-longitude-delta" 1.0 *. factor);
+ refresh_map_markers map;
+ emit_map_region map emit
+
+let map_pointer_down map drag dragging event =
+ let target =
+ W.EventTarget.unsafeAsElement (W.Event.target event)
+ in
+ if W.Element.tagName target <> "BUTTON" then (
+ let pointer = Lui_web_util.pointer_mouse_event event in
+ drag :=
+ ( float_of_int (W.MouseEvent.clientX pointer)
+ , float_of_int (W.MouseEvent.clientY pointer)
+ , attribute_float map "data-center-latitude" 0.0
+ , attribute_float map "data-center-longitude" 0.0 );
+ dragging := true;
+ W.Element.setAttribute "aria-grabbed" "true" map)
+
+let map_pointer_move map drag dragging event =
+ if !dragging then (
+ let start_x, start_y, start_latitude, start_longitude = !drag in
+ let bounds = W.Element.getBoundingClientRect map in
+ let width = Float.max 1.0 (W.DomRect.width bounds) in
+ let height = Float.max 1.0 (W.DomRect.height bounds) in
+ let pointer = Lui_web_util.pointer_mouse_event event in
+ let x = float_of_int (W.MouseEvent.clientX pointer) in
+ let y = float_of_int (W.MouseEvent.clientY pointer) in
+ let longitude_delta =
+ attribute_float map "data-longitude-delta" 1.0
+ in
+ let latitude_delta = attribute_float map "data-latitude-delta" 1.0 in
+ set_float_attribute map "data-center-longitude"
+ (start_longitude -. ((x -. start_x) /. width *. longitude_delta));
+ set_float_attribute map "data-center-latitude"
+ (start_latitude +. ((y -. start_y) /. height *. latitude_delta));
+ refresh_map_markers map)
+
+let simulator_map_create _node document emit =
+ let map = W.Document.createElement "section" document in
+ let texture = W.Document.createElement "div" document in
+ let controls = W.Document.createElement "div" document in
+ let drag = ref (0.0, 0.0, 0.0, 0.0) in
+ let dragging = ref false in
+ W.Element.setClassName map "lui-simulator-map";
+ W.Element.setAttribute "role" "region" map;
+ W.Element.setAttribute "aria-grabbed" "false" map;
+ W.Element.setClassName texture "lui-simulator-map-texture";
+ W.Element.setAttribute "aria-hidden" "true" texture;
+ W.Element.setClassName controls "lui-simulator-map-controls";
+ append controls (map_control document "Zoom in" "+" (fun () ->
+ update_zoom map emit 0.5));
+ append controls
+ (map_control document "Zoom out" "−" (fun () ->
+ update_zoom map emit 2.0));
+ append controls
+ (map_control document "Recenter map" "◎" (fun () ->
+ recenter_map map emit));
+ append texture controls;
+ append map texture;
+ W.Element.addEventListener "pointerdown"
+ (map_pointer_down map drag dragging)
+ map;
+ W.Element.addEventListener "pointermove"
+ (map_pointer_move map drag dragging)
+ map;
+ let map_pointer_up _event =
+ if !dragging then (
+ dragging := false;
+ W.Element.setAttribute "aria-grabbed" "false" map;
+ emit_map_region map emit)
+ in
+ W.Element.addEventListener "pointerup" map_pointer_up map;
+ W.Element.addEventListener "pointercancel" map_pointer_up map;
+ map
+
+let simulator_map_adapter : web_extension_adapter =
+ { web_extension_create = simulator_map_create;
+ web_extension_set_property =
+ (fun map property value ->
+ (match (property, value) with
+ | "label", StringValue label ->
+ W.Element.setAttribute "aria-label" label map
+ | "latitude", FloatValue latitude ->
+ set_float_attribute map "data-center-latitude" latitude;
+ set_float_attribute map "data-home-latitude" latitude
+ | "longitude", FloatValue longitude ->
+ set_float_attribute map "data-center-longitude" longitude;
+ set_float_attribute map "data-home-longitude" longitude
+ | "latitude-delta", FloatValue delta ->
+ set_float_attribute map "data-latitude-delta" delta;
+ set_float_attribute map "data-home-latitude-delta" delta
+ | "longitude-delta", FloatValue delta ->
+ set_float_attribute map "data-longitude-delta" delta;
+ set_float_attribute map "data-home-longitude-delta" delta
+ | _ -> invalid_arg "invalid simulator-map property");
+ Webapi.requestAnimationFrame (fun _time -> refresh_map_markers map));
+ web_extension_remove_property =
+ (fun map property ->
+ match property with
+ | "label" -> W.Element.removeAttribute "aria-label" map
+ | "latitude" ->
+ W.Element.removeAttribute "data-center-latitude" map
+ | "longitude" ->
+ W.Element.removeAttribute "data-center-longitude" map
+ | "latitude-delta" ->
+ W.Element.removeAttribute "data-latitude-delta" map
+ | "longitude-delta" ->
+ W.Element.removeAttribute "data-longitude-delta" map
+ | _ -> ());
+ web_extension_cleanup = (fun _map -> ());
+ }
+
+let simulator_map_marker_adapter : web_extension_adapter =
+ { web_extension_create =
+ (fun _node document _emit ->
+ let marker = W.Document.createElement "button" document in
+ W.Element.setAttribute "type" "button" marker;
+ W.Element.setClassName marker "lui-simulator-map-marker";
+ marker);
+ web_extension_set_property =
+ (fun marker property value ->
+ (match (property, value) with
+ | "title", StringValue title ->
+ W.Element.setTextContent marker title;
+ W.Element.setAttribute "aria-label" title marker
+ | "latitude", FloatValue latitude ->
+ set_float_attribute marker "data-latitude" latitude
+ | "longitude", FloatValue longitude ->
+ set_float_attribute marker "data-longitude" longitude
+ | _ -> invalid_arg "invalid simulator-map-marker property");
+ Webapi.requestAnimationFrame (fun _time ->
+ match W.Element.parentElement marker with
+ | Some parent -> refresh_map_markers parent
+ | None -> ()));
+ web_extension_remove_property =
+ (fun marker property ->
+ match property with
+ | "title" ->
+ W.Element.setTextContent marker "";
+ W.Element.removeAttribute "aria-label" marker
+ | "latitude" -> W.Element.removeAttribute "data-latitude" marker
+ | "longitude" -> W.Element.removeAttribute "data-longitude" marker
+ | _ -> ());
+ web_extension_cleanup = (fun _marker -> ());
+ }
+
+type camera_dom =
+ { camera : Dom.element;
+ video : Dom.element;
+ mock : Dom.element;
+ status : Dom.element;
+ alert : Dom.element;
+ action : Dom.element }
+
+let simulator_camera_dom document =
+ let camera = W.Document.createElement "section" document in
+ let frame = W.Document.createElement "div" document in
+ let video = W.Document.createElement "video" document in
+ let mock = W.Document.createElement "div" document in
+ let status = W.Document.createElement "span" document in
+ let alert = W.Document.createElement "p" document in
+ let action = W.Document.createElement "button" document in
+ W.Element.setClassName camera "lui-simulator-camera";
+ W.Element.setAttribute "role" "group" camera;
+ W.Element.setAttribute "data-camera-state" "mock" camera;
+ W.Element.setClassName frame "lui-simulator-camera-frame";
+ W.Element.setAttribute "autoplay" "" video;
+ W.Element.setAttribute "muted" "" video;
+ W.Element.setAttribute "playsinline" "" video;
+ set_muted video true;
+ W.Element.setAttribute "aria-label" "Live camera preview" video;
+ set_hidden video true;
+ W.Element.setClassName mock "lui-simulator-camera-mock";
+ W.Element.setAttribute "aria-hidden" "true" mock;
+ W.Element.setTextContent mock "SIMULATOR CAMERA";
+ W.Element.setAttribute "role" "status" status;
+ W.Element.setTextContent status "Using deterministic simulator camera";
+ W.Element.setAttribute "role" "alert" alert;
+ set_hidden alert true;
+ W.Element.setAttribute "type" "button" action;
+ W.Element.setTextContent action "Use browser camera";
+ append frame video;
+ append frame mock;
+ append camera frame;
+ append camera status;
+ append camera alert;
+ append camera action;
+ { camera; video; mock; status; alert; action }
+
+let simulator_camera_adapter : web_extension_adapter =
+ let create _node document emit =
+ let { camera; video; mock; status; alert; action } =
+ simulator_camera_dom document
+ in
+ let show_state state status_text action_text ~video_hidden ~mock_hidden
+ ~alert_hidden =
+ W.Element.setAttribute "data-camera-state" state camera;
+ set_hidden video video_hidden;
+ set_hidden mock mock_hidden;
+ set_hidden alert alert_hidden;
+ W.Element.setTextContent status status_text;
+ W.Element.setTextContent action action_text;
+ emit "state-change" (String_map.singleton "state" (StringValue state))
+ in
+ let show_mock () =
+ Lui_web_media.stop_camera video;
+ show_state "mock" "Using deterministic simulator camera"
+ "Use browser camera" ~video_hidden:true ~mock_hidden:false
+ ~alert_hidden:true
+ in
+ let show_live () =
+ show_state "live" "Using browser camera" "Use simulator camera"
+ ~video_hidden:false ~mock_hidden:true ~alert_hidden:true
+ in
+ let show_denied () =
+ W.Element.setAttribute "data-camera-state" "denied" camera;
+ set_hidden video true;
+ set_hidden mock false;
+ set_hidden alert false;
+ W.Element.setTextContent alert
+ "Camera permission denied. The simulator camera remains available.";
+ W.Element.setTextContent status "Using deterministic simulator camera";
+ W.Element.setTextContent action "Use browser camera";
+ emit "state-change" (String_map.singleton "state" (StringValue "denied"))
+ in
+ W.Element.addEventListener "click"
+ (fun _event ->
+ match W.Element.getAttribute "data-camera-state" camera with
+ | Some "live" -> show_mock ()
+ | _ ->
+ W.Element.setAttribute "data-camera-state" "requesting" camera;
+ W.Element.setTextContent status "Requesting browser camera";
+ Lui_web_media.request_camera document video
+ (match W.Element.getAttribute "data-facing" camera with
+ | Some facing -> facing
+ | None -> "environment")
+ show_live show_denied)
+ action;
+ camera
+ in
+ { web_extension_create = create;
+ web_extension_set_property =
+ (fun camera property value ->
+ match (property, value) with
+ | "label", StringValue label ->
+ W.Element.setAttribute "aria-label" label camera
+ | "facing", StringValue facing ->
+ W.Element.setAttribute "data-facing" facing camera
+ | _ -> invalid_arg "invalid simulator-camera property");
+ web_extension_remove_property =
+ (fun camera property ->
+ match property with
+ | "label" -> W.Element.removeAttribute "aria-label" camera
+ | "facing" -> W.Element.removeAttribute "data-facing" camera
+ | _ -> ());
+ web_extension_cleanup =
+ (fun camera ->
+ match W.Element.querySelector "video" camera with
+ | Some video -> Lui_web_media.stop_camera video
+ | None -> ());
+ }
+
+(* Simulator toolbar (outside #app) *)
+
+let select_value event =
+ element_value (W.EventTarget.unsafeAsElement (W.Event.target event))
+
+let simulator_option document value label =
+ let option = W.Document.createElement "option" document in
+ W.Element.setAttribute "value" value option;
+ W.Element.setTextContent option label;
+ option
+
+let mount_simulator_toolbar renderer refresh_layout =
+ let document = renderer.web_document in
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ let toolbar = W.Document.createElement "div" document in
+ let label = W.Document.createElement "label" document in
+ let label_text = W.Document.createElement "span" document in
+ let select = W.Document.createElement "select" document in
+ let device_label = W.Document.createElement "label" document in
+ let device_label_text = W.Document.createElement "span" document in
+ let device_select = W.Document.createElement "select" document in
+ let rotate = W.Document.createElement "button" document in
+ W.Element.setClassName toolbar "lui-simulator-toolbar";
+ W.Element.setClassName label "lui-simulator-platform-field";
+ W.Element.setTextContent label_text "Platform";
+ W.Element.setAttribute "aria-label" "Simulator platform" select;
+ append select (simulator_option document "ios" "iOS");
+ append select (simulator_option document "android" "Android");
+ W.Element.setClassName device_label "lui-simulator-platform-field";
+ W.Element.setTextContent device_label_text "Device";
+ W.Element.setAttribute "aria-label" "Simulator form factor" device_select;
+ append device_select (simulator_option document "phone" "Phone");
+ append device_select (simulator_option document "tablet" "Tablet");
+ W.Element.setAttribute "type" "button" rotate;
+ W.Element.setAttribute "aria-label" "Rotate simulator" rotate;
+ W.Element.setTextContent rotate "Rotate";
+ W.Element.addEventListener "change"
+ (fun event ->
+ (match select_value event with
+ | "ios" -> ignore (Lui_web_simulator.set_simulator_platform renderer IOS)
+ | "android" ->
+ ignore (Lui_web_simulator.set_simulator_platform renderer AndroidOS)
+ | _ -> ());
+ refresh_layout ())
+ select;
+ W.Element.addEventListener "change"
+ (fun event ->
+ (match select_value event with
+ | "phone" ->
+ ignore
+ (Lui_web_simulator.set_simulator_form_factor renderer
+ SimulatorPhone)
+ | "tablet" ->
+ ignore
+ (Lui_web_simulator.set_simulator_form_factor renderer
+ SimulatorTablet)
+ | _ -> ());
+ refresh_layout ())
+ device_select;
+ W.Element.addEventListener "click"
+ (fun _event ->
+ ignore (Lui_web_simulator.rotate_simulator renderer);
+ refresh_layout ())
+ rotate;
+ append label label_text;
+ append label select;
+ append device_label device_label_text;
+ append device_label device_select;
+ append toolbar label;
+ append toolbar device_label;
+ append toolbar rotate;
+ match W.HtmlDocument.body html_document with
+ | Some body -> append body toolbar
+ | None -> invalid_arg "document body is unavailable"
+
+(* Gallery shell *)
+
+let set_accessibility_hidden element hidden =
+ W.Element.setAttribute "aria-hidden"
+ (if hidden then "true" else "false")
+ element;
+ if hidden then W.Element.setAttribute "inert" "" element
+ else W.Element.removeAttribute "inert" element
+
+let focus element =
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement element)
+
+let select_section renderer content buttons sections selected_index =
+ let section = sections.(selected_index) in
+ W.Element.setTextContent content "";
+ Lui_web.mount renderer section.root_section_node content;
+ Array.iteri
+ (fun index button ->
+ let selected = index = selected_index in
+ W.Element.setAttribute "aria-current"
+ (if selected then "page" else "false")
+ button;
+ W.Element.setAttribute "data-selected"
+ (if selected then "true" else "false")
+ button)
+ buttons
+
+let mount_gallery_shell renderer root host =
+ let document = renderer.web_document in
+ let shell = W.Document.createElement "div" document in
+ let navigation_bar = W.Document.createElement "header" document in
+ let back = W.Document.createElement "button" document in
+ let navigation_title = W.Document.createElement "span" document in
+ let sidebar = W.Document.createElement "nav" document in
+ let content = W.Document.createElement "div" document in
+ let sections = Array.of_list (Lui_web.root_sections renderer root) in
+ let selected_index = ref 0 in
+ let buttons =
+ Array.map
+ (fun section ->
+ let button = W.Document.createElement "button" document in
+ W.Element.setAttribute "type" "button" button;
+ W.Element.setClassName button "lui-gallery-nav-item";
+ W.Element.setTextContent button section.root_section_title;
+ append sidebar button;
+ button)
+ sections
+ in
+ let refresh_layout () =
+ let tablet =
+ W.Element.getAttribute "data-lui-form-factor" host = Some "tablet"
+ in
+ let detail =
+ W.Element.getAttribute "data-lui-navigation" shell = Some "detail"
+ in
+ let show_detail = tablet || detail in
+ set_accessibility_hidden sidebar ((not tablet) && detail);
+ set_accessibility_hidden content (not show_detail);
+ set_hidden back (tablet || not detail);
+ W.Element.setTextContent navigation_title
+ (if detail then sections.(!selected_index).root_section_title
+ else "Components")
+ in
+ W.Element.setClassName shell "lui-gallery-shell";
+ W.Element.setAttribute "data-lui-navigation" "list" shell;
+ W.Element.setClassName navigation_bar "lui-gallery-navigation-bar";
+ W.Element.setClassName back "lui-gallery-navigation-back";
+ W.Element.setAttribute "type" "button" back;
+ W.Element.setAttribute "aria-label" "Back to Components" back;
+ W.Element.setTextContent back "Components";
+ W.Element.setClassName navigation_title "lui-gallery-navigation-title";
+ W.Element.setTextContent navigation_title "Components";
+ W.Element.setClassName sidebar "lui-gallery-sidebar";
+ W.Element.setAttribute "aria-label" "Components" sidebar;
+ W.Element.setClassName content "lui-gallery-content";
+ append navigation_bar back;
+ append navigation_bar navigation_title;
+ append shell navigation_bar;
+ append shell sidebar;
+ append shell content;
+ append host shell;
+ W.Element.addEventListener "click"
+ (fun _event ->
+ W.Element.setAttribute "data-lui-navigation" "list" shell;
+ refresh_layout ();
+ focus buttons.(!selected_index))
+ back;
+ Array.iteri
+ (fun index button ->
+ W.Element.addEventListener "click"
+ (fun _event ->
+ select_section renderer content buttons sections index;
+ selected_index := index;
+ W.Element.setAttribute "data-lui-navigation" "detail" shell;
+ refresh_layout ();
+ if W.Element.getAttribute "data-lui-form-factor" host = Some "phone"
+ then focus back)
+ button)
+ buttons;
+ if Array.length sections > 0 then
+ select_section renderer content buttons sections 0;
+ refresh_layout ();
+ refresh_layout
+
+(* Entry *)
+
+let app_icon_url =
+ "/examples/components/flutter/macos/Runner/Assets.xcassets/AppIcon.appiconset/app_icon_128.png"
+
+let main host =
+ let registry = Extension_schemas.registry () in
+ let adapters =
+ String_map.empty
+ |> String_map.add "simulator-map" simulator_map_adapter
+ |> String_map.add "simulator-map-marker" simulator_map_marker_adapter
+ |> String_map.add "simulator-camera" simulator_camera_adapter
+ |> String_map.add "native-card" native_card_adapter
+ |> String_map.add "gallery-accent" gallery_accent_adapter
+ in
+ let renderer =
+ Lui_web.create_simulator_with_extensions host IOS String_map.empty
+ registry adapters
+ in
+ let app =
+ Lui_app.create_with_extensions (Lui_web.backend renderer) registry
+ Model.initial Model.update View.view
+ in
+ Hashtbl.replace renderer.web_images 1
+ { web_image_url = app_icon_url
+ ; web_image_width = 128.0
+ ; web_image_height = 128.0
+ };
+ Hashtbl.replace renderer.web_media_surfaces 1
+ { web_image_url = app_icon_url
+ ; web_image_width = 128.0
+ ; web_image_height = 128.0
+ };
+ ignore
+ (Lui_web.set_event_handler renderer (fun event ->
+ ignore (Lui_app.dispatch_event app event);
+ Lui_app.flush app));
+ ignore (Lui_app.start app);
+ ignore (Lui_app.flush app);
+ let refresh_gallery_layout =
+ mount_gallery_shell renderer (Lui_app.root_node app) host
+ in
+ mount_simulator_toolbar renderer refresh_gallery_layout;
+ true
diff --git a/examples/gallery/dune b/examples/gallery/dune
index b7e6ed93..f911749f 100644
--- a/examples/gallery/dune
+++ b/examples/gallery/dune
@@ -1,6 +1,7 @@
(library
(name gallery_app)
(modules model view extension_schemas)
+ (modes byte native melange)
(libraries lui ocaml-signal)
(preprocess (pps lui_ppx))
(wrapped false))
diff --git a/examples/gallery/extension_schemas.json b/examples/gallery/extension_schemas.json
index cad4d5f5..e7e21c24 100644
--- a/examples/gallery/extension_schemas.json
+++ b/examples/gallery/extension_schemas.json
@@ -93,6 +93,38 @@
"os": "web",
"host": "web"
}
+ ],
+ "web": [
+ {
+ "os": "web",
+ "host": "web"
+ }
+ ],
+ "web-and-flutter": [
+ {
+ "os": "web",
+ "host": "web"
+ },
+ {
+ "os": "macos",
+ "host": "flutter"
+ },
+ {
+ "os": "ios",
+ "host": "flutter"
+ },
+ {
+ "os": "android",
+ "host": "flutter"
+ },
+ {
+ "os": "linux",
+ "host": "flutter"
+ },
+ {
+ "os": "windows",
+ "host": "flutter"
+ }
]
},
"components": [
@@ -151,6 +183,136 @@
],
"events": []
},
+ {
+ "identifier": "simulator-map",
+ "profiles": "web",
+ "standardChildren": false,
+ "children": [
+ "simulator-map-marker"
+ ],
+ "properties": [
+ {
+ "name": "label",
+ "kind": "string",
+ "required": true
+ },
+ {
+ "name": "latitude",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "longitude",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "latitude-delta",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "longitude-delta",
+ "kind": "float",
+ "required": true
+ }
+ ],
+ "events": [
+ {
+ "name": "region-change",
+ "fields": [
+ {
+ "name": "latitude",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "longitude",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "latitude-delta",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "longitude-delta",
+ "kind": "float",
+ "required": true
+ }
+ ]
+ }
+ ]
+ },
+ {
+ "identifier": "simulator-map-marker",
+ "profiles": "web",
+ "standardChildren": false,
+ "children": [],
+ "properties": [
+ {
+ "name": "title",
+ "kind": "string",
+ "required": true
+ },
+ {
+ "name": "latitude",
+ "kind": "float",
+ "required": true
+ },
+ {
+ "name": "longitude",
+ "kind": "float",
+ "required": true
+ }
+ ],
+ "events": []
+ },
+ {
+ "identifier": "simulator-camera",
+ "profiles": "web",
+ "standardChildren": false,
+ "children": [],
+ "properties": [
+ {
+ "name": "label",
+ "kind": "string",
+ "required": true
+ },
+ {
+ "name": "facing",
+ "kind": "string",
+ "required": true
+ }
+ ],
+ "events": [
+ {
+ "name": "state-change",
+ "fields": [
+ {
+ "name": "state",
+ "kind": "string",
+ "required": true
+ }
+ ]
+ }
+ ]
+ },
+ {
+ "identifier": "native-card",
+ "profiles": "web-and-flutter",
+ "standardChildren": false,
+ "children": [],
+ "properties": [
+ {
+ "name": "title",
+ "kind": "string",
+ "required": true
+ }
+ ],
+ "events": []
+ },
{
"identifier": "split-view",
"profiles": "splits",
diff --git a/examples/gallery/extension_schemas.ml b/examples/gallery/extension_schemas.ml
index 3c2c1245..0f6c5425 100644
--- a/examples/gallery/extension_schemas.ml
+++ b/examples/gallery/extension_schemas.ml
@@ -2,6 +2,19 @@
open Lui_protocol
+type simulator_map_region_change = {
+ event_node : int;
+ latitude : float;
+ longitude : float;
+ latitude_delta : float;
+ longitude_delta : float;
+}
+
+type simulator_camera_state_change = {
+ event_node : int;
+ state : string;
+}
+
type split_branch_ratio_changed = {
event_node : int;
ratio : float;
@@ -51,6 +64,35 @@ type split_pane_pane_closed = {
}
+let decode_simulator_map_region_change = function
+ | ExtensionEvent (node, identifier, event_name, values)
+ when String.equal event_name "region-change"
+ && String.equal identifier "simulator-map" ->
+ (match (String_map.find_opt "latitude" values, String_map.find_opt "longitude" values, String_map.find_opt "latitude-delta" values, String_map.find_opt "longitude-delta" values) with
+ | (Some (FloatValue latitude), Some (FloatValue longitude), Some (FloatValue latitude_delta), Some (FloatValue longitude_delta)) ->
+ Some ({
+ event_node = node;
+ latitude = latitude;
+ longitude = longitude;
+ latitude_delta = latitude_delta;
+ longitude_delta = longitude_delta;
+ } : simulator_map_region_change)
+ | _ -> None)
+ | _ -> None
+
+let decode_simulator_camera_state_change = function
+ | ExtensionEvent (node, identifier, event_name, values)
+ when String.equal event_name "state-change"
+ && String.equal identifier "simulator-camera" ->
+ (match (String_map.find_opt "state" values) with
+ | (Some (StringValue state)) ->
+ Some ({
+ event_node = node;
+ state = state;
+ } : simulator_camera_state_change)
+ | _ -> None)
+ | _ -> None
+
let decode_split_branch_ratio_changed = function
| ExtensionEvent (node, identifier, event_name, values)
when String.equal event_name "ratio-changed"
@@ -174,6 +216,34 @@ let apple_map_marker_schema =
[ Lui_extension.property "title" Lui_extension.StringScalar true None; Lui_extension.property "latitude" Lui_extension.FloatScalar true None; Lui_extension.property "longitude" Lui_extension.FloatScalar true None ]
[ ]
+let simulator_map_schema =
+ Lui_extension.component "simulator-map" [ { Lui_protocol.profile_os = WebOS; Lui_protocol.profile_host = WebHost } ]
+ false
+ [ "simulator-map-marker" ]
+ [ Lui_extension.property "label" Lui_extension.StringScalar true None; Lui_extension.property "latitude" Lui_extension.FloatScalar true None; Lui_extension.property "longitude" Lui_extension.FloatScalar true None; Lui_extension.property "latitude-delta" Lui_extension.FloatScalar true None; Lui_extension.property "longitude-delta" Lui_extension.FloatScalar true None ]
+ [ Lui_extension.event "region-change" [ Lui_extension.event_field "latitude" Lui_extension.FloatScalar true; Lui_extension.event_field "longitude" Lui_extension.FloatScalar true; Lui_extension.event_field "latitude-delta" Lui_extension.FloatScalar true; Lui_extension.event_field "longitude-delta" Lui_extension.FloatScalar true ] ]
+
+let simulator_map_marker_schema =
+ Lui_extension.component "simulator-map-marker" [ { Lui_protocol.profile_os = WebOS; Lui_protocol.profile_host = WebHost } ]
+ false
+ [ ]
+ [ Lui_extension.property "title" Lui_extension.StringScalar true None; Lui_extension.property "latitude" Lui_extension.FloatScalar true None; Lui_extension.property "longitude" Lui_extension.FloatScalar true None ]
+ [ ]
+
+let simulator_camera_schema =
+ Lui_extension.component "simulator-camera" [ { Lui_protocol.profile_os = WebOS; Lui_protocol.profile_host = WebHost } ]
+ false
+ [ ]
+ [ Lui_extension.property "label" Lui_extension.StringScalar true None; Lui_extension.property "facing" Lui_extension.StringScalar true None ]
+ [ Lui_extension.event "state-change" [ Lui_extension.event_field "state" Lui_extension.StringScalar true ] ]
+
+let native_card_schema =
+ Lui_extension.component "native-card" [ { Lui_protocol.profile_os = WebOS; Lui_protocol.profile_host = WebHost }; { Lui_protocol.profile_os = MacOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = IOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = AndroidOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = LinuxOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = WindowsOS; Lui_protocol.profile_host = FlutterHost } ]
+ false
+ [ ]
+ [ Lui_extension.property "title" Lui_extension.StringScalar true None ]
+ [ ]
+
let split_view_schema =
Lui_extension.component "split-view" [ { Lui_protocol.profile_os = MacOS; Lui_protocol.profile_host = SwiftUIHost }; { Lui_protocol.profile_os = IOS; Lui_protocol.profile_host = SwiftUIHost }; { Lui_protocol.profile_os = LinuxOS; Lui_protocol.profile_host = QMLHost }; { Lui_protocol.profile_os = MacOS; Lui_protocol.profile_host = QMLHost }; { Lui_protocol.profile_os = WindowsOS; Lui_protocol.profile_host = QMLHost }; { Lui_protocol.profile_os = AndroidOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = IOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = LinuxOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = MacOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = WindowsOS; Lui_protocol.profile_host = FlutterHost }; { Lui_protocol.profile_os = WindowsOS; Lui_protocol.profile_host = WinUIHost }; { Lui_protocol.profile_os = WebOS; Lui_protocol.profile_host = WebHost } ]
false
@@ -210,6 +280,10 @@ let registry () =
let registry = Lui_extension.registry () in
Lui_extension.register_component registry apple_map_schema;
Lui_extension.register_component registry apple_map_marker_schema;
+ Lui_extension.register_component registry simulator_map_schema;
+ Lui_extension.register_component registry simulator_map_marker_schema;
+ Lui_extension.register_component registry simulator_camera_schema;
+ Lui_extension.register_component registry native_card_schema;
Lui_extension.register_component registry split_view_schema;
Lui_extension.register_component registry split_branch_schema;
Lui_extension.register_component registry split_pane_schema;
@@ -310,6 +384,172 @@ let apple_map_marker ?key ~title ~latitude ~longitude ?title_signal ?latitude_si
node
+let simulator_map ?key ~label ~latitude ~longitude ~latitude_delta ~longitude_delta ?label_signal ?latitude_signal ?longitude_signal ?latitude_delta_signal ?longitude_delta_signal ?on_region_change (children : Lui_elements.t list) : Lui_elements.t =
+ fun context parent ->
+ let node = Lui_ui.extension context "simulator-map" in
+ Option.iter (Lui_ui.key context node) key;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "label"
+ (StringValue value))
+ (Some label);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "label"
+ (Signal.map (fun value -> StringValue value) signal))
+ label_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "latitude"
+ (FloatValue value))
+ (Some latitude);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "latitude"
+ (Signal.map (fun value -> FloatValue value) signal))
+ latitude_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "longitude"
+ (FloatValue value))
+ (Some longitude);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "longitude"
+ (Signal.map (fun value -> FloatValue value) signal))
+ longitude_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "latitude-delta"
+ (FloatValue value))
+ (Some latitude_delta);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "latitude-delta"
+ (Signal.map (fun value -> FloatValue value) signal))
+ latitude_delta_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "longitude-delta"
+ (FloatValue value))
+ (Some longitude_delta);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "longitude-delta"
+ (Signal.map (fun value -> FloatValue value) signal))
+ longitude_delta_signal;
+ Option.iter
+ (fun handler ->
+ Lui_ui.on_event context node (fun raw ->
+ match decode_simulator_map_region_change raw with
+ | Some event -> handler event
+ | None -> ()))
+ on_region_change;
+ (match parent with
+ | Some parent -> Lui_ui.append context parent node
+ | None -> ());
+ Lui_elements.mount_children context node children;
+ node
+
+let simulator_map_marker ?key ~title ~latitude ~longitude ?title_signal ?latitude_signal ?longitude_signal () : Lui_elements.t =
+ fun context parent ->
+ let node = Lui_ui.extension context "simulator-map-marker" in
+ Option.iter (Lui_ui.key context node) key;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "title"
+ (StringValue value))
+ (Some title);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "title"
+ (Signal.map (fun value -> StringValue value) signal))
+ title_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "latitude"
+ (FloatValue value))
+ (Some latitude);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "latitude"
+ (Signal.map (fun value -> FloatValue value) signal))
+ latitude_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "longitude"
+ (FloatValue value))
+ (Some longitude);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "longitude"
+ (Signal.map (fun value -> FloatValue value) signal))
+ longitude_signal;
+
+ (match parent with
+ | Some parent -> Lui_ui.append context parent node
+ | None -> ());
+
+ node
+
+let simulator_camera ?key ~label ~facing ?label_signal ?facing_signal ?on_state_change () : Lui_elements.t =
+ fun context parent ->
+ let node = Lui_ui.extension context "simulator-camera" in
+ Option.iter (Lui_ui.key context node) key;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "label"
+ (StringValue value))
+ (Some label);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "label"
+ (Signal.map (fun value -> StringValue value) signal))
+ label_signal;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "facing"
+ (StringValue value))
+ (Some facing);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "facing"
+ (Signal.map (fun value -> StringValue value) signal))
+ facing_signal;
+ Option.iter
+ (fun handler ->
+ Lui_ui.on_event context node (fun raw ->
+ match decode_simulator_camera_state_change raw with
+ | Some event -> handler event
+ | None -> ()))
+ on_state_change;
+ (match parent with
+ | Some parent -> Lui_ui.append context parent node
+ | None -> ());
+
+ node
+
+let native_card ?key ~title ?title_signal () : Lui_elements.t =
+ fun context parent ->
+ let node = Lui_ui.extension context "native-card" in
+ Option.iter (Lui_ui.key context node) key;
+ Option.iter
+ (fun value ->
+ Lui_ui.extension_property context node "title"
+ (StringValue value))
+ (Some title);
+ Option.iter
+ (fun signal ->
+ Lui_ui.extension_property_signal context node "title"
+ (Signal.map (fun value -> StringValue value) signal))
+ title_signal;
+
+ (match parent with
+ | Some parent -> Lui_ui.append context parent node
+ | None -> ());
+
+ node
+
let split_view ?key ?divider_thickness ?animation ?accessibility_identifier ?divider_thickness_signal ?animation_signal ?accessibility_identifier_signal (children : Lui_elements.t list) : Lui_elements.t =
fun context parent ->
let node = Lui_ui.extension context "split-view" in
diff --git a/examples/gallery/extension_schemas.mli b/examples/gallery/extension_schemas.mli
index e4881118..7e85a0d5 100644
--- a/examples/gallery/extension_schemas.mli
+++ b/examples/gallery/extension_schemas.mli
@@ -1,5 +1,18 @@
(* Generated by tooling/generate_extension_api.mjs. Do not edit by hand. *)
+type simulator_map_region_change = {
+ event_node : int;
+ latitude : float;
+ longitude : float;
+ latitude_delta : float;
+ longitude_delta : float;
+}
+
+type simulator_camera_state_change = {
+ event_node : int;
+ state : string;
+}
+
type split_branch_ratio_changed = {
event_node : int;
ratio : float;
@@ -51,6 +64,10 @@ type split_pane_pane_closed = {
val apple_map : ?key:string -> latitude:float -> longitude:float -> latitude_delta:float -> longitude_delta:float -> ?latitude_signal:float Signal.signal -> ?longitude_signal:float Signal.signal -> ?latitude_delta_signal:float Signal.signal -> ?longitude_delta_signal:float Signal.signal -> Lui_elements.t list -> Lui_elements.t
val apple_map_marker : ?key:string -> title:string -> latitude:float -> longitude:float -> ?title_signal:string Signal.signal -> ?latitude_signal:float Signal.signal -> ?longitude_signal:float Signal.signal -> unit -> Lui_elements.t
+val simulator_map : ?key:string -> label:string -> latitude:float -> longitude:float -> latitude_delta:float -> longitude_delta:float -> ?label_signal:string Signal.signal -> ?latitude_signal:float Signal.signal -> ?longitude_signal:float Signal.signal -> ?latitude_delta_signal:float Signal.signal -> ?longitude_delta_signal:float Signal.signal -> ?on_region_change:(simulator_map_region_change -> unit) -> Lui_elements.t list -> Lui_elements.t
+val simulator_map_marker : ?key:string -> title:string -> latitude:float -> longitude:float -> ?title_signal:string Signal.signal -> ?latitude_signal:float Signal.signal -> ?longitude_signal:float Signal.signal -> unit -> Lui_elements.t
+val simulator_camera : ?key:string -> label:string -> facing:string -> ?label_signal:string Signal.signal -> ?facing_signal:string Signal.signal -> ?on_state_change:(simulator_camera_state_change -> unit) -> unit -> Lui_elements.t
+val native_card : ?key:string -> title:string -> ?title_signal:string Signal.signal -> unit -> Lui_elements.t
val split_view : ?key:string -> ?divider_thickness:float -> ?animation:bool -> ?accessibility_identifier:string -> ?divider_thickness_signal:float Signal.signal -> ?animation_signal:bool Signal.signal -> ?accessibility_identifier_signal:string Signal.signal -> Lui_elements.t list -> Lui_elements.t
val split_branch : ?key:string -> orientation:string -> ratio:float -> ?orientation_signal:string Signal.signal -> ?ratio_signal:float Signal.signal -> ?on_ratio_changed:(split_branch_ratio_changed -> unit) -> Lui_elements.t list -> Lui_elements.t
val split_pane : ?key:string -> pane_id:string -> ?selected:string -> ?focused:bool -> ?accessibility_identifier:string -> ?pane_id_signal:string Signal.signal -> ?selected_signal:string Signal.signal -> ?focused_signal:bool Signal.signal -> ?accessibility_identifier_signal:string Signal.signal -> ?on_tab_selected:(split_pane_tab_selected -> unit) -> ?on_tab_closed:(split_pane_tab_closed -> unit) -> ?on_tab_moved:(split_pane_tab_moved -> unit) -> ?on_pane_focused:(split_pane_pane_focused -> unit) -> ?on_navigate:(split_pane_navigate -> unit) -> ?on_split_requested:(split_pane_split_requested -> unit) -> ?on_split_drop:(split_pane_split_drop -> unit) -> ?on_pane_closed:(split_pane_pane_closed -> unit) -> Lui_elements.t list -> Lui_elements.t
diff --git a/examples/gallery/view.ml b/examples/gallery/view.ml
index 3b8b842d..e95744cb 100644
--- a/examples/gallery/view.ml
+++ b/examples/gallery/view.ml
@@ -131,7 +131,7 @@ let toggle_button_section model_source send : t =
let button_group_section model_source send : t =
let disabled = model_source >|= Model.disabled in
section "ButtonGroup"
- [ button_group ~accessibility_identifier:"Document actions"
+ [ button_group ~label:"Document actions"
[ button ~icon:`save ~text:"Save" ~disabled:(reactive disabled)
~on_press:(press send Model.ToggleDisabled) []
; dyn
@@ -170,7 +170,7 @@ let glass_buttons_section : t =
let toggle_group_section model_source send : t =
let disabled = model_source >|= Model.disabled in
section "ToggleGroup"
- [ toggle_group ~accessibility_identifier:"View options"
+ [ toggle_group ~label:"View options"
[ dyn
~equal:(fun (a : Model.t) (b : Model.t) ->
a.Model.checked = b.Model.checked)
@@ -199,7 +199,7 @@ let toggle_group_section model_source send : t =
let breadcrumb_section send : t =
section "Breadcrumb"
- [ breadcrumb ~accessibility_identifier:"Component path"
+ [ breadcrumb ~label:"Component path"
[ text ~value:"Gallery" ~foreground:"muted-foreground"
~on_press:(press send (Model.SelectTab "overview")) []
; icon ~name:`chevron_right ~size:`sm
@@ -221,7 +221,7 @@ let pagination_section model_source send : t =
model_source
in
section "Pagination"
- [ pagination ~accessibility_identifier:"Gallery pages"
+ [ pagination ~label:"Gallery pages"
[ button ~variant:`ghost ~icon:`chevron_left ~text:"Previous"
~disabled:(reactive disabled)
~on_press:(press send (Model.SelectTab "overview")) []
@@ -277,7 +277,7 @@ let bottom_tabs_section model_source send : t =
~selected:(reactive home)
~on_press:(press send (Model.SelectBottomTab "home"))
[ column ~gap:12 ~padding:20
- [ heading ~level:3 ~value:"Home" []
+ [ text ~style_class:"headline" ~value:"Home" []
; input ~label:"Draft" ~placeholder:"Retained home draft" []
; paragraph
~value:"This input stays mounted while another destination is active."
@@ -288,7 +288,7 @@ let bottom_tabs_section model_source send : t =
~selected:(reactive search)
~on_press:(press send (Model.SelectBottomTab "search"))
[ column ~gap:12 ~padding:20
- [ heading ~level:3 ~value:"Search" []
+ [ text ~style_class:"headline" ~value:"Search" []
; paragraph
~value:"Search uses the same retained destination model." []
]
@@ -297,7 +297,7 @@ let bottom_tabs_section model_source send : t =
~selected:(reactive settings)
~on_press:(press send (Model.SelectBottomTab "settings"))
[ column ~gap:12 ~padding:20
- [ heading ~level:3 ~value:"Settings" []
+ [ text ~style_class:"headline" ~value:"Settings" []
; paragraph
~value:"Platform chrome changes without rebuilding this page." []
]
@@ -903,11 +903,10 @@ let toast_section model_source send : t =
let toolbar_section model_source send : t =
let value = model_source >|= Model.field_value in
let checked = model_source >|= Model.checked in
- let disabled = model_source >|= Model.disabled in
section "Toolbar"
[ toolbar ~orientation:`horizontal ~label:"Formatting" ~gap:4
[ button ~variant:`ghost ~text:"Bold" ~on_press:noop []
- ; button_group ~accessibility_identifier:"Text style"
+ ; button_group ~label:"Text style"
[ button ~variant:`ghost ~text:"Italic" ~on_press:noop []
; button ~variant:`ghost ~text:"Underline" ~on_press:noop []
]
@@ -921,11 +920,11 @@ let toolbar_section model_source send : t =
[ button ~variant:`ghost ~text:"Link" ~on_press:noop []
; button ~variant:`ghost ~text:"Image" ~on_press:noop []
; checkbox ~text:"Locked option" ~checked:(reactive checked)
- ~disabled:(reactive disabled) []
+ ~disabled:true []
; select ~text:(reactive value) ~placeholder:"Locked picker"
- ~disabled:(reactive disabled) []
+ ~disabled:true []
; input ~text:(reactive value) ~label:"Locked input"
- ~disabled:(reactive disabled) []
+ ~disabled:true []
]
; paragraph
~value:"Toolbar composes ordinary controls and owns only orientation-aware roving focus."
@@ -936,7 +935,7 @@ let accordion_section model_source send : t =
let open_ = model_source >|= Model.accordion_open in
section "Accordion"
[ accordion ~text:"Do collapsed children stay retained?"
- ~selected:(sample open_)
+ ~selected:(reactive open_)
~on_toggle:(on_toggle send (fun v -> Model.SetAccordionOpen v))
[ paragraph
~value:"Yes. The native disclosure hides this content while LUI preserves its node identity."
@@ -1018,7 +1017,8 @@ let combobox_section model_source send : t =
]
; row ~gap:8 ~cross:`center
[ text ~value:"Shared query:" []
- ; text ~value:(reactive query) []
+ ; text ~value:(reactive query)
+ ~style_class:"lui-combobox-query-value" []
]
; paragraph
~value:"Signals filter the retained options while the native input keeps focus and identity."
@@ -1319,21 +1319,40 @@ let native_extension_section : t =
fun context parent ->
let page =
column ~gap:16 ~padding:32
- [ heading ~level:2 ~value:"Native Extensions" []
+ [ heading ~level:2 ~value:"NativeExtension" []
; paragraph
~value:"apple-map renders a real MapKit map; its marker children stay retained."
[]
]
in
let page_id = page context parent in
- ignore
- (Extension_schemas.apple_map ~latitude:37.3349 ~longitude:(-122.0090)
- ~latitude_delta:0.02 ~longitude_delta:0.02
- [
- Extension_schemas.apple_map_marker ~title:"Apple Park"
- ~latitude:37.3349 ~longitude:(-122.0090) ();
- ]
- context (Some page_id));
+ (match Lui_ui.host context with
+ | Lui_protocol.WebHost ->
+ ignore
+ (column ~gap:16
+ [ label ~value:"Map" []
+ ; Extension_schemas.simulator_map ~label:"Map of San Francisco"
+ ~latitude:37.7793 ~longitude:(-122.4193) ~latitude_delta:0.08
+ ~longitude_delta:0.08 ~on_region_change:(fun _ -> ())
+ [
+ Extension_schemas.simulator_map_marker ~title:"San Francisco"
+ ~latitude:37.7793 ~longitude:(-122.4193) ();
+ ]
+ ; label ~value:"Camera" []
+ ; Extension_schemas.simulator_camera ~label:"Back camera preview"
+ ~facing:"environment" ~on_state_change:(fun _ -> ())
+ ();
+ ]
+ context (Some page_id))
+ | _ ->
+ ignore
+ (Extension_schemas.apple_map ~latitude:37.3349 ~longitude:(-122.0090)
+ ~latitude_delta:0.02 ~longitude_delta:0.02
+ [
+ Extension_schemas.apple_map_marker ~title:"Apple Park"
+ ~latitude:37.3349 ~longitude:(-122.0090) ();
+ ]
+ context (Some page_id)));
page_id
let split_panes_section model_source send : t =
@@ -1371,6 +1390,8 @@ let tweak_paragraph : t =
Lui_elements.attach context parent node;
node
+let tweak_section : t = section "Tweaks" [ tweak_paragraph ]
+
(* Composite components (lui_element_combine): generic layouts built
purely from primitives — composer, banners, settings rows, sidebar. *)
@@ -1593,9 +1614,10 @@ let view context model_source send : t =
sections
@ [
native_extension_section;
- tweak_paragraph;
+ tweak_section;
split_panes_section model_source send;
]
+ | WebOS -> sections @ [ native_extension_section; tweak_section ]
| _ -> sections
in
column sections
diff --git a/platform/web/melange/PORTING.md b/platform/web/melange/PORTING.md
new file mode 100644
index 00000000..57fedb63
--- /dev/null
+++ b/platform/web/melange/PORTING.md
@@ -0,0 +1,67 @@
+# Web backend port: conventions
+
+The OCaml/Melange port of the deleted LG web backend (`/tmp/lui-web-ref/web.cljc`,
+6379 lines; interface contract in `/tmp/lui-web-ref/web.mli`; retained mirror in
+`/tmp/lui-web-ref/retained.cljc`, already ported in `core/lui_web_store.ml`).
+
+## Module map (dependency order, bottom → top)
+
+| Module | File | Owns |
+|---|---|---|
+| types | `core/lui_web_types.ml` | all records (done) |
+| util | `core/lui_web_util.ml` | DOM helpers, coercions, CSS (done) |
+| store | `core/lui_web_store.ml` | retained mirror + validations + store queries (done) |
+| nodes | `nodes/lui_web_nodes.ml` | base-class table, element factories, `platform_node`, `dom_node`, dropdown anchor/side/offset |
+| position | `popup/lui_web_position.ml` | popup geometry, transitions, submenu corridor |
+| widgets | `widgets/lui_web_widgets.ml` | avatar/image/media-surface/icon/stepper/timeline/bottom-tabs/progress/select-display |
+| widgets | `widgets/lui_web_split.ml` | split render/reconcile/update + pointer events |
+| focus | `focus/lui_web_focus.ml` | tree, horizontal groups, tabs roving, toolbar, radio, restore-focus |
+| overlay | `popup/lui_web_overlay.ml` | modal (stack/inert/focus-trap), tooltip, toast |
+| menu | `popup/lui_web_menu.ml` | dropdown, picker/combobox, context-menu |
+| props | `render/lui_web_props.ml` | `apply_property!`/`remove_property!`/class refresh |
+| events | `events/lui_web_events.ml` | `attach_events!` dispatch + control listeners |
+| apply | `shell/lui_web_apply.ml` | `apply_dom_op!`/`apply_dom_batch!`, cleanup, structured refresh |
+| simulator | `shell/lui_web_simulator.ml` | device emulation |
+| top | `shell/lui_web.ml` | `create*`, `backend`, `mount!`, `root_sections`, extension plumbing, query API |
+
+Modules may only call modules strictly below them. `apply` may call all;
+`events` may call popup/focus/widgets; `props` may call widgets/focus/nodes.
+
+## Rules
+
+- Never `Obj.magic`. For DOM type narrowing use the `%identity` externals in
+ `core/lui_web_util.ml` (same mechanism melange-webapi itself uses); add new
+ ones there only, with the JS property name visible.
+- Every function ≤64 lines. Factor shared logic up into the lowest layer that
+ can host it (util for pure DOM, store for mirror queries).
+- Keep the exact DOM structure the LG code produced: same tags, same class
+ names (`base_class_name`), same attributes and child order.
+- Do NOT touch dune files, git, or files owned by another module. Do NOT
+ `git commit`.
+
+## Translation cheatsheet
+
+- `atom` → `ref`; `deref` → `!`; `reset!` → `:=`; `swap!` → `:= f !x`.
+- `hash-map`/maps on `retained_properties` → `Lui_protocol.Property_map`
+ (persistent, `find_opt`/`add`/`remove`/`mem`); extension props → `String_map`.
+- vectors (`Rrbvec`, `[]`) → `list`; `conj` → append; `nth` → `List.nth`.
+- `(if-some [x e] a b)` → `match e with Some x -> a | None -> b`.
+- `(raise (Invalid_argument m))` → `invalid_arg m`.
+- Event emit: `((deref (:web-event-handler renderer)) (proto/Press node))`
+ → `ignore (!(renderer.web_event_handler) (Press node))`
+ (open `Lui_protocol` for the event variants).
+- `addEventListener` handlers take `Dom.event -> unit`; typed helpers exist
+ (`addClickEventListener`, `addKeyDownEventListener`, `addFocusInEventListener`
+ …). For pointer events use `addEventListener "pointerdown"` +
+ `Lui_web_util.as_pointer_event` / `pointer_type` / `pointer_id`.
+- webapi arg order differs per function — check signatures:
+ `setAttribute name value el`, `setClassName el name`,
+ `HtmlCollection.item index col`, `insertBefore new ref parent`,
+ `Element.addEventListener "type" handler el`.
+- `Js.Global.setTimeout`, `Webapi.requestAnimationFrame` are available.
+
+## Verify
+
+From repo root: `opam exec --switch=default -- dune build` must compile the
+whole `lui.web.dom` library (other modules are still `failwith` stubs — keep
+stub signatures compatible: names and arity as listed in your stub file).
diff --git a/platform/web/melange/core/lui_web_store.ml b/platform/web/melange/core/lui_web_store.ml
new file mode 100644
index 00000000..0bcd4e43
--- /dev/null
+++ b/platform/web/melange/core/lui_web_store.ml
@@ -0,0 +1,748 @@
+(* Backend-side retained mirror: tracks the runtime tree the way the LG
+ retained.cljc store did — applying each patch op with validation, checking
+ the whole graph after a batch, then recording the committed batch. *)
+
+open Lui_protocol
+open Lui_web_types
+
+let create_store () =
+ { retained_nodes = Hashtbl.create 64;
+ retained_batches = [];
+ retained_generation = 0 }
+
+let find_child_index children child =
+ let rec loop index rest =
+ match rest with
+ | [] -> None
+ | candidate :: tail ->
+ if candidate = child then Some index else loop (index + 1) tail
+ in
+ loop 0 children
+
+let remove_at values removed_index =
+ List.filteri (fun index _ -> index <> removed_index) values
+
+let insert_at values inserted_index value =
+ if inserted_index < 0 || inserted_index > List.length values then
+ invalid_arg "child index is out of bounds";
+ let rec loop index rest acc =
+ match rest with
+ | [] -> List.rev_append acc [ value ] |> (fun xs -> xs)
+ | head :: tail ->
+ let acc = if index = inserted_index then value :: acc else acc in
+ loop (index + 1) tail (head :: acc)
+ in
+ if inserted_index = List.length values then values @ [ value ]
+ else loop 0 values []
+
+let move_at values from_index to_index =
+ match List.nth_opt values from_index with
+ | None -> values
+ | Some value ->
+ let without = remove_at values from_index in
+ insert_at without to_index value
+
+let standard_kind current =
+ match current.semantic_kind with
+ | StandardSemantic kind -> Some kind
+ | ExtensionSemantic _ -> None
+
+let standard_kind_is current expected =
+ match standard_kind current with
+ | Some kind -> kind = expected
+ | None -> false
+
+(* MenuTrigger renders as a menu row (a submenu's trigger), so menu
+ behaviour that matches MenuItem rows covers both kinds. *)
+let menu_item_row current =
+ match standard_kind current with
+ | Some kind -> kind = MenuItem || kind = MenuTrigger
+ | None -> false
+
+let extension_identity current =
+ match current.semantic_kind with
+ | ExtensionSemantic (identifier, fingerprint) -> Some (identifier, fingerprint)
+ | StandardSemantic _ -> None
+
+(* [target] is a descendant-or-self of [root] iff walking the retained-parent
+ chain from target reaches root. *)
+let rec descendant nodes root target =
+ if target = root then true
+ else
+ match Hashtbl.find_opt nodes target with
+ | Some node ->
+ (match node.retained_parent with
+ | Some parent -> descendant nodes root parent
+ | None -> false)
+ | None -> false
+
+let extension_schema registry identifier =
+ match Lui_extension.schema registry identifier with
+ | Some schema -> schema
+ | None -> invalid_arg "unknown extension identifier"
+
+let rec retained_child_supported registry nodes parent child =
+ match child.semantic_kind with
+ | ExtensionSemantic (child_identifier, _) ->
+ if Lui_extension.is_tweak registry child_identifier then
+ match child.retained_children with
+ | [ inner_id ] ->
+ (match Hashtbl.find_opt nodes inner_id with
+ | Some inner -> retained_child_supported registry nodes parent inner
+ | None -> false)
+ | _ -> false
+ else
+ (match parent.semantic_kind with
+ | StandardSemantic parent_kind ->
+ Lui_extension.standard_container_supported parent_kind
+ | ExtensionSemantic (parent_identifier, _) ->
+ if Lui_extension.is_tweak registry parent_identifier then
+ parent.retained_children = []
+ else
+ Lui_extension.identifier_allowed
+ (extension_schema registry parent_identifier)
+ .extension_child_identifiers
+ child_identifier)
+ | StandardSemantic child_kind ->
+ if child_kind = Root then false
+ else
+ (match parent.semantic_kind with
+ | StandardSemantic parent_kind ->
+ can_contain_children parent_kind
+ && child_kind_supported parent_kind child_kind
+ | ExtensionSemantic (parent_identifier, _) ->
+ if Lui_extension.is_tweak registry parent_identifier then
+ parent.retained_children = []
+ else
+ (extension_schema registry parent_identifier)
+ .extension_standard_children)
+
+let unsupported_child_message parent child =
+ match (parent.semantic_kind, child.semantic_kind) with
+ | StandardSemantic parent_kind, StandardSemantic _ ->
+ if not (can_contain_children parent_kind) then
+ "parent cannot contain children"
+ else if parent_kind = Table then "table can contain only table-row"
+ else if parent_kind = TableRow then "table-row can contain only table-cell"
+ else if parent_kind = Tree then "tree accepts only row containers"
+ else "unsupported child kind"
+ | _ -> "unsupported child kind"
+
+let with_children node children = { node with retained_children = children }
+
+let replace nodes node_id next = Hashtbl.replace nodes node_id next
+
+let fetch nodes node_id what =
+ match Hashtbl.find_opt nodes node_id with
+ | Some node -> node
+ | None -> invalid_arg ("unknown " ^ what)
+
+let apply_create_node nodes platform_for node_id kind =
+ if Hashtbl.mem nodes node_id then invalid_arg "node already exists";
+ replace nodes node_id
+ { platform_node = platform_for kind;
+ semantic_kind = StandardSemantic kind;
+ retained_parent = None;
+ retained_properties = Property_map.empty;
+ retained_extension_properties = String_map.empty;
+ retained_children = [] }
+
+let apply_create_extension nodes extension_platform_for registry node_id identifier fingerprint =
+ if Hashtbl.mem nodes node_id then invalid_arg "node already exists";
+ let schema = extension_schema registry identifier in
+ let expected =
+ if Lui_extension.is_tweak registry identifier then
+ Lui_extension.tweak_fingerprint schema
+ else Lui_extension.fingerprint schema
+ in
+ if fingerprint <> expected then invalid_arg "extension fingerprint mismatch";
+ replace nodes node_id
+ { platform_node = extension_platform_for node_id identifier;
+ semantic_kind = ExtensionSemantic (identifier, fingerprint);
+ retained_parent = None;
+ retained_properties = Property_map.empty;
+ retained_extension_properties = String_map.empty;
+ retained_children = [] }
+
+let apply_drop_node nodes node_id =
+ let current = fetch nodes node_id "node" in
+ if current.retained_parent <> None then
+ invalid_arg "cannot drop an attached node"
+ else if current.retained_children <> [] then
+ invalid_arg "cannot drop a node with children"
+ else Hashtbl.remove nodes node_id
+
+let apply_set_prop nodes node_id property value =
+ let current = fetch nodes node_id "node" in
+ match standard_kind current with
+ | Some kind ->
+ if
+ property_supported kind property
+ && property_value_supported_for_kind kind property value
+ then
+ replace nodes node_id
+ { current with
+ retained_properties =
+ Property_map.add property value current.retained_properties }
+ else invalid_arg "unsupported property value"
+ | None -> invalid_arg "standard property targets extension"
+
+let apply_remove_prop nodes node_id property =
+ let current = fetch nodes node_id "node" in
+ match standard_kind current with
+ | Some kind ->
+ if property_supported kind property then
+ replace nodes node_id
+ { current with
+ retained_properties =
+ Property_map.remove property current.retained_properties }
+ else invalid_arg "unsupported property"
+ | None -> invalid_arg "standard property targets extension"
+
+let apply_set_extension_prop nodes registry node_id property value =
+ let current = fetch nodes node_id "node" in
+ match current.semantic_kind with
+ | ExtensionSemantic (identifier, _) ->
+ let schema = extension_schema registry identifier in
+ if not (Lui_extension.property_value_supported schema property value) then
+ invalid_arg "unsupported extension property value";
+ replace nodes node_id
+ { current with
+ retained_extension_properties =
+ String_map.add property value current.retained_extension_properties }
+ | StandardSemantic _ ->
+ invalid_arg "extension property targets standard node"
+
+let apply_remove_extension_prop nodes registry node_id property =
+ let current = fetch nodes node_id "node" in
+ match current.semantic_kind with
+ | ExtensionSemantic (identifier, _) ->
+ let schema = extension_schema registry identifier in
+ if not (Lui_extension.property_supported schema property) then
+ invalid_arg "unknown extension property";
+ replace nodes node_id
+ { current with
+ retained_extension_properties =
+ String_map.remove property current.retained_extension_properties }
+ | StandardSemantic _ ->
+ invalid_arg "extension property targets standard node"
+
+let apply_insert_child nodes registry parent_id child_id index =
+ let parent_node = fetch nodes parent_id "parent" in
+ let child_node = fetch nodes child_id "child" in
+ if not (retained_child_supported registry nodes parent_node child_node) then
+ invalid_arg (unsupported_child_message parent_node child_node)
+ else if descendant nodes child_id parent_id then
+ invalid_arg "child insertion would create a cycle"
+ else if child_node.retained_parent <> None then
+ invalid_arg "child is already attached"
+ else begin
+ replace nodes parent_id
+ (with_children parent_node
+ (insert_at parent_node.retained_children index child_id));
+ replace nodes child_id { child_node with retained_parent = Some parent_id }
+ end
+
+let apply_remove_child nodes parent_id child_id =
+ let parent_node = fetch nodes parent_id "parent" in
+ match find_child_index parent_node.retained_children child_id with
+ | Some index ->
+ let child_node = fetch nodes child_id "child" in
+ replace nodes parent_id
+ (with_children parent_node
+ (remove_at parent_node.retained_children index));
+ replace nodes child_id { child_node with retained_parent = None }
+ | None -> invalid_arg "child is not attached to parent"
+
+let apply_move_child nodes parent_id child_id index =
+ let parent_node = fetch nodes parent_id "parent" in
+ match find_child_index parent_node.retained_children child_id with
+ | Some current_index ->
+ replace nodes parent_id
+ (with_children parent_node
+ (move_at parent_node.retained_children current_index index))
+ | None -> invalid_arg "child is not attached to parent"
+
+let apply_op nodes platform_for extension_platform_for registry operation =
+ match operation with
+ | CreateNode (node, kind) -> apply_create_node nodes platform_for node kind
+ | CreateExtension (node, identifier, fingerprint) ->
+ apply_create_extension nodes extension_platform_for registry node
+ identifier fingerprint
+ | DropNode node -> apply_drop_node nodes node
+ | SetProp (node, property, value) -> apply_set_prop nodes node property value
+ | RemoveProp (node, property) -> apply_remove_prop nodes node property
+ | SetExtensionProp (node, property, value) ->
+ apply_set_extension_prop nodes registry node property value
+ | RemoveExtensionProp (node, property) ->
+ apply_remove_extension_prop nodes registry node property
+ | InsertChild (parent, child, index) ->
+ apply_insert_child nodes registry parent child index
+ | RemoveChild (parent, child) -> apply_remove_child nodes parent child
+ | MoveChild (parent, child, index) ->
+ apply_move_child nodes parent child index
+
+let unavailable_extension_platform _node _identifier =
+ invalid_arg "extension registry is not configured"
+
+let string_property_of properties property =
+ match Property_map.find_opt property properties with
+ | Some (StringValue value) -> value
+ | _ -> ""
+
+let node_properties_error current =
+ let kind =
+ match standard_kind current with
+ | Some value -> value
+ | None -> invalid_arg "expected standard node"
+ in
+ let properties = current.retained_properties in
+ if not (surface_size_supported properties) then
+ "surface size constraints conflict"
+ else if kind = Button || kind = ToggleButton then
+ let text = string_property_of properties TextValue in
+ let label = string_property_of properties AccessibilityLabel in
+ let icon = string_property_of properties InlineIconName in
+ if text = "" && icon <> "" && label = "" then
+ "icon-only button requires an accessibility label"
+ else "button requires text or an accessibility label"
+ else if kind = Icon then "icon requires a valid name"
+ else "node properties conflict"
+
+let context_menu_child nodes child_id =
+ match Hashtbl.find_opt nodes child_id with
+ | Some current -> standard_kind_is current ContextMenu
+ | None -> false
+
+let validate_list_item_content nodes current =
+ if standard_kind_is current ListItem then begin
+ let text = string_property_of current.retained_properties TextValue in
+ let visible_children =
+ List.filter
+ (fun child -> not (context_menu_child nodes child))
+ current.retained_children
+ in
+ if text <> "" && visible_children <> [] then
+ invalid_arg "list-item accepts text or children, not both";
+ if text = "" && visible_children = [] then
+ invalid_arg "list-item requires text or children"
+ end
+
+let bool_property_true properties property =
+ match Property_map.find_opt property properties with
+ | Some (BoolValue true) -> true
+ | _ -> false
+
+let interactive_context_menu_host current =
+ let properties = current.retained_properties in
+ (match standard_kind current with
+ | Some kind -> context_menu_host_kind kind
+ | None -> false)
+ || bool_property_true properties PressEnabled
+ || bool_property_true properties DoublePressEnabled
+ || bool_property_true properties ToggleEnabled
+ || bool_property_true properties LongPressEnabled
+
+let context_menu_child_has_nested nodes child kind =
+ List.exists
+ (fun nested_id ->
+ match Hashtbl.find_opt nodes nested_id with
+ | Some nested -> standard_kind_is nested kind
+ | None -> false)
+ child.retained_children
+
+let validate_context_menu_child nodes child =
+ let properties = child.retained_properties in
+ let has_nested = context_menu_child_has_nested nodes child in
+ if
+ standard_kind_is child MenuItem
+ && not (bool_property_true properties PressEnabled)
+ && not (has_nested DropdownMenu)
+ then invalid_arg "context-menu menu-item requires press support";
+ if standard_kind_is child MenuItem && has_nested ContextMenu then
+ invalid_arg "context-menu submenu must use dropdown-menu";
+ if standard_kind_is child Divider then
+ let allowed =
+ Property_map.add OrientationValue (StringValue "horizontal")
+ (Property_map.add StyleClass (StringValue "lui-separator")
+ Property_map.empty)
+ in
+ if not (Property_map.is_empty properties || properties = allowed) then
+ invalid_arg "context-menu separator accepts no attributes"
+
+let validate_context_menu nodes current =
+ let context_children =
+ List.filter (context_menu_child nodes) current.retained_children
+ in
+ if List.length context_children > 1 then
+ invalid_arg "host accepts at most one context-menu";
+ if context_children <> [] && not (interactive_context_menu_host current) then
+ invalid_arg "context-menu host must be interactive";
+ if standard_kind_is current ContextMenu then begin
+ (match current.retained_parent with
+ | None -> invalid_arg "context-menu requires a direct host"
+ | Some _ -> ());
+ List.iter
+ (fun child_id ->
+ match Hashtbl.find_opt nodes child_id with
+ | Some child -> validate_context_menu_child nodes child
+ | None -> invalid_arg "unknown context-menu child")
+ current.retained_children
+ end
+
+let validate_image_source current =
+ match standard_kind current with
+ | Some kind when kind = Avatar || kind = Image ->
+ let properties = current.retained_properties in
+ let label = if kind = Avatar then "avatar" else "image" in
+ let present p = Property_map.mem p properties in
+ let source_count =
+ List.length
+ (List.filter present [ SourceX; SourceY; SourceWidth; SourceHeight ])
+ in
+ if source_count > 0 && source_count < 4 then
+ invalid_arg
+ (label ^ " source crop requires all four coordinates");
+ if source_count = 4 then begin
+ let float_prop p fallback =
+ match Property_map.find_opt p properties with
+ | Some (FloatValue value) -> value
+ | _ -> fallback
+ in
+ let x = float_prop SourceX (-1.0) in
+ let y = float_prop SourceY (-1.0) in
+ let width = float_prop SourceWidth 0.0 in
+ let height = float_prop SourceHeight 0.0 in
+ if x < 0.0 || y < 0.0 then
+ invalid_arg
+ (label ^ " source crop coordinates must be non-negative");
+ if width <= 0.0 || height <= 0.0 then
+ invalid_arg
+ (label ^ " source crop dimensions must be positive")
+ end
+ | _ -> ()
+
+let validate_media_resource current =
+ match standard_kind current with
+ | Some Image ->
+ if not (Property_map.mem ImageIdValue current.retained_properties) then
+ invalid_arg "image requires image"
+ | Some MediaSurface ->
+ if not (Property_map.mem SurfaceIdValue current.retained_properties) then
+ invalid_arg "media-surface requires surface"
+ | _ -> ()
+
+let validate_progress_structure current =
+ match standard_kind current with
+ | Some Stepper ->
+ if not (Property_map.mem ActiveIndex current.retained_properties) then
+ invalid_arg "stepper requires active"
+ | Some TimelineItem ->
+ if not (Property_map.mem TitleValue current.retained_properties) then
+ invalid_arg "timeline-item requires title"
+ | _ -> ()
+
+let child_kind_of nodes child_id =
+ match Hashtbl.find_opt nodes child_id with
+ | Some current ->
+ (match standard_kind current with
+ | Some kind -> kind
+ | None -> invalid_arg "expected standard child")
+ | None -> invalid_arg "unknown child"
+
+let validate_input_group nodes current =
+ match standard_kind current with
+ | Some InputGroup ->
+ let children = current.retained_children in
+ if children = [] || List.length children > 2 then
+ invalid_arg "input-group requires one textarea and optional actions";
+ if child_kind_of nodes (List.hd children) <> Textarea then
+ invalid_arg "input-group requires textarea first";
+ if List.length children = 2
+ && child_kind_of nodes (List.nth children 1) <> InputGroupActions
+ then invalid_arg "input-group actions must follow textarea"
+ | Some InputGroupActions ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match Hashtbl.find_opt nodes parent with
+ | Some parent_node ->
+ if not (standard_kind_is parent_node InputGroup) then
+ invalid_arg
+ "input-group-actions requires a direct input-group parent"
+ | None -> invalid_arg "unknown input-group parent")
+ | None ->
+ invalid_arg
+ "input-group-actions requires a direct input-group parent")
+ | _ -> ()
+
+let rec has_ancestor_kind nodes parent kind =
+ match parent with
+ | Some parent_id ->
+ (match Hashtbl.find_opt nodes parent_id with
+ | Some parent_node ->
+ standard_kind_is parent_node kind
+ || has_ancestor_kind nodes parent_node.retained_parent kind
+ | None -> false)
+ | None -> false
+
+let validate_tree_item nodes current =
+ if string_property_of current.retained_properties RoleValue = "treeitem"
+ && not (has_ancestor_kind nodes current.retained_parent Tree)
+ then invalid_arg "treeitem must be contained by a tree"
+
+let validate_split current =
+ if standard_kind_is current Split
+ && List.length current.retained_children <> 2
+ then invalid_arg "split requires exactly two children"
+
+let validate_drawer current =
+ if standard_kind_is current Drawer
+ && List.length current.retained_children <> 2
+ then invalid_arg "drawer requires exactly two children"
+
+let validate_root current =
+ if standard_kind_is current Root then begin
+ if current.retained_parent <> None then
+ invalid_arg "runtime root cannot have a parent";
+ if List.length current.retained_children <> 1 then
+ invalid_arg "runtime root requires exactly one child"
+ end
+
+let validate_standard_node nodes _registry current kind =
+ if kind = Radio
+ && not (has_ancestor_kind nodes current.retained_parent RadioGroup)
+ then invalid_arg "radio must be contained by a radio-group";
+ validate_list_item_content nodes current;
+ validate_context_menu nodes current;
+ validate_image_source current;
+ validate_media_resource current;
+ validate_progress_structure current;
+ validate_input_group nodes current;
+ validate_tree_item nodes current;
+ validate_split current;
+ validate_drawer current;
+ validate_root current;
+ if not (node_properties_supported kind current.retained_properties) then
+ invalid_arg (node_properties_error current)
+
+let validate_extension_node registry current identifier =
+ if
+ not
+ (Lui_extension.properties_supported
+ (extension_schema registry identifier)
+ current.retained_extension_properties)
+ then invalid_arg "extension properties are incomplete";
+ if
+ Lui_extension.is_tweak registry identifier
+ && List.length current.retained_children <> 1
+ then invalid_arg "platform tweak requires exactly one child"
+
+let validate_nodes nodes registry =
+ Hashtbl.iter
+ (fun _node current ->
+ match current.semantic_kind with
+ | StandardSemantic kind ->
+ validate_standard_node nodes registry current kind
+ | ExtensionSemantic (identifier, _) ->
+ validate_extension_node registry current identifier)
+ nodes
+
+let apply_operations nodes platform_for extension_platform_for registry batch =
+ List.iter
+ (fun op ->
+ apply_op nodes platform_for extension_platform_for registry op)
+ batch.ops;
+ validate_nodes nodes registry
+
+let commit_batch store platform_for extension_platform_for registry send_batch
+ batch =
+ let expected_generation = store.retained_generation + 1 in
+ if expected_generation <> batch.generation then
+ invalid_arg
+ (Printf.sprintf "expected patch generation %d, received %d"
+ expected_generation batch.generation);
+ apply_operations store.retained_nodes platform_for extension_platform_for
+ registry batch;
+ if send_batch batch then begin
+ store.retained_batches <- store.retained_batches @ [ batch ];
+ store.retained_generation <- batch.generation;
+ true
+ end
+ else invalid_arg "platform rejected patch batch"
+
+let apply_batch_with store platform_for send_batch batch =
+ commit_batch store platform_for unavailable_extension_platform
+ (Lui_extension.registry ()) send_batch batch
+
+let apply_batch_with_extensions store platform_for extension_platform_for
+ registry send_batch batch =
+ commit_batch store platform_for extension_platform_for registry send_batch
+ batch
+
+let apply_extension_batch store extension_platform_for registry batch =
+ let unavailable_standard_platform _kind =
+ invalid_arg "standard platform factory is not configured"
+ in
+ commit_batch store unavailable_standard_platform extension_platform_for
+ registry (fun _batch -> true) batch
+
+let apply_batch store platform_for batch =
+ apply_batch_with store platform_for (fun _batch -> true) batch
+
+let node store node_id = Hashtbl.find_opt store.retained_nodes node_id
+let nodes store = store.retained_nodes
+
+let platform_node store node_id =
+ match node store node_id with
+ | Some current -> Some current.platform_node
+ | None -> None
+
+let property store node_id property =
+ match node store node_id with
+ | Some current -> Property_map.find_opt property current.retained_properties
+ | None -> None
+
+let extension_identifier store node_id =
+ match node store node_id with
+ | Some current ->
+ (match current.semantic_kind with
+ | ExtensionSemantic (identifier, _) -> Some identifier
+ | StandardSemantic _ -> None)
+ | None -> None
+
+let extension_property store node_id property =
+ match node store node_id with
+ | Some current ->
+ String_map.find_opt property current.retained_extension_properties
+ | None -> None
+
+let children store node_id =
+ match node store node_id with
+ | Some current -> current.retained_children
+ | None -> invalid_arg "unknown node"
+
+let node_count store = Hashtbl.length store.retained_nodes
+let batches store = store.retained_batches
+let generation store = store.retained_generation
+
+(* Shared queries that only read the mirror — used by every feature module. *)
+
+let kind_of_store_node store node_id =
+ match node store node_id with
+ | Some current -> standard_kind current
+ | None -> None
+
+let dropdown_node store node_id =
+ match node store node_id with
+ | Some current -> standard_kind_is current DropdownMenu
+ | None -> false
+
+let modal_node store node_id =
+ match node store node_id with
+ | Some current ->
+ (match standard_kind current with
+ | Some kind -> modal_surface kind
+ | None -> false)
+ | None -> false
+
+let toast_node store node_id =
+ match node store node_id with
+ | Some current -> standard_kind_is current Toast
+ | None -> false
+
+let context_menu_node store node_id =
+ match node store node_id with
+ | Some current -> standard_kind_is current ContextMenu
+ | None -> false
+
+let anchored_tooltip current =
+ standard_kind_is current Tooltip
+ && Property_map.mem AnchorValue current.retained_properties
+
+let anchored_tooltip_node store node_id =
+ match node store node_id with
+ | Some current -> anchored_tooltip current
+ | None -> false
+
+let portal_surface_node store node_id =
+ context_menu_node store node_id
+ || dropdown_node store node_id
+ || toast_node store node_id
+ || anchored_tooltip_node store node_id
+ || modal_node store node_id
+
+let rec node_has_ancestor_kind store node_id kind =
+ match node store node_id with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match Hashtbl.find_opt store.retained_nodes parent with
+ | Some parent_node ->
+ standard_kind_is parent_node kind
+ || node_has_ancestor_kind store parent kind
+ | None -> false)
+ | None -> false)
+ | None -> false
+
+let true_property renderer node prop =
+ match property renderer.web_store node prop with
+ | Some (BoolValue true) -> true
+ | _ -> false
+
+let enabled_node renderer node =
+ match property renderer.web_store node Enabled with
+ | Some (BoolValue false) -> false
+ | _ -> true
+let event_capability renderer node prop = true_property renderer node prop
+
+let submit_on_enter renderer node = true_property renderer node SubmitOnEnter
+let submit_enabled renderer node = true_property renderer node SubmitEnabled
+
+let string_property renderer node prop =
+ match property renderer.web_store node prop with
+ | Some (StringValue value) -> value
+ | _ -> ""
+
+let int_property renderer node prop fallback =
+ match property renderer.web_store node prop with
+ | Some (IntValue value) -> value
+ | _ -> fallback
+
+let float_property renderer node prop fallback =
+ match property renderer.web_store node prop with
+ | Some (FloatValue value) -> value
+ | _ -> fallback
+
+let tooltip_delay renderer node = int_property renderer node TooltipDelay 600
+let toast_duration renderer node = int_property renderer node DurationValue 5000
+
+let selected_property renderer node =
+ true_property renderer node Selected
+
+let direct_toggle kind =
+ match kind with
+ | Checkbox | SwitchControl | Radio -> true
+ | _ -> false
+
+let button_like kind =
+ match kind with
+ | Button | ToggleButton | Toggle -> true
+ | _ -> false
+
+let treeitem renderer node =
+ match property renderer.web_store node RoleValue with
+ | Some (StringValue "treeitem") -> true
+ | _ -> false
+
+let rec tree_ancestor renderer node_id =
+ match node renderer.web_store node_id with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match node renderer.web_store parent with
+ | Some parent_node ->
+ if standard_kind_is parent_node Tree then Some parent
+ else tree_ancestor renderer parent
+ | None -> None)
+ | None -> None)
+ | None -> None
diff --git a/platform/web/melange/core/lui_web_types.ml b/platform/web/melange/core/lui_web_types.ml
new file mode 100644
index 00000000..bb1d5533
--- /dev/null
+++ b/platform/web/melange/core/lui_web_types.ml
@@ -0,0 +1,110 @@
+(* Shared types for the LUI web (DOM) backend. *)
+
+open Lui_protocol
+
+type web_node = Dom.element
+
+(** JS-side adapter for extension components. [web_extension_create node_id
+ document emit] builds the host element; [emit name payload] forwards an
+ extension event back into the LUI runtime. *)
+type web_extension_adapter = {
+ web_extension_create :
+ int -> Dom.document -> (string -> wire_value String_map.t -> unit) -> web_node;
+ web_extension_set_property : web_node -> string -> wire_value -> unit;
+ web_extension_remove_property : web_node -> string -> unit;
+ web_extension_cleanup : web_node -> unit;
+}
+
+type web_image_resource = {
+ web_image_url : string;
+ web_image_width : float;
+ web_image_height : float;
+}
+
+type web_split_state = {
+ web_split_source : float;
+ web_split_current : float;
+}
+
+type root_section = {
+ root_section_node : int;
+ root_section_title : string;
+}
+
+type web_simulator_form_factor =
+ | SimulatorPhone
+ | SimulatorTablet
+
+type web_simulator_orientation =
+ | SimulatorPortrait
+ | SimulatorLandscape
+
+type web_simulator_pointer =
+ | SimulatorTouch
+ | SimulatorHybrid
+
+type web_simulator_device = {
+ simulator_device_platform : operating_system;
+ simulator_device_form_factor : web_simulator_form_factor;
+ simulator_device_orientation : web_simulator_orientation;
+ simulator_device_pointer : web_simulator_pointer;
+ simulator_device_width : int;
+ simulator_device_height : int;
+ simulator_device_scale : float;
+ simulator_device_safe_top : int;
+ simulator_device_safe_right : int;
+ simulator_device_safe_bottom : int;
+ simulator_device_safe_left : int;
+ simulator_device_keyboard_height : int;
+}
+
+(** What a retained node semantically is: either a standard LUI element or an
+ extension node carrying its identifier and the schema fingerprint it was
+ created with. *)
+type semantic_kind =
+ | StandardSemantic of node_kind
+ | ExtensionSemantic of string * string
+
+(** Backend-side mirror of a runtime node. Properties live in the runtime's
+ own persistent maps so updates stay cheap and snapshot-friendly. *)
+type 'platform retained_node = {
+ platform_node : 'platform;
+ semantic_kind : semantic_kind;
+ mutable retained_parent : int option;
+ mutable retained_properties : wire_value Property_map.t;
+ mutable retained_extension_properties : wire_value String_map.t;
+ mutable retained_children : int list;
+}
+
+(** Mirror of the runtime tree plus the history needed for generation checks
+ and query APIs. Node records are updated functionally (the table entry is
+ replaced); the table itself is mutable. *)
+type 'platform retained_store = {
+ retained_nodes : (int, 'platform retained_node) Hashtbl.t;
+ mutable retained_batches : patch_batch list;
+ mutable retained_generation : int;
+}
+
+type web_renderer = {
+ web_store : web_node retained_store;
+ web_document : Dom.document;
+ web_host : web_node;
+ web_portal_root : web_node;
+ web_simulator_platform : operating_system option ref;
+ web_simulator_device : web_simulator_device option ref;
+ web_simulator_keyboard_visible : bool ref;
+ web_toast_viewport : web_node;
+ web_event_handler : (event -> bool) ref;
+ web_app_icons : string String_map.t;
+ web_images : (int, web_image_resource) Hashtbl.t;
+ web_media_surfaces : (int, web_image_resource) Hashtbl.t;
+ web_cleanups : (int, unit -> unit) Hashtbl.t;
+ web_modal_stack : int list ref;
+ web_modal_return_focus : web_node option ref;
+ web_open_tooltip : int option ref;
+ web_tooltip_warm : bool ref;
+ web_open_context_menu : int option ref;
+ web_splits : (int, web_split_state) Hashtbl.t;
+ web_extension_registry : Lui_extension.extension_registry;
+ web_extension_adapters : (string, web_extension_adapter) Hashtbl.t;
+}
diff --git a/platform/web/melange/core/lui_web_util.ml b/platform/web/melange/core/lui_web_util.ml
new file mode 100644
index 00000000..4843c911
--- /dev/null
+++ b/platform/web/melange/core/lui_web_util.ml
@@ -0,0 +1,163 @@
+(* Low-level DOM helpers shared by every web-backend feature module.
+ Nothing here reads the retained store. *)
+
+open Lui_web_types
+
+module W = Webapi.Dom
+
+(* The DOM is untyped: a "pointerdown" listener receives a Dom.event whose
+ runtime representation is a PointerEvent. melange-webapi performs the same
+ narrowing with its own %identity externals (EventTarget.asEventTarget,
+ Element.unsafeAsHtmlElement); these are the webapi-shaped equivalents for
+ the subtypes it does not export. *)
+external as_pointer_event : Dom.event -> Dom.pointerEvent = "%identity"
+external as_mouse_event : Dom.event -> Dom.mouseEvent = "%identity"
+external event_target_to_element : Dom.eventTarget -> Dom.element = "%identity"
+external element_to_event_target : Dom.element -> Dom.eventTarget = "%identity"
+external node_to_element : Dom.node -> Dom.element = "%identity"
+external element_to_html_element : Dom.element -> Dom.htmlElement = "%identity"
+
+external pointer_type_raw : Dom.pointerEvent -> string = "pointerType" [@@mel.get]
+external pointer_id_raw : Dom.pointerEvent -> int = "pointerId" [@@mel.get]
+
+let pointer_mouse_event (event : Dom.event) : Dom.mouseEvent = as_mouse_event event
+let pointer_type (event : Dom.event) : string = pointer_type_raw (as_pointer_event event)
+let pointer_id (event : Dom.event) : int = pointer_id_raw (as_pointer_event event)
+
+(* Element construction. [attributes] is (name, value) pairs applied before
+ children are appended, matching the original element/5 helper. *)
+let element document tag class_name attributes children =
+ let node = W.Document.createElement tag document in
+ List.iter
+ (fun (name, value) -> W.Element.setAttribute name value node)
+ attributes;
+ W.Element.setClassName node class_name;
+ List.iter (fun child -> W.Element.appendChild (W.Element.asNode child) node) children;
+ node
+
+let child_element dom_node index =
+ match W.HtmlCollection.item index (W.Element.children dom_node) with
+ | Some child -> child
+ | None ->
+ invalid_arg
+ ("DOM node child is missing: " ^ W.Element.tagName dom_node ^ "."
+ ^ W.Element.className dom_node ^ "[" ^ string_of_int index ^ "] of "
+ ^ string_of_int
+ (W.HtmlCollection.length (W.Element.children dom_node)))
+
+let text_control_node dom_node =
+ let tag_name = W.Element.tagName dom_node in
+ let candidate =
+ if tag_name = "INPUT" || tag_name = "TEXTAREA" then dom_node
+ else child_element dom_node 0
+ in
+ let candidate_tag_name = W.Element.tagName candidate in
+ if candidate_tag_name <> "INPUT" && candidate_tag_name <> "TEXTAREA" then
+ invalid_arg "DOM node is not a text control";
+ match W.HtmlInputElement.ofNode (W.Element.asNode candidate) with
+ | Some control -> control
+ | None -> invalid_arg "DOM node is not a text control"
+
+let toggle_label_node dom_node = child_element dom_node 1
+let button_icon_node dom_node = child_element dom_node 0
+let button_label_node dom_node = child_element dom_node 1
+
+let node_dom_id node = "lui-node-" ^ string_of_int node
+
+let accordion_trigger_node dom_node = child_element dom_node 0
+let accordion_panel_node dom_node = child_element dom_node 1
+let accordion_label_node dom_node = child_element (accordion_trigger_node dom_node) 0
+
+let initialize_accordion_semantics node dom_node =
+ let trigger = accordion_trigger_node dom_node in
+ let panel = accordion_panel_node dom_node in
+ let trigger_id = node_dom_id node ^ "-trigger" in
+ let panel_id = node_dom_id node ^ "-panel" in
+ W.Element.setAttribute "id" trigger_id trigger;
+ W.Element.setAttribute "id" panel_id panel;
+ W.Element.setAttribute "aria-controls" panel_id trigger;
+ W.Element.setAttribute "aria-labelledby" trigger_id panel
+
+let insert_dom_child parent child index =
+ let children = W.Element.children parent in
+ let length = W.HtmlCollection.length children in
+ if index = length then
+ W.Element.appendChild (W.Element.asNode child) parent
+ else
+ match W.HtmlCollection.item index children with
+ | Some reference ->
+ ignore
+ (W.Element.insertBefore
+ (W.Element.asNode child)
+ (W.Element.asNode reference)
+ parent)
+ | None -> invalid_arg "DOM child index is out of bounds"
+
+let document_body renderer =
+ let document = W.Document.unsafeAsHtmlDocument renderer.web_document in
+ match W.HtmlDocument.body document with
+ | Some body -> body
+ | None -> invalid_arg "document body is unavailable"
+
+let modal_layer_node surface =
+ match W.Element.parentElement surface with
+ | Some layer -> layer
+ | None -> invalid_arg "modal surface requires a portal layer"
+
+let bottom_tab_trigger_id node = "lui-bottom-tab-" ^ string_of_int node
+let bottom_tabs_pages_node dom_node = child_element dom_node 0
+let bottom_tabs_bar_node dom_node = child_element dom_node 1
+
+let focus_element element =
+ let html_element = W.Element.unsafeAsHtmlElement element in
+ W.HtmlElement.focus html_element
+
+let set_style scope name value =
+ W.CssStyleDeclaration.setProperty name value "" scope
+
+let set_state_attribute dom_node attribute enabled =
+ if enabled then W.Element.setAttribute attribute "" dom_node
+ else W.Element.removeAttribute attribute dom_node
+
+let css_url url =
+ let buffer = Buffer.create (String.length url + 8) in
+ Buffer.add_string buffer "url(\"";
+ String.iter
+ (fun c ->
+ if c = '\\' || c = '"' then Buffer.add_char buffer '\\';
+ Buffer.add_char buffer c)
+ url;
+ Buffer.add_string buffer "\")";
+ Buffer.contents buffer
+
+let semantic_color_names =
+ [ "background"; "foreground"; "card"; "card-foreground"; "primary";
+ "primary-foreground"; "secondary"; "secondary-foreground"; "accent";
+ "accent-foreground"; "muted-foreground"; "destructive";
+ "destructive-foreground"; "success"; "success-foreground"; "warning";
+ "warning-foreground"; "error"; "error-foreground"; "input"; "ring";
+ "border" ]
+
+let web_color_value color =
+ if color = "transparent" then "transparent"
+ else if List.mem color semantic_color_names then "var(--color-" ^ color ^ ")"
+ else color
+
+(* Which element actually receives children for a given node kind. Several
+ components keep their content in a wrapper child (dropdown menu surface,
+ split panes, modal layers, accordion panels). *)
+let content_container kind dom_node =
+ match kind with
+ | Lui_protocol.DropdownMenu | Lui_protocol.Split -> child_element dom_node 0
+ | Lui_protocol.Alert -> child_element dom_node 1
+ | Lui_protocol.Bubble -> child_element dom_node 0
+ | Lui_protocol.Accordion -> accordion_panel_node dom_node
+ | kind when Lui_protocol.modal_surface kind -> child_element dom_node 1
+ | _ -> dom_node
+
+let set_optional_text element value =
+ W.Element.setTextContent element value;
+ if value = "" then W.Element.setAttribute "hidden" "" element
+ else W.Element.removeAttribute "hidden" element
+
+let some_node value = Some value
diff --git a/platform/web/melange/dune b/platform/web/melange/dune
index e6faff1a..aaf75e4c 100644
--- a/platform/web/melange/dune
+++ b/platform/web/melange/dune
@@ -1,7 +1,9 @@
+(include_subdirs unqualified)
+
(library
(name lui_web_dom)
(public_name lui.web.dom)
(wrapped false)
(modes melange)
- (libraries melange-webapi)
+ (libraries lui melange-webapi melange.dom)
(preprocess (pps melange.ppx)))
diff --git a/platform/web/melange/events/lui_web_events.ml b/platform/web/melange/events/lui_web_events.ml
new file mode 100644
index 00000000..eb1b2bac
--- /dev/null
+++ b/platform/web/melange/events/lui_web_events.ml
@@ -0,0 +1,476 @@
+(* DOM event wiring for the web backend: per-control listeners plus the
+ attach_events! dispatcher. Source: web.cljc — see PORTING.md. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+
+(* web.cljc enabled-node? — a node is interactive unless Enabled is
+ explicitly BoolValue false; an absent property means enabled. *)
+let enabled_node renderer node =
+ match Store.property renderer.web_store node Enabled with
+ | Some (BoolValue false) -> false
+ | _ -> true
+
+let emit renderer event = ignore (!(renderer.web_event_handler) event)
+
+let record_modal_return_focus renderer element =
+ renderer.web_modal_return_focus := Some element;
+ ignore
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ match !(renderer.web_modal_return_focus) with
+ | Some current
+ when W.Element.isSameNode (W.Element.asNode current) element ->
+ renderer.web_modal_return_focus := None
+ | _ -> ())
+ 0)
+
+let combobox_keydown renderer node event =
+ let key = W.KeyboardEvent.key event in
+ let dropdown = Lui_web_menu.picker_dropdown renderer node in
+ if key = "ArrowDown" || key = "ArrowUp" then begin
+ W.KeyboardEvent.preventDefault event;
+ match dropdown with
+ | Some menu ->
+ let items = Lui_web_menu.picker_menu_items renderer menu in
+ let current = Lui_web_menu.combobox_active_index renderer node items in
+ let navigation_key =
+ if key = "ArrowDown" then "ArrowRight" else "ArrowLeft"
+ in
+ (match
+ Lui_web_focus.horizontal_focus_index
+ navigation_key current (List.length items)
+ with
+ | Some index ->
+ ignore (Lui_web_menu.set_combobox_active renderer node menu index)
+ | None -> ())
+ | None -> emit renderer (Press node)
+ end
+ else if key = "Enter" then begin
+ W.KeyboardEvent.preventDefault event;
+ match dropdown with
+ | Some menu ->
+ let items = Lui_web_menu.picker_menu_items renderer menu in
+ (match Lui_web_menu.combobox_active_index renderer node items with
+ | Some index ->
+ ignore
+ (Lui_web_menu.activate_menu_item renderer (List.nth items index))
+ | None ->
+ if items <> [] then
+ ignore
+ (Lui_web_menu.set_combobox_active renderer node menu 0))
+ | None ->
+ emit renderer
+ (if Store.submit_enabled renderer node then Submit node
+ else Press node)
+ end
+ else if key = "Escape" then
+ match dropdown with
+ | Some menu ->
+ W.KeyboardEvent.preventDefault event;
+ emit renderer (Dismiss menu)
+ | None -> ()
+
+let text_keydown renderer node kind composing event =
+ if enabled_node renderer node then begin
+ let composing_now = !composing || W.KeyboardEvent.isComposing event in
+ let enter = W.KeyboardEvent.key event = "Enter" in
+ let shift = W.KeyboardEvent.shiftKey event in
+ let primary =
+ W.KeyboardEvent.metaKey event || W.KeyboardEvent.ctrlKey event
+ in
+ let submit =
+ (not composing_now)
+ &&
+ (if enter then
+ (if kind = Textarea then
+ (if Store.submit_on_enter renderer node then not shift
+ else primary)
+ else true)
+ else false)
+ in
+ if submit && kind <> Combobox then begin
+ W.KeyboardEvent.preventDefault event;
+ emit renderer (Submit node)
+ end;
+ if kind = Combobox && not composing_now then
+ combobox_keydown renderer node event
+ end
+
+let attach_text_events renderer node kind dom_node =
+ let composing = ref false in
+ let committed_composition = ref None in
+ let current_value () =
+ W.HtmlInputElement.value (Util.text_control_node dom_node)
+ in
+ let emit_value value =
+ if enabled_node renderer node then begin
+ if
+ kind = Combobox
+ && Store.true_property renderer node PressEnabled
+ && Lui_web_menu.picker_dropdown renderer node = None
+ then emit renderer (Press node);
+ emit renderer (TextChanged (node, value))
+ end
+ in
+ W.Element.addEventListener "beforeinput"
+ (fun event ->
+ if not (enabled_node renderer node) then W.Event.preventDefault event)
+ dom_node;
+ W.Element.addEventListener "compositionstart"
+ (fun _event ->
+ composing := true;
+ committed_composition := None)
+ dom_node;
+ W.Element.addEventListener "compositionend"
+ (fun _event ->
+ let value = current_value () in
+ composing := false;
+ committed_composition := Some value;
+ emit_value value)
+ dom_node;
+ W.Element.addEventListener "input"
+ (fun _event ->
+ if not !composing then begin
+ let value = current_value () in
+ match !committed_composition with
+ | Some committed ->
+ committed_composition := None;
+ if value <> committed then emit_value value
+ | None -> emit_value value
+ end)
+ dom_node;
+ W.Element.addKeyDownEventListener
+ (fun event -> text_keydown renderer node kind composing event)
+ dom_node
+
+let attach_toggle_event renderer node _kind dom_node =
+ let control = Util.child_element dom_node 0 in
+ W.Element.addEventListener "click"
+ (fun event ->
+ if not (enabled_node renderer node) then W.Event.preventDefault event)
+ control;
+ W.Element.addEventListener "change"
+ (fun _event ->
+ if enabled_node renderer node then
+ let checked =
+ W.HtmlInputElement.checked (Util.text_control_node dom_node)
+ in
+ emit renderer (ToggleChanged (node, checked)))
+ control
+
+let attach_radio_event renderer node dom_node =
+ let control = Util.child_element dom_node 0 in
+ W.Element.addEventListener "click"
+ (fun event ->
+ if not (enabled_node renderer node) then W.Event.preventDefault event)
+ control;
+ W.Element.addEventListener "change"
+ (fun _event ->
+ if
+ enabled_node renderer node
+ && W.HtmlInputElement.checked (Util.text_control_node dom_node)
+ then
+ emit renderer
+ (if Store.true_property renderer node ChangeEnabled then Change node
+ else if Store.true_property renderer node ToggleEnabled then
+ ToggleChanged (node, true)
+ else Press node))
+ control
+
+let attach_slider_event renderer node dom_node =
+ W.Element.addEventListener "input"
+ (fun _event ->
+ emit renderer
+ (ValueChanged
+ (node,
+ W.HtmlInputElement.valueAsNumber
+ (Util.text_control_node dom_node))))
+ dom_node
+
+let attach_accordion_event renderer node dom_node =
+ W.Element.addEventListener "click"
+ (fun event ->
+ W.Event.preventDefault event;
+ if Store.true_property renderer node ToggleEnabled then begin
+ let selected = Store.true_property renderer node Selected in
+ emit renderer (ToggleChanged (node, not selected))
+ end)
+ (Util.accordion_trigger_node dom_node)
+
+let attach_pressable_text_events renderer node dom_node =
+ W.Element.addEventListener "click"
+ (fun _event ->
+ if Store.event_capability renderer node PressEnabled then
+ emit renderer (Press node))
+ dom_node;
+ W.Element.addKeyDownEventListener
+ (fun event ->
+ let key = W.KeyboardEvent.key event in
+ if
+ Store.event_capability renderer node PressEnabled
+ && (key = "Enter" || key = " ")
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ emit renderer (Press node)
+ end)
+ dom_node
+
+let attach_list_item_events renderer node dom_node =
+ W.Element.addEventListener "dblclick"
+ (fun _event ->
+ if Store.event_capability renderer node DoublePressEnabled then
+ emit renderer (DoublePress node))
+ dom_node;
+ W.Element.addKeyDownEventListener
+ (fun event ->
+ if
+ W.KeyboardEvent.key event = "Enter"
+ && Store.event_capability renderer node SubmitEnabled
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ emit renderer (Submit node)
+ end)
+ dom_node
+
+type button_state = {
+ button_timer : Js.Global.timeoutId option ref;
+ button_suppress_click : bool ref;
+ button_active_pointer : int option ref;
+ button_origin_x : int ref;
+ button_origin_y : int ref;
+}
+
+let button_long_press_enabled renderer node dom_node =
+ enabled_node renderer node
+ && W.Element.hasAttribute "data-long-press-enabled" dom_node
+ && not (W.Element.hasAttribute "disabled" dom_node)
+
+let button_connected renderer dom_node =
+ W.Element.contains
+ (W.Element.asNode dom_node)
+ (W.Document.documentElement renderer.web_document)
+
+let button_cancel_timer state =
+ (match !(state.button_timer) with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ state.button_timer := None
+
+let button_cancel_long_press state =
+ button_cancel_timer state;
+ state.button_active_pointer := None
+
+let button_dispatch_long_press renderer node dom_node state suppress =
+ if button_long_press_enabled renderer node dom_node then begin
+ state.button_suppress_click := suppress;
+ emit renderer (LongPress node)
+ end
+
+let button_dispatch_primary renderer node kind dom_node =
+ record_modal_return_focus renderer dom_node;
+ if kind = ToggleButton || kind = Toggle then begin
+ let selected =
+ match W.Element.getAttribute "aria-pressed" dom_node with
+ | Some "true" -> true
+ | _ -> false
+ in
+ let next_selected = not selected in
+ if next_selected then W.Element.setAttribute "data-selected" "" dom_node
+ else W.Element.removeAttribute "data-selected" dom_node;
+ W.Element.setAttribute "aria-pressed"
+ (if next_selected then "true" else "false")
+ dom_node;
+ emit renderer (ToggleChanged (node, next_selected))
+ end
+ else if kind = ListItem then begin
+ if Store.event_capability renderer node PressEnabled then
+ emit renderer (Press node);
+ if
+ Store.treeitem renderer node
+ && Store.event_capability renderer node ToggleEnabled
+ then
+ match Store.property renderer.web_store node Expanded with
+ | Some (BoolValue expanded) ->
+ emit renderer (ToggleChanged (node, not expanded))
+ | _ -> ()
+ end
+ else emit renderer (Press node)
+
+let button_schedule_long_press renderer node dom_node state =
+ state.button_timer :=
+ Some
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ state.button_timer := None;
+ if button_connected renderer dom_node then
+ button_dispatch_long_press renderer node dom_node state true)
+ 350)
+
+let button_pointer_down renderer node dom_node state event =
+ button_cancel_long_press state;
+ state.button_suppress_click := false;
+ if
+ button_long_press_enabled renderer node dom_node
+ && W.MouseEvent.button (Util.pointer_mouse_event event) = 0
+ then begin
+ state.button_active_pointer := Some (Util.pointer_id event);
+ state.button_origin_x :=
+ W.MouseEvent.clientX (Util.pointer_mouse_event event);
+ state.button_origin_y :=
+ W.MouseEvent.clientY (Util.pointer_mouse_event event);
+ if W.Event.isTrusted event then
+ W.Element.setPointerCapture
+ (W.PointerEvent.pointerId (Util.as_pointer_event event))
+ dom_node;
+ button_schedule_long_press renderer node dom_node state
+ end
+
+let button_pointer_move state event =
+ match !(state.button_active_pointer) with
+ | Some pointer when pointer = Util.pointer_id event ->
+ let delta_x =
+ abs (W.MouseEvent.clientX (Util.pointer_mouse_event event)
+ - !(state.button_origin_x))
+ in
+ let delta_y =
+ abs (W.MouseEvent.clientY (Util.pointer_mouse_event event)
+ - !(state.button_origin_y))
+ in
+ if delta_x > 10 || delta_y > 10 then begin
+ button_cancel_long_press state;
+ state.button_suppress_click := false
+ end
+ | _ -> ()
+
+let button_pointer_end state event =
+ match !(state.button_active_pointer) with
+ | Some pointer when pointer = Util.pointer_id event ->
+ button_cancel_long_press state
+ | _ -> ()
+
+let button_pointer_cancel state event =
+ match !(state.button_active_pointer) with
+ | Some pointer when pointer = Util.pointer_id event ->
+ button_cancel_long_press state;
+ state.button_suppress_click := false
+ | _ -> ()
+
+let button_context_menu renderer node dom_node state event =
+ if button_long_press_enabled renderer node dom_node then begin
+ button_cancel_long_press state;
+ W.Event.preventDefault event;
+ button_dispatch_long_press renderer node dom_node state false
+ end
+
+let button_click renderer node kind dom_node state event =
+ if not (enabled_node renderer node) then W.Event.preventDefault event
+ else if !(state.button_suppress_click) then begin
+ state.button_suppress_click := false;
+ W.Event.preventDefault event
+ end
+ else button_dispatch_primary renderer node kind dom_node
+
+let attach_button_events renderer node kind dom_node =
+ let state =
+ { button_timer = ref None;
+ button_suppress_click = ref false;
+ button_active_pointer = ref None;
+ button_origin_x = ref 0;
+ button_origin_y = ref 0 }
+ in
+ let pointer_down = button_pointer_down renderer node dom_node state in
+ let pointer_move = button_pointer_move state in
+ let pointer_end = button_pointer_end state in
+ let pointer_cancel = button_pointer_cancel state in
+ let context_menu = button_context_menu renderer node dom_node state in
+ let click = button_click renderer node kind dom_node state in
+ let previous_cleanup = Hashtbl.find_opt renderer.web_cleanups node in
+ W.Element.addEventListener "pointerdown" pointer_down dom_node;
+ W.Element.addEventListener "pointermove" pointer_move dom_node;
+ W.Element.addEventListener "pointerup" pointer_end dom_node;
+ W.Element.addEventListener "pointercancel" pointer_cancel dom_node;
+ W.Element.addEventListener "lostpointercapture" pointer_cancel dom_node;
+ W.Element.addEventListener "contextmenu" context_menu dom_node;
+ W.Element.addEventListener "click" click dom_node;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ (match previous_cleanup with
+ | Some cleanup -> cleanup ()
+ | None -> ());
+ button_cancel_long_press state;
+ W.Element.removeEventListener "pointerdown" pointer_down dom_node;
+ W.Element.removeEventListener "pointermove" pointer_move dom_node;
+ W.Element.removeEventListener "pointerup" pointer_end dom_node;
+ W.Element.removeEventListener "pointercancel" pointer_cancel dom_node;
+ W.Element.removeEventListener "lostpointercapture" pointer_cancel
+ dom_node;
+ W.Element.removeEventListener "contextmenu" context_menu dom_node;
+ W.Element.removeEventListener "click" click dom_node)
+
+let attach_events renderer node kind dom_node =
+ if kind <> ContextMenu then
+ ignore (Lui_web_menu.attach_context_host_events renderer node dom_node);
+ if tree_row_kind kind then
+ ignore
+ (Lui_web_focus.attach_tree_item_events renderer node kind dom_node);
+ if kind = Tree then
+ ignore (Lui_web_focus.attach_tree_events renderer node dom_node);
+ if kind = Toolbar then
+ ignore (Lui_web_focus.attach_toolbar_events renderer node dom_node);
+ match kind with
+ | Text | TableCell | TimelineItem ->
+ attach_pressable_text_events renderer node dom_node
+ | Button | ToggleButton | Toggle ->
+ attach_button_events renderer node kind dom_node
+ | TextField | SecureField | Input | SearchField | Textarea ->
+ attach_text_events renderer node kind dom_node
+ | Select ->
+ ignore (Lui_web_menu.attach_picker_trigger_events renderer node dom_node)
+ | Combobox ->
+ attach_text_events renderer node kind dom_node;
+ ignore
+ (Lui_web_menu.attach_picker_trigger_events renderer node
+ (Util.child_element dom_node 1))
+ | DropdownMenu ->
+ ignore
+ (Lui_web_menu.attach_dropdown_events renderer node
+ (Util.child_element dom_node 0))
+ | ContextMenu ->
+ ignore (Lui_web_menu.attach_context_menu_events renderer node dom_node)
+ | Dialog | Sheet ->
+ ignore (Lui_web_overlay.attach_modal_events renderer node dom_node)
+ | MenuItem | MenuTrigger ->
+ ignore (Lui_web_menu.attach_picker_press_event renderer node dom_node);
+ W.Element.addEventListener "focusin"
+ (fun _event ->
+ W.Element.setAttribute "data-highlighted" "" dom_node)
+ dom_node;
+ W.Element.addEventListener "focusout"
+ (fun _event -> W.Element.removeAttribute "data-highlighted" dom_node)
+ dom_node
+ | ListItem ->
+ attach_button_events renderer node kind dom_node;
+ attach_list_item_events renderer node dom_node
+ | Checkbox | SwitchControl ->
+ attach_toggle_event renderer node kind dom_node
+ | Radio -> attach_radio_event renderer node dom_node
+ | Slider -> attach_slider_event renderer node dom_node
+ | Split -> ignore (Lui_web_split.attach_split_events renderer node dom_node)
+ | Tabs | ButtonGroup | ToggleGroup | Breadcrumb | Pagination ->
+ ignore (Lui_web_focus.attach_horizontal_focus renderer node kind dom_node)
+ | Accordion -> attach_accordion_event renderer node dom_node
+ | _ -> ()
+
+let attach_events_bang = attach_events
+let attach_text_events_bang = attach_text_events
+let attach_toggle_event_bang = attach_toggle_event
+let attach_radio_event_bang = attach_radio_event
+let attach_slider_event_bang = attach_slider_event
+let attach_list_item_events_bang = attach_list_item_events
+let attach_pressable_text_events_bang = attach_pressable_text_events
+let attach_accordion_event_bang = attach_accordion_event
+let attach_button_events_bang = attach_button_events
diff --git a/platform/web/melange/focus/lui_web_focus.ml b/platform/web/melange/focus/lui_web_focus.ml
new file mode 100644
index 00000000..69e47706
--- /dev/null
+++ b/platform/web/melange/focus/lui_web_focus.ml
@@ -0,0 +1,908 @@
+(* Keyboard focus, roving tabindex, and typeahead for the LUI web DOM
+ backend. Port of web.cljc ranges 1339-1652, 1802-1827, 2430-2805,
+ 4712-4815, 5823-5842 — see PORTING.md. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+
+let standard_kind_strict current =
+ match Store.standard_kind current with
+ | Some kind -> kind
+ | None -> invalid_arg "expected standard DOM node"
+
+let tree_ancestor = Store.tree_ancestor
+
+let tree_items_under renderer parent =
+ let rec collect items child =
+ let items =
+ if Store.treeitem renderer child then child :: items else items
+ in
+ List.fold_left collect items
+ (Store.children renderer.web_store child)
+ in
+ List.rev
+ (List.fold_left collect []
+ (Store.children renderer.web_store parent))
+
+let tree_focus_items_under renderer parent =
+ List.filter
+ (fun node -> Store.enabled_node renderer node)
+ (tree_items_under renderer parent)
+
+let rec derived_tree_item_level renderer tree current level =
+ match Store.node renderer.web_store current with
+ | Some state ->
+ (match state.retained_parent with
+ | Some parent ->
+ if parent = tree then level
+ else
+ derived_tree_item_level renderer tree parent
+ (if Store.treeitem renderer parent then level + 1 else level)
+ | None -> level)
+ | None -> level
+
+let tree_item_level renderer tree node =
+ match Store.property renderer.web_store node TreeLevel with
+ | Some (IntValue level) -> level
+ | _ -> derived_tree_item_level renderer tree node 1
+
+let node_index nodes node =
+ let rec loop index = function
+ | [] -> -1
+ | item :: rest -> if item = node then index else loop (index + 1) rest
+ in
+ loop 0 nodes
+
+let logical_tree_parent renderer tree items node =
+ let index = node_index items node in
+ let level = tree_item_level renderer tree node in
+ let rec loop candidate =
+ if candidate < 0 then None
+ else
+ let candidate_node = List.nth items candidate in
+ if tree_item_level renderer tree candidate_node = level - 1 then
+ Some candidate_node
+ else loop (candidate - 1)
+ in
+ loop (index - 1)
+
+let logical_tree_child renderer tree items node =
+ let index = node_index items node in
+ let next_index = index + 1 in
+ if next_index < List.length items then
+ let candidate = List.nth items next_index in
+ if
+ tree_item_level renderer tree candidate
+ = tree_item_level renderer tree node + 1
+ then Some candidate
+ else None
+ else None
+
+let set_tree_tabstop renderer items target =
+ List.iter
+ (fun item ->
+ W.Element.setAttribute "tabindex"
+ (if item = target then "0" else "-1")
+ (Lui_web_nodes.dom_node renderer item))
+ items
+
+let set_tree_tabstop_bang = set_tree_tabstop
+
+let dispatch_tree_selection renderer node =
+ ignore
+ (!(renderer.web_event_handler)
+ (if Store.event_capability renderer node ChangeEnabled then Change node
+ else Press node))
+
+let dispatch_tree_selection_bang = dispatch_tree_selection
+
+let focus_tree_item renderer _tree items node =
+ set_tree_tabstop renderer items node;
+ W.HtmlElement.focus
+ (W.Element.unsafeAsHtmlElement (Lui_web_nodes.dom_node renderer node));
+ dispatch_tree_selection renderer node
+
+let focus_tree_item_bang = focus_tree_item
+
+let refresh_tree_item_accessibility renderer tree node =
+ let element = Lui_web_nodes.dom_node renderer node in
+ W.Element.setAttribute "aria-level"
+ (string_of_int (tree_item_level renderer tree node))
+ element;
+ W.Element.setAttribute "aria-disabled"
+ (if Store.enabled_node renderer node then "false" else "true")
+ element;
+ (match Store.property renderer.web_store node Selected with
+ | Some (BoolValue selected) ->
+ W.Element.setAttribute "aria-selected"
+ (if selected then "true" else "false") element
+ | _ -> W.Element.removeAttribute "aria-selected" element);
+ match Store.property renderer.web_store node Expanded with
+ | Some (BoolValue expanded) ->
+ W.Element.setAttribute "aria-expanded"
+ (if expanded then "true" else "false") element
+ | _ -> W.Element.removeAttribute "aria-expanded" element
+
+let refresh_tree_item_accessibility_bang = refresh_tree_item_accessibility
+
+let rec focused_child_index renderer children focused index =
+ if index >= List.length children then None
+ else if
+ W.Element.isSameNode
+ (W.Element.asNode
+ (Lui_web_nodes.dom_node renderer (List.nth children index)))
+ focused
+ then Some index
+ else focused_child_index renderer children focused (index + 1)
+
+let update_tree_roving renderer tree =
+ let all_items = tree_items_under renderer tree in
+ let items = tree_focus_items_under renderer tree in
+ List.iter
+ (fun item ->
+ refresh_tree_item_accessibility renderer tree item;
+ W.Element.setAttribute "tabindex" "-1"
+ (Lui_web_nodes.dom_node renderer item))
+ all_items;
+ if items <> [] then begin
+ let selected =
+ let rec loop index =
+ if index = List.length items then List.hd items
+ else
+ let item = List.nth items index in
+ if
+ Store.property renderer.web_store item Selected
+ = Some (BoolValue true)
+ then item
+ else loop (index + 1)
+ in
+ loop 0
+ in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let active_index =
+ match W.HtmlDocument.activeElement document with
+ | Some focused -> focused_child_index renderer items focused 0
+ | None -> None
+ in
+ let target =
+ match active_index with
+ | Some index -> List.nth items index
+ | None -> selected
+ in
+ set_tree_tabstop renderer items target
+ end
+
+let update_tree_roving_bang = update_tree_roving
+
+let update_all_tree_roving renderer =
+ Hashtbl.iter
+ (fun node current ->
+ if Store.standard_kind_is current Tree then
+ update_tree_roving renderer node)
+ (Store.nodes renderer.web_store);
+ true
+
+let update_all_tree_roving_bang = update_all_tree_roving
+
+let cancel_typeahead typeahead_timer =
+ (match !typeahead_timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ typeahead_timer := None
+
+let reset_typeahead_later typeahead_buffer typeahead_timer =
+ cancel_typeahead typeahead_timer;
+ typeahead_timer :=
+ Some
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ typeahead_timer := None;
+ typeahead_buffer := "")
+ 500)
+
+let tree_item_keydown_target items index key =
+ if key = "ArrowUp" then
+ if index > 0 then Some (List.nth items (index - 1)) else None
+ else if key = "ArrowDown" then
+ if index + 1 < List.length items then
+ Some (List.nth items (index + 1))
+ else None
+ else if key = "Home" then Some (List.nth items 0)
+ else if key = "End" then
+ Some (List.nth items (List.length items - 1))
+ else None
+
+let attach_tree_item_events renderer node kind element =
+ (if kind <> ListItem then
+ W.Element.addEventListener "click"
+ (fun (_event : Dom.event) ->
+ if
+ Store.treeitem renderer node
+ && Store.event_capability renderer node PressEnabled
+ then ignore (!(renderer.web_event_handler) (Press node)))
+ element);
+ W.Element.addKeyDownEventListener
+ (fun (event : Dom.keyboardEvent) ->
+ if Store.treeitem renderer node then
+ match Store.tree_ancestor renderer node with
+ | Some tree ->
+ let items = tree_focus_items_under renderer tree in
+ let index = node_index items node in
+ let key = W.KeyboardEvent.key event in
+ (match tree_item_keydown_target items index key with
+ | Some target_node ->
+ W.KeyboardEvent.preventDefault event;
+ focus_tree_item renderer tree items target_node
+ | None ->
+ if key = "ArrowLeft" then begin
+ W.KeyboardEvent.preventDefault event;
+ if
+ Store.property renderer.web_store node Expanded
+ = Some (BoolValue true)
+ && Store.event_capability renderer node ToggleEnabled
+ then
+ ignore
+ (!(renderer.web_event_handler)
+ (ToggleChanged (node, false)))
+ else
+ match
+ logical_tree_parent renderer tree items node
+ with
+ | Some parent ->
+ focus_tree_item renderer tree items parent
+ | None -> ()
+ end
+ else if key = "ArrowRight" then begin
+ W.KeyboardEvent.preventDefault event;
+ if
+ Store.property renderer.web_store node Expanded
+ = Some (BoolValue false)
+ && Store.event_capability renderer node ToggleEnabled
+ then
+ ignore
+ (!(renderer.web_event_handler)
+ (ToggleChanged (node, true)))
+ else
+ match
+ logical_tree_child renderer tree items node
+ with
+ | Some child ->
+ focus_tree_item renderer tree items child
+ | None -> ()
+ end
+ else if
+ kind <> ListItem && (key = "Enter" || key = " ")
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ if Store.event_capability renderer node PressEnabled
+ then ignore (!(renderer.web_event_handler) (Press node))
+ end)
+ | None -> ())
+ element
+
+let attach_tree_item_events_bang = attach_tree_item_events
+
+let typeahead_key_handler renderer tree typeahead_buffer typeahead_timer
+ event =
+ let key = W.KeyboardEvent.key event in
+ if
+ String.length key = 1
+ && String.trim key <> ""
+ && not (W.KeyboardEvent.isComposing event)
+ && not (W.KeyboardEvent.metaKey event)
+ && not (W.KeyboardEvent.ctrlKey event)
+ && not (W.KeyboardEvent.altKey event)
+ then begin
+ let items = tree_focus_items_under renderer tree in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let current_index =
+ match W.HtmlDocument.activeElement document with
+ | Some focused -> focused_child_index renderer items focused 0
+ | None -> None
+ in
+ let query =
+ String.lowercase_ascii (!typeahead_buffer ^ key)
+ in
+ let start =
+ match current_index with Some index -> index | None -> -1
+ in
+ typeahead_buffer := query;
+ reset_typeahead_later typeahead_buffer typeahead_timer;
+ let rec loop offset =
+ if offset <= List.length items then begin
+ let index = (start + offset) mod List.length items in
+ let item = List.nth items index in
+ let label =
+ String.lowercase_ascii
+ (String.trim
+ (W.Element.textContent
+ (Lui_web_nodes.dom_node renderer item)))
+ in
+ if String.starts_with ~prefix:query label then begin
+ W.KeyboardEvent.preventDefault event;
+ focus_tree_item renderer tree items item
+ end
+ else loop (offset + 1)
+ end
+ in
+ loop 1
+ end
+
+let attach_tree_events renderer tree tree_node =
+ let typeahead_buffer = ref "" in
+ let typeahead_timer = ref None in
+ let key_handler event =
+ typeahead_key_handler renderer tree typeahead_buffer typeahead_timer
+ event
+ in
+ W.Element.addKeyDownEventListener key_handler tree_node;
+ Hashtbl.replace renderer.web_cleanups tree (fun () ->
+ cancel_typeahead typeahead_timer;
+ W.Element.removeKeyDownEventListener key_handler tree_node)
+
+let attach_tree_events_bang = attach_tree_events
+
+let document_body_focused renderer =
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ (match W.HtmlDocument.body document with
+ | Some body ->
+ W.Element.isSameNode (W.Element.asNode body) focused
+ | None -> false)
+ | None -> false
+
+let restore_focus renderer focused =
+ match focused with
+ | Some element ->
+ Util.focus_element element;
+ ignore
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ if document_body_focused renderer then
+ Util.focus_element element)
+ 0)
+ | None -> ()
+
+let restore_focus_bang = restore_focus
+
+let horizontal_group_child group_kind child_kind =
+ match group_kind with
+ | Tabs -> child_kind = Button
+ | ButtonGroup | ToggleGroup ->
+ child_kind = Button || child_kind = ToggleButton
+ | Breadcrumb | Pagination -> child_kind = Button
+ | _ -> false
+
+let horizontal_group_child_ = horizontal_group_child
+
+let horizontal_all_focus_children renderer node kind =
+ List.filter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some current ->
+ (match Store.standard_kind current with
+ | Some child_kind -> horizontal_group_child kind child_kind
+ | None -> false)
+ | None -> false)
+ (Store.children renderer.web_store node)
+
+let horizontal_focus_children renderer node kind =
+ List.filter
+ (fun child -> Store.enabled_node renderer child)
+ (horizontal_all_focus_children renderer node kind)
+
+let rec horizontal_tab_stop_index renderer children index =
+ if index >= List.length children then None
+ else if
+ W.Element.getAttribute "tabindex"
+ (Lui_web_nodes.dom_node renderer (List.nth children index))
+ = Some "0"
+ then Some index
+ else horizontal_tab_stop_index renderer children (index + 1)
+
+let horizontal_focus_index key current length =
+ if length = 0 then None
+ else
+ match key with
+ | "Home" -> Some 0
+ | "End" -> Some (length - 1)
+ | "ArrowRight" ->
+ (match current with
+ | Some index -> Some ((index + 1) mod length)
+ | None -> Some 0)
+ | "ArrowLeft" ->
+ (match current with
+ | Some index -> Some ((index + length - 1) mod length)
+ | None -> Some 0)
+ | _ -> None
+
+let element_direction renderer element =
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ match W.HtmlDocument.defaultView document with
+ | Some window ->
+ W.CssStyleDeclaration.direction
+ (W.Window.getComputedStyle element window)
+ | None -> "ltr"
+
+let refresh_horizontal_group_roving renderer node kind =
+ let all_children = horizontal_all_focus_children renderer node kind in
+ let children = horizontal_focus_children renderer node kind in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let focused_index =
+ match W.HtmlDocument.activeElement document with
+ | Some focused -> focused_child_index renderer children focused 0
+ | None -> None
+ in
+ let target =
+ match focused_index with
+ | Some index -> index
+ | None ->
+ (match horizontal_tab_stop_index renderer children 0 with
+ | Some index -> index
+ | None -> 0)
+ in
+ List.iter
+ (fun child ->
+ W.Element.setAttribute "tabindex" "-1"
+ (Lui_web_nodes.dom_node renderer child))
+ all_children;
+ (match children with
+ | [] -> ()
+ | _ ->
+ W.Element.setAttribute "tabindex" "0"
+ (Lui_web_nodes.dom_node renderer (List.nth children target)));
+ true
+
+let refresh_horizontal_group_roving_bang = refresh_horizontal_group_roving
+
+let horizontal_focus_kind kind =
+ kind = Tabs || kind = ButtonGroup || kind = ToggleGroup
+ || kind = Breadcrumb || kind = Pagination
+
+let update_all_horizontal_group_roving renderer =
+ Hashtbl.iter
+ (fun node current ->
+ match Store.standard_kind current with
+ | Some kind ->
+ if horizontal_focus_kind kind then
+ ignore (refresh_horizontal_group_roving renderer node kind)
+ | None -> ())
+ (Store.nodes renderer.web_store);
+ true
+
+let update_all_horizontal_group_roving_bang =
+ update_all_horizontal_group_roving
+
+let horizontal_navigation_key key orientation direction =
+ let forward_key =
+ if orientation = "vertical" then "ArrowDown"
+ else if direction = "rtl" then "ArrowLeft"
+ else "ArrowRight"
+ in
+ let backward_key =
+ if orientation = "vertical" then "ArrowUp"
+ else if direction = "rtl" then "ArrowRight"
+ else "ArrowLeft"
+ in
+ ( forward_key
+ , backward_key
+ , if key = forward_key then "ArrowRight"
+ else if key = backward_key then "ArrowLeft"
+ else if key = "Home" then "Home"
+ else if key = "End" then "End"
+ else "" )
+
+let attach_horizontal_focus renderer node kind group_node =
+ W.Element.addFocusInEventListener
+ (fun (_event : Dom.focusEvent) ->
+ ignore (refresh_horizontal_group_roving renderer node kind))
+ group_node;
+ W.Element.addKeyDownEventListener
+ (fun (event : Dom.keyboardEvent) ->
+ if
+ not
+ (Store.node_has_ancestor_kind renderer.web_store node Toolbar)
+ then begin
+ let key = W.KeyboardEvent.key event in
+ let orientation =
+ if kind = Tabs then
+ match
+ Store.property renderer.web_store node OrientationValue
+ with
+ | Some (StringValue value) -> value
+ | _ -> "horizontal"
+ else "horizontal"
+ in
+ let direction = element_direction renderer group_node in
+ let _forward_key, _backward_key, navigation_key =
+ horizontal_navigation_key key orientation direction
+ in
+ let children = horizontal_focus_children renderer node kind in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let current =
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ focused_child_index renderer children focused 0
+ | None -> None
+ in
+ match
+ horizontal_focus_index navigation_key current
+ (List.length children)
+ with
+ | Some index ->
+ W.KeyboardEvent.preventDefault event;
+ W.HtmlElement.focus
+ (W.Element.unsafeAsHtmlElement
+ (Lui_web_nodes.dom_node renderer
+ (List.nth children index)))
+ | None -> ()
+ end)
+ group_node
+
+let attach_horizontal_focus_bang = attach_horizontal_focus
+
+let toolbar_item_kind kind =
+ kind = Button || kind = ToggleButton || kind = Toggle
+ || kind = Checkbox || kind = SwitchControl || kind = Radio
+ || kind = Select || kind = Combobox || kind = TextField
+ || kind = SecureField || kind = Input || kind = SearchField
+
+let toolbar_item_kind_ = toolbar_item_kind
+
+let toolbar_all_items_under renderer parent =
+ let rec collect items child =
+ match Store.node renderer.web_store child with
+ | Some current ->
+ if toolbar_item_kind (standard_kind_strict current) then
+ child :: items
+ else
+ List.fold_left collect items
+ (Store.children renderer.web_store child)
+ | None -> items
+ in
+ List.rev
+ (List.fold_left collect []
+ (Store.children renderer.web_store parent))
+
+let toolbar_items_under renderer parent =
+ toolbar_all_items_under renderer parent
+
+let toolbar_focus_node store node =
+ match Store.node store node with
+ | Some current ->
+ let kind = standard_kind_strict current in
+ if Store.direct_toggle kind || kind = Combobox then
+ Util.child_element current.platform_node 0
+ else current.platform_node
+ | None -> invalid_arg "unknown toolbar item"
+
+let apply_toolbar_disabled_semantics renderer item =
+ (match Store.node renderer.web_store item with
+ | Some current ->
+ let kind = standard_kind_strict current in
+ let platform_node = Lui_web_nodes.dom_node renderer item in
+ let focus_node =
+ if Store.direct_toggle kind || kind = Combobox then
+ Util.child_element platform_node 0
+ else platform_node
+ in
+ if Store.enabled_node renderer item then begin
+ W.Element.removeAttribute "aria-disabled" focus_node;
+ W.Element.removeAttribute "data-disabled" focus_node
+ end
+ else begin
+ W.Element.removeAttribute "disabled" focus_node;
+ W.Element.setAttribute "aria-disabled" "true" focus_node;
+ W.Element.setAttribute "data-disabled" "" focus_node
+ end
+ | None -> ());
+ true
+
+let apply_toolbar_disabled_semantics_bang =
+ apply_toolbar_disabled_semantics
+
+let toolbar_text_input_kind kind =
+ kind = TextField || kind = SecureField || kind = Input
+ || kind = SearchField || kind = Combobox
+
+let rec focused_toolbar_item_index store items focused index =
+ if index >= List.length items then None
+ else if
+ W.Element.isSameNode
+ (W.Element.asNode (toolbar_focus_node store (List.nth items index)))
+ focused
+ then Some index
+ else focused_toolbar_item_index store items focused (index + 1)
+
+let toolbar_input_owns_key store item event forward_key backward_key =
+ match Store.node store item with
+ | Some current ->
+ if toolbar_text_input_kind (standard_kind_strict current) then
+ let control = Util.text_control_node current.platform_node in
+ let start = W.HtmlInputElement.selectionStart control in
+ let finish = W.HtmlInputElement.selectionEnd control in
+ let length =
+ String.length (W.HtmlInputElement.value control)
+ in
+ let key = W.KeyboardEvent.key event in
+ W.KeyboardEvent.isComposing event
+ || W.KeyboardEvent.shiftKey event
+ || W.KeyboardEvent.ctrlKey event
+ || W.KeyboardEvent.altKey event
+ || W.KeyboardEvent.metaKey event
+ || start <> finish
+ || (key = forward_key && finish < length)
+ || (key = backward_key && start > 0)
+ || (length > 0 && (key = "Home" || key = "End"))
+ else false
+ | None -> false
+
+let select_toolbar_input store item =
+ match Store.node store item with
+ | Some current ->
+ if toolbar_text_input_kind (standard_kind_strict current) then
+ let control = Util.text_control_node current.platform_node in
+ W.HtmlInputElement.setSelectionRange 0
+ (String.length (W.HtmlInputElement.value control)) control
+ | None -> ()
+
+let refresh_toolbar_roving renderer toolbar =
+ let all_items = toolbar_all_items_under renderer toolbar in
+ let items = toolbar_items_under renderer toolbar in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let active =
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ focused_toolbar_item_index renderer.web_store items focused 0
+ | None -> None
+ in
+ let target = match active with Some index -> index | None -> 0 in
+ List.iter
+ (fun item ->
+ ignore (apply_toolbar_disabled_semantics renderer item);
+ W.Element.setAttribute "tabindex" "-1"
+ (toolbar_focus_node renderer.web_store item))
+ all_items;
+ List.iteri
+ (fun index item ->
+ W.Element.setAttribute "tabindex"
+ (if index = target then "0" else "-1")
+ (toolbar_focus_node renderer.web_store item))
+ items;
+ true
+
+let refresh_toolbar_roving_bang = refresh_toolbar_roving
+
+let update_all_toolbar_roving renderer =
+ Hashtbl.iter
+ (fun node current ->
+ if Store.standard_kind_is current Toolbar then
+ ignore (refresh_toolbar_roving renderer node))
+ (Store.nodes renderer.web_store);
+ true
+
+let update_all_toolbar_roving_bang = update_all_toolbar_roving
+
+let attach_toolbar_events renderer node toolbar_node =
+ W.Element.addFocusInEventListener
+ (fun (_event : Dom.focusEvent) ->
+ let items = toolbar_items_under renderer node in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ (match
+ focused_toolbar_item_index renderer.web_store items
+ focused 0
+ with
+ | Some index ->
+ ignore (refresh_toolbar_roving renderer node);
+ select_toolbar_input renderer.web_store
+ (List.nth items index)
+ | None -> ())
+ | None -> ())
+ toolbar_node;
+ W.Element.addKeyDownEventListener
+ (fun (event : Dom.keyboardEvent) ->
+ let key = W.KeyboardEvent.key event in
+ let orientation =
+ match Store.property renderer.web_store node OrientationValue with
+ | Some (StringValue value) -> value
+ | _ -> "horizontal"
+ in
+ let direction = element_direction renderer toolbar_node in
+ let forward_key, backward_key, navigation_key =
+ horizontal_navigation_key key orientation direction
+ in
+ let items = toolbar_items_under renderer node in
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ let current =
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ focused_toolbar_item_index renderer.web_store items
+ focused 0
+ | None -> None
+ in
+ if
+ navigation_key <> ""
+ && not
+ (match current with
+ | Some index ->
+ toolbar_input_owns_key renderer.web_store
+ (List.nth items index) event forward_key backward_key
+ | None -> false)
+ then
+ match
+ horizontal_focus_index navigation_key current
+ (List.length items)
+ with
+ | Some index ->
+ W.KeyboardEvent.preventDefault event;
+ W.HtmlElement.focus
+ (W.Element.unsafeAsHtmlElement
+ (toolbar_focus_node renderer.web_store
+ (List.nth items index)))
+ | None -> ())
+ toolbar_node
+
+let attach_toolbar_events_bang = attach_toolbar_events
+
+let direct_tab_trigger renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ Store.standard_kind_is current Button
+ &&
+ (match current.retained_parent with
+ | Some parent ->
+ (match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ Store.standard_kind_is parent_node Tabs
+ | None -> false)
+ | None -> false)
+ | None -> false
+
+let direct_tab_trigger_ = direct_tab_trigger
+
+let refresh_tabs_roving store document tabs =
+ let all_children =
+ List.filter
+ (fun child ->
+ match Store.node store child with
+ | Some current -> Store.standard_kind_is current Button
+ | None -> false)
+ (Store.children store tabs)
+ in
+ let children =
+ List.filter
+ (fun child ->
+ Store.property store child Enabled <> Some (BoolValue false))
+ all_children
+ in
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ let active =
+ match W.HtmlDocument.activeElement html_document with
+ | Some focused ->
+ let rec loop index =
+ if index >= List.length children then None
+ else
+ match Store.node store (List.nth children index) with
+ | Some current ->
+ if
+ W.Element.isSameNode
+ (W.Element.asNode current.platform_node) focused
+ then Some index
+ else loop (index + 1)
+ | None -> loop (index + 1)
+ in
+ loop 0
+ | None -> None
+ in
+ let selected =
+ let rec loop index =
+ if index >= List.length children then 0
+ else if
+ Store.property store (List.nth children index) Selected
+ = Some (BoolValue true)
+ then index
+ else loop (index + 1)
+ in
+ loop 0
+ in
+ let target =
+ match active with Some index -> index | None -> selected
+ in
+ List.iter
+ (fun child ->
+ match Store.node store child with
+ | Some current ->
+ W.Element.setAttribute "tabindex" "-1" current.platform_node
+ | None -> ())
+ all_children;
+ List.iteri
+ (fun index child ->
+ match Store.node store child with
+ | Some current ->
+ W.Element.setAttribute "tabindex"
+ (if index = target then "0" else "-1")
+ current.platform_node
+ | None -> ())
+ children
+
+let refresh_tabs_roving_bang = refresh_tabs_roving
+
+let refresh_button_context renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ if Store.standard_kind_is current Button then begin
+ let element = current.platform_node in
+ let selected = Store.selected_property renderer node in
+ if direct_tab_trigger renderer node then begin
+ W.Element.setAttribute "role" "tab" element;
+ W.Element.setAttribute "aria-selected"
+ (if selected then "true" else "false") element;
+ W.Element.removeAttribute "aria-pressed" element;
+ match current.retained_parent with
+ | Some parent ->
+ refresh_tabs_roving renderer.web_store
+ renderer.web_document parent
+ | None -> ()
+ end
+ else begin
+ W.Element.removeAttribute "role" element;
+ W.Element.removeAttribute "aria-selected" element;
+ match Store.property renderer.web_store node Selected with
+ | Some (BoolValue _) ->
+ W.Element.setAttribute "aria-pressed"
+ (if selected then "true" else "false") element
+ | _ -> W.Element.removeAttribute "aria-pressed" element
+ end
+ end
+ | None -> ()
+
+let refresh_button_context_bang = refresh_button_context
+
+let rec radio_group_ancestor renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if Store.standard_kind_is parent_node RadioGroup then
+ Some parent
+ else radio_group_ancestor renderer parent
+ | None -> None)
+ | None -> None)
+ | None -> None
+
+let update_radio_group renderer node =
+ match radio_group_ancestor renderer node with
+ | Some group ->
+ W.Element.setAttribute "name"
+ ("lui-radio-group-" ^ string_of_int group)
+ (Util.child_element (Lui_web_nodes.dom_node renderer node) 0)
+ | None -> ()
+
+let update_radio_group_bang = update_radio_group
diff --git a/platform/web/melange/nodes/lui_web_nodes.ml b/platform/web/melange/nodes/lui_web_nodes.ml
new file mode 100644
index 00000000..a071c9b0
--- /dev/null
+++ b/platform/web/melange/nodes/lui_web_nodes.ml
@@ -0,0 +1,482 @@
+(* Element factories and DOM lookups for the LUI web (DOM) backend.
+ Ported from web.cljc: base-class table, create_* factories, platform_node,
+ dom_node lookups, and the dropdown anchor helpers. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+
+let base_class_name kind =
+ match kind with
+ | Root -> "lui-root"
+ | Row -> "lui-row"
+ | Column -> "lui-column"
+ | Grid -> "lui-grid"
+ | Stack -> "lui-stack"
+ | Panel -> "lui-panel"
+ | Card -> "lui-card"
+ | Alert -> "lui-alert"
+ | Bubble -> "lui-bubble"
+ | Box -> "lui-box"
+ | Text -> "lui-text"
+ | Heading -> "lui-heading"
+ | Paragraph -> "lui-paragraph"
+ | Label -> "lui-label"
+ | Button -> "lui-button"
+ | ToggleButton -> "lui-button lui-toggle-button"
+ | Toggle -> "lui-toggle"
+ | RadioGroup -> "lui-radio-group"
+ | Radio -> "lui-radio"
+ | Slider -> "lui-slider"
+ | TextField -> "lui-text-field"
+ | SecureField -> "lui-text-field"
+ | Input -> "lui-input"
+ | SearchField -> "lui-search-field"
+ | Textarea -> "lui-textarea"
+ | Checkbox -> "lui-checkbox"
+ | SwitchControl -> "lui-switch"
+ | Progress -> "lui-progress"
+ | Divider -> "lui-separator"
+ | Scroll -> "lui-scroll"
+ | ListContainer -> "lui-list"
+ | VirtualList -> "lui-virtual-list"
+ | Tabs -> "lui-tabs"
+ | BottomTabs -> "lui-bottom-tabs"
+ | BottomTab -> "lui-bottom-tab"
+ | ButtonGroup -> "lui-button-group"
+ | ToggleGroup -> "lui-toggle-group"
+ | Breadcrumb -> "lui-breadcrumb"
+ | Pagination -> "lui-pagination"
+ | Spacer -> "lui-spacer"
+ | Spinner -> "lui-spinner"
+ | Icon -> "lui-icon"
+ | Select -> "lui-select"
+ | Combobox -> "lui-combobox"
+ | DropdownMenu -> "lui-dropdown-menu"
+ | ContextMenu -> "lui-context-menu"
+ | MenuItem -> "lui-menu-item"
+ (* MenuTrigger has no counterpart in the original backend (the kind was added
+ later); it renders as a menu-item row, matching the
+ .lui-menu-item[data-submenu-trigger] styling in lui.css. *)
+ | MenuTrigger -> "lui-menu-item"
+ | ListItem -> "lui-list-item"
+ | Avatar -> "lui-avatar"
+ | Image -> "lui-image"
+ | MediaSurface -> "lui-media-surface"
+ | Stepper -> "lui-stepper"
+ | Step -> "lui-step"
+ | Timeline -> "lui-timeline"
+ | TimelineItem -> "lui-timeline-item"
+ | InputGroup -> "lui-input-group"
+ | InputGroupActions -> "lui-input-group-actions"
+ | Dialog -> "lui-dialog"
+ | Sheet -> "lui-sheet"
+ | Tooltip -> "lui-tooltip"
+ | Toast -> "lui-toast"
+ | Toolbar -> "lui-toolbar"
+ | Accordion -> "lui-accordion"
+ | Table -> "lui-table"
+ | TableRow -> "lui-table-row"
+ | TableCell -> "lui-table-cell"
+ | Tree -> "lui-tree"
+ | Resizable -> "lui-resizable"
+ | Split -> "lui-split"
+ | Drawer -> "lui-drawer"
+ | StatusBar -> "lui-status-bar"
+
+let create_split_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-split" []
+ [ Util.element document "div" "lui-split-panes" [] [];
+ Util.element document "div" "lui-split-divider"
+ [ ("role", "separator");
+ ("aria-orientation", "vertical");
+ ("aria-valuemin", "0");
+ ("aria-valuemax", "1");
+ ("aria-valuenow", "0.5");
+ ("tabindex", "0") ]
+ [] ]
+
+let create_direct_toggle_node renderer kind =
+ let document = renderer.web_document in
+ let control_class =
+ match kind with
+ | Radio -> "lui-radio-control"
+ | Checkbox -> "lui-checkbox-control"
+ | _ -> "lui-switch-control"
+ in
+ let control_attributes =
+ if kind = SwitchControl then
+ [ ("type", "checkbox"); ("role", "switch") ]
+ else [ ("type", if kind = Radio then "radio" else "checkbox") ]
+ in
+ Util.element document "label" (base_class_name kind) []
+ [ Util.element document "input" control_class control_attributes [];
+ Util.element document "span" "lui-control-label" [] [] ]
+
+let create_button_node renderer kind =
+ let document = renderer.web_document in
+ let attributes =
+ [ ("data-variant", "default");
+ ("data-size", "default");
+ ("data-icon-placement", "leading");
+ ("type", "button") ]
+ in
+ let attributes =
+ if kind = ToggleButton || kind = Toggle then
+ attributes @ [ ("aria-pressed", "false") ]
+ else attributes
+ in
+ Util.element document "button" (base_class_name kind) attributes
+ [ Util.element document "span" "lui-button-icon lui-icon"
+ [ ("aria-hidden", "true") ] [];
+ Util.element document "span" "lui-button-label" [] [] ]
+
+let create_combobox_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-combobox" []
+ [ Util.element document "input" "lui-combobox-control"
+ [ ("role", "combobox");
+ ("aria-haspopup", "listbox");
+ ("aria-expanded", "false") ]
+ [];
+ Util.element document "button" "lui-combobox-trigger"
+ [ ("type", "button"); ("aria-label", "Open menu") ]
+ [] ]
+
+let create_select_node renderer =
+ let document = renderer.web_document in
+ Util.element document "button" "lui-select"
+ [ ("type", "button");
+ ("role", "combobox");
+ ("aria-haspopup", "listbox");
+ ("aria-expanded", "false") ]
+ [ Util.element document "span" "lui-select-value" [] [] ]
+
+let create_menu_item_node renderer =
+ let document = renderer.web_document in
+ let hidden = [ ("aria-hidden", "true") ] in
+ Util.element document "button" "lui-menu-item"
+ [ ("type", "button"); ("role", "option"); ("aria-selected", "false") ]
+ [ Util.element document "span" "lui-menu-item-icon lui-icon" hidden [];
+ Util.element document "span" "lui-menu-item-label" [] [];
+ Util.element document "span" "lui-menu-item-check lui-icon"
+ [ ("aria-hidden", "true"); ("data-name", "check") ]
+ [] ]
+
+let create_dropdown_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-popup-positioner"
+ [ ("data-anchor", "below"); ("data-anchor-alignment", "start") ]
+ [ Util.element document "div" "lui-dropdown-menu"
+ [ ("role", "listbox"); ("tabindex", "-1") ]
+ [] ]
+
+let create_avatar_node renderer =
+ let document = renderer.web_document in
+ Util.element document "span" "lui-avatar" []
+ [ Util.element document "img" "lui-avatar-image"
+ [ ("alt", "");
+ ("aria-hidden", "true");
+ ("draggable", "false");
+ ("hidden", "") ]
+ [];
+ Util.element document "span" "lui-avatar-initials" [] [] ]
+
+let create_media_node renderer kind =
+ let class_name = base_class_name kind in
+ let pixels_class =
+ if kind = Image then "lui-image-pixels" else "lui-media-surface-frame"
+ in
+ Util.element renderer.web_document "span" class_name []
+ [ Util.element renderer.web_document "img" pixels_class
+ [ ("alt", "");
+ ("aria-hidden", "true");
+ ("draggable", "false");
+ ("hidden", "") ]
+ [] ]
+
+let create_step_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-step" [ ("role", "listitem") ]
+ [ Util.element document "span" "lui-step-indicator"
+ [ ("aria-hidden", "true") ] [];
+ Util.element document "span" "lui-step-label" [] [];
+ Util.element document "span" "lui-step-connector"
+ [ ("aria-hidden", "true") ] [] ]
+
+let create_timeline_item_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-timeline-item"
+ [ ("role", "listitem"); ("data-variant", "outline") ]
+ [ Util.element document "div" "lui-timeline-item-lead"
+ [ ("aria-hidden", "true") ]
+ [ Util.element document "span" "lui-timeline-item-indicator" [] [];
+ Util.element document "span" "lui-timeline-item-connector" [] [] ];
+ Util.element document "div" "lui-timeline-item-content" []
+ [ Util.element document "div" "lui-timeline-item-title" [] [];
+ Util.element document "div" "lui-timeline-item-description"
+ [ ("hidden", "") ] [];
+ Util.element document "div" "lui-timeline-item-meta"
+ [ ("hidden", "") ] [] ];
+ Util.element document "span" "lui-timeline-item-chevron lui-icon"
+ [ ("aria-hidden", "true");
+ ("data-name", "chevron-right");
+ ("hidden", "") ]
+ [] ]
+
+let create_accordion_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-accordion" [ ("data-closed", "") ]
+ [ Util.element document "button" "lui-accordion-summary"
+ [ ("type", "button"); ("aria-expanded", "false") ]
+ [ Util.element document "span" "lui-accordion-label" [] [];
+ Util.element document "span" "lui-accordion-chevron lui-icon"
+ [ ("aria-hidden", "true"); ("data-name", "chevron-down") ]
+ [] ];
+ Util.element document "div" "lui-accordion-content"
+ [ ("role", "region"); ("data-closed", ""); ("hidden", "") ]
+ [] ]
+
+let simple_node_tag kind =
+ match kind with
+ | Heading -> "div"
+ | Paragraph -> "p"
+ | Label -> "label"
+ | Text -> "span"
+ | TextField | SecureField | Input -> "input"
+ | SearchField -> "input"
+ | Textarea -> "textarea"
+ | Select | ListItem -> "button"
+ | Table -> "table"
+ | TableRow -> "tr"
+ | TableCell -> "td"
+ | Stepper | Timeline | InputGroup | InputGroupActions | Tree | Toast
+ | Toolbar -> "div"
+ | Slider -> "input"
+ | Divider -> "hr"
+ | Tooltip -> "span"
+ | _ -> "div"
+
+let simple_node_attributes kind =
+ match kind with
+ | Heading -> [ ("role", "heading") ]
+ | SearchField -> [ ("type", "search") ]
+ | SecureField -> [ ("type", "password") ]
+ | Textarea ->
+ [ ("style", "field-sizing: content; resize: vertical; overflow-y: auto") ]
+ | Progress ->
+ [ ("role", "progressbar");
+ ("aria-valuemin", "0");
+ ("aria-valuemax", "1") ]
+ | RadioGroup -> [ ("role", "radiogroup") ]
+ | Tabs -> [ ("role", "tablist"); ("aria-orientation", "horizontal") ]
+ | BottomTab -> [ ("role", "tabpanel") ]
+ | ButtonGroup | ToggleGroup | Breadcrumb | Pagination ->
+ [ ("role", "group") ]
+ | Slider ->
+ [ ("type", "range"); ("min", "0"); ("max", "1"); ("step", "any") ]
+ | Spinner -> [ ("role", "progressbar") ]
+ | Divider -> [ ("role", "separator") ]
+ | Select ->
+ [ ("type", "button");
+ ("role", "combobox");
+ ("aria-haspopup", "listbox");
+ ("aria-expanded", "false") ]
+ | ListItem -> [ ("type", "button"); ("aria-pressed", "false") ]
+ | Table -> [ ("role", "grid") ]
+ | TableRow -> [ ("role", "row"); ("aria-selected", "false") ]
+ | TableCell -> [ ("role", "gridcell") ]
+ | Tree -> [ ("role", "tree") ]
+ | Stepper | Timeline -> [ ("role", "list") ]
+ | InputGroup -> [ ("role", "group") ]
+ | DropdownMenu ->
+ [ ("role", "listbox");
+ ("data-anchor", "below");
+ ("data-anchor-alignment", "start") ]
+ | ContextMenu -> [ ("role", "menu"); ("tabindex", "-1") ]
+ | Tooltip -> [ ("role", "tooltip") ]
+ | Toast ->
+ [ ("role", "status");
+ ("aria-atomic", "true");
+ ("tabindex", "0");
+ ("data-state", "open") ]
+ | Toolbar -> [ ("role", "toolbar"); ("aria-orientation", "horizontal") ]
+ | StatusBar -> [ ("role", "status") ]
+ | _ -> []
+
+let create_simple_node renderer kind =
+ Util.element renderer.web_document (simple_node_tag kind)
+ (base_class_name kind) (simple_node_attributes kind) []
+
+let create_bottom_tabs_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-bottom-tabs" []
+ [ Util.element document "div" "lui-bottom-tabs-pages" [] [];
+ Util.element document "div" "lui-bottom-tabs-bar"
+ [ ("role", "tablist"); ("aria-orientation", "horizontal") ]
+ [] ]
+
+let create_modal_node renderer kind =
+ let document = renderer.web_document in
+ let class_name = base_class_name kind in
+ let layer =
+ Util.element document "div" "lui-modal-layer"
+ [ ("data-lui-modal-state", "closed"); ("hidden", "") ] []
+ in
+ let backdrop =
+ Util.element document "div" "lui-modal-backdrop"
+ [ ("aria-hidden", "true") ] []
+ in
+ let surface =
+ Util.element document "section" class_name
+ [ ("role", "dialog"); ("aria-modal", "true"); ("tabindex", "-1") ]
+ [ Util.element document "div" (class_name ^ "-title") []
+ [ Util.element document "div" (class_name ^ "-heading") [] [];
+ Util.element document "div" "lui-modal-description"
+ [ ("hidden", "") ] [] ];
+ Util.element document "div" (class_name ^ "-body") [] [];
+ (if kind = Sheet then
+ Util.element document "div" "lui-sheet-handle"
+ [ ("aria-hidden", "true") ] []
+ else
+ Util.element document "span" "lui-modal-decoration"
+ [ ("hidden", "") ] []) ]
+ in
+ W.Element.appendChild (W.Element.asNode backdrop) layer;
+ W.Element.appendChild (W.Element.asNode surface) layer;
+ surface
+
+let create_alert_node renderer =
+ let document = renderer.web_document in
+ Util.element document "section" "lui-alert"
+ [ ("role", "alert"); ("data-variant", "default") ]
+ [ Util.element document "div" "lui-alert-title" [] [];
+ Util.element document "div" "lui-alert-content" [] [] ]
+
+let create_bubble_node renderer =
+ let document = renderer.web_document in
+ Util.element document "div" "lui-bubble"
+ [ ("data-variant", "default"); ("data-reactions-alignment", "end") ]
+ [ Util.element document "div" "lui-bubble-content" [] [];
+ Util.element document "span" "lui-bubble-reactions" [] [] ]
+
+let platform_node renderer kind =
+ match kind with
+ | Button | ToggleButton | Toggle -> create_button_node renderer kind
+ | Checkbox | SwitchControl | Radio -> create_direct_toggle_node renderer kind
+ | Select -> create_select_node renderer
+ | Combobox -> create_combobox_node renderer
+ | DropdownMenu -> create_dropdown_node renderer
+ | MenuItem | MenuTrigger -> create_menu_item_node renderer
+ | Avatar -> create_avatar_node renderer
+ | Image | MediaSurface -> create_media_node renderer kind
+ | Step -> create_step_node renderer
+ | TimelineItem -> create_timeline_item_node renderer
+ | BottomTabs -> create_bottom_tabs_node renderer
+ | Accordion -> create_accordion_node renderer
+ | Alert -> create_alert_node renderer
+ | Bubble -> create_bubble_node renderer
+ | Dialog | Sheet -> create_modal_node renderer kind
+ | Split -> create_split_node renderer
+ | _ -> create_simple_node renderer kind
+
+let dom_node renderer node =
+ match Store.node renderer.web_store node with
+ | Some current -> current.platform_node
+ | None -> invalid_arg "unknown DOM node"
+
+let dom_node_before renderer previous_nodes node =
+ match Store.node renderer.web_store node with
+ | Some current -> current.platform_node
+ | None ->
+ (match Hashtbl.find_opt previous_nodes node with
+ | Some previous -> previous.platform_node
+ | None -> invalid_arg "unknown DOM node")
+
+let retained_content_container current dom_node =
+ match Store.standard_kind current with
+ | Some kind -> Util.content_container kind dom_node
+ | None -> dom_node
+
+let dom_child_container renderer node dom_node =
+ match Store.node renderer.web_store node with
+ | Some current -> retained_content_container current dom_node
+ | None -> dom_node
+
+let dom_child_container_before renderer previous_nodes node dom_node =
+ match Store.node renderer.web_store node with
+ | Some current -> retained_content_container current dom_node
+ | None ->
+ (match Hashtbl.find_opt previous_nodes node with
+ | Some previous -> retained_content_container previous dom_node
+ | None -> dom_node)
+
+let picker_under_parent renderer parent =
+ let children = Store.children renderer.web_store parent in
+ let count = List.length children in
+ let rec loop index =
+ if index = count then None
+ else
+ let child = List.nth children index in
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ if
+ Store.standard_kind_is child_node Select
+ || Store.standard_kind_is child_node Combobox
+ then Some child
+ else loop (index + 1)
+ | None -> loop (index + 1)
+ in
+ loop 0
+
+let picker_for_dropdown renderer dropdown =
+ match Store.node renderer.web_store dropdown with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent -> picker_under_parent renderer parent
+ | None -> None)
+ | None -> None
+
+let dropdown_anchor_node renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if Store.menu_item_row parent_node then
+ parent_node.platform_node
+ else
+ let container =
+ retained_content_container
+ parent_node parent_node.platform_node
+ in
+ let children = W.Element.children container in
+ let length = W.HtmlCollection.length children in
+ if length > 0 then
+ (match W.HtmlCollection.item (length - 1) children with
+ | Some anchor -> anchor
+ | None -> container)
+ else container
+ | None -> invalid_arg "dropdown parent is unavailable")
+ | None -> invalid_arg "dropdown requires an anchor parent")
+ | None -> invalid_arg "unknown dropdown node"
+
+let dropdown_side dom_node =
+ match W.Element.getAttribute "data-anchor" dom_node with
+ | Some value -> value
+ | None -> "below"
+
+let dropdown_offset renderer node =
+ match Store.property renderer.web_store node AnchorOffset with
+ | Some (FloatValue value) -> value
+ | _ -> 0.0
+
+let dropdown_listbox renderer node =
+ picker_for_dropdown renderer node <> None
+
+let dropdown_listbox_ = dropdown_listbox
diff --git a/platform/web/melange/popup/lui_web_menu.ml b/platform/web/melange/popup/lui_web_menu.ml
new file mode 100644
index 00000000..97c1319b
--- /dev/null
+++ b/platform/web/melange/popup/lui_web_menu.ml
@@ -0,0 +1,1059 @@
+(* Menus for the web backend: picker/combobox plumbing, dropdown wiring,
+ and context-menu behaviour. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+
+(* Popup transition helpers. These belong to the popup-transition vocabulary
+ owned by Lui_web_position, but that module is still a stub, so the port
+ keeps local copies here; switch to the shared versions when they exist. *)
+external media_query_list_matches : W.Window.mediaQueryList -> bool = "matches"
+ [@@mel.get]
+
+let emit renderer event = ignore (!(renderer.web_event_handler) event)
+
+let transition_event_from target event =
+ W.Element.isSameNode
+ (W.Element.asNode
+ (Lui_web_util.event_target_to_element (W.Event.target event)))
+ target
+
+let prefers_reduced_motion document =
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ match W.HtmlDocument.defaultView html_document with
+ | Some window ->
+ media_query_list_matches
+ (W.Window.matchMedia "(prefers-reduced-motion: reduce)" window)
+ | None -> false
+
+let after_transition document target fallback_duration finish_on_cancel
+ complete =
+ if prefers_reduced_motion document then complete ()
+ else begin
+ let finished = ref false in
+ let timer = ref None in
+ let finish_ref = ref (fun () -> ()) in
+ let transition_handler event =
+ if transition_event_from target event then !finish_ref ()
+ in
+ let finish () =
+ if not !finished then begin
+ finished := true;
+ (match !timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ W.Element.removeEventListener "transitionend" transition_handler
+ target;
+ if finish_on_cancel then
+ W.Element.removeEventListener "transitioncancel" transition_handler
+ target;
+ complete ()
+ end
+ in
+ finish_ref := finish;
+ W.Element.addEventListener "transitionend" transition_handler target;
+ if finish_on_cancel then
+ W.Element.addEventListener "transitioncancel" transition_handler target;
+ timer := Some (Js.Global.setTimeout ~f:finish fallback_duration)
+ end
+
+let begin_popup_open popup =
+ W.Element.removeAttribute "data-closed" popup;
+ W.Element.removeAttribute "data-ending-style" popup;
+ W.Element.setAttribute "data-open" "" popup;
+ W.Element.setAttribute "data-starting-style" "" popup;
+ Webapi.requestAnimationFrame (fun _time ->
+ W.Element.removeAttribute "data-starting-style" popup)
+
+let begin_popup_close popup =
+ W.Element.removeAttribute "data-open" popup;
+ W.Element.setAttribute "data-closed" "" popup;
+ W.Element.setAttribute "data-ending-style" "" popup
+
+let finish_popup_close_after_transition document popup duration =
+ after_transition document popup duration true (fun () ->
+ if W.Element.getAttribute "data-ending-style" popup = Some "" then
+ W.Element.removeAttribute "data-ending-style" popup)
+
+let cancel_typeahead typeahead_timer =
+ (match !typeahead_timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ typeahead_timer := None
+
+let reset_typeahead_later typeahead_buffer typeahead_timer =
+ cancel_typeahead typeahead_timer;
+ typeahead_timer :=
+ Some
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ typeahead_timer := None;
+ typeahead_buffer := "")
+ 500)
+
+let starts_with ~prefix value =
+ let prefix_length = String.length prefix in
+ String.length value >= prefix_length
+ && String.sub value 0 prefix_length = prefix
+
+let dropdown_node nodes node =
+ match Hashtbl.find_opt nodes node with
+ | Some current -> Store.standard_kind_is current DropdownMenu
+ | None -> false
+
+let dropdown_node_ = dropdown_node
+
+let child_with_kind renderer children kind =
+ List.find_opt
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node -> Store.standard_kind_is child_node kind
+ | None -> false)
+ children
+
+(* --- picker / combobox plumbing --- *)
+
+let picker_dropdown renderer picker =
+ match Store.node renderer.web_store picker with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ child_with_kind renderer
+ (Store.children renderer.web_store parent)
+ DropdownMenu
+ | None -> None)
+ | None -> None
+
+let picker_under_parent renderer parent =
+ List.find_opt
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.standard_kind_is child_node Select
+ || Store.standard_kind_is child_node Combobox
+ | None -> false)
+ (Store.children renderer.web_store parent)
+
+let picker_for_dropdown renderer dropdown =
+ match Store.node renderer.web_store dropdown with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent -> picker_under_parent renderer parent
+ | None -> None)
+ | None -> None
+
+let picker_control_element renderer picker =
+ let picker_element = Lui_web_nodes.dom_node renderer picker in
+ match Store.node renderer.web_store picker with
+ | Some current ->
+ if Store.standard_kind_is current Combobox then
+ Lui_web_util.child_element picker_element 0
+ else picker_element
+ | None -> invalid_arg "unknown picker node"
+
+let picker_menu_items renderer dropdown =
+ match Store.node renderer.web_store dropdown with
+ | Some current ->
+ List.filter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.menu_item_row child_node
+ && Store.enabled_node renderer child
+ | None -> false)
+ current.retained_children
+ | None -> []
+
+let picker_selected_index renderer dropdown =
+ let items = picker_menu_items renderer dropdown in
+ let rec loop index =
+ if index = List.length items then 0
+ else if
+ Store.property renderer.web_store (List.nth items index) Selected
+ = Some (BoolValue true)
+ then index
+ else loop (index + 1)
+ in
+ loop 0
+
+let combobox_active_index renderer picker items =
+ match
+ W.Element.getAttribute "data-lui-active-index"
+ (picker_control_element renderer picker)
+ with
+ | Some value ->
+ (match int_of_string_opt value with
+ | Some index ->
+ if index >= 0 && index < List.length items then Some index
+ else None
+ | None -> None)
+ | None -> None
+
+let set_combobox_active renderer picker dropdown index =
+ let items = picker_menu_items renderer dropdown in
+ let control = picker_control_element renderer picker in
+ List.iter
+ (fun item ->
+ W.Element.removeAttribute "data-highlighted"
+ (Lui_web_nodes.dom_node renderer item))
+ items;
+ if items <> [] && index >= 0 && index < List.length items then begin
+ let item = List.nth items index in
+ let element = Lui_web_nodes.dom_node renderer item in
+ W.Element.setAttribute "data-lui-active-index" (string_of_int index)
+ control;
+ W.Element.setAttribute "data-highlighted" "" element;
+ W.Element.setAttribute "aria-activedescendant"
+ (Lui_web_util.node_dom_id item) control
+ end
+
+let set_combobox_active_bang = set_combobox_active
+
+let clear_combobox_active renderer picker =
+ let control = picker_control_element renderer picker in
+ W.Element.removeAttribute "data-lui-active-index" control;
+ W.Element.removeAttribute "aria-activedescendant" control
+
+let ensure_combobox_status renderer dropdown =
+ let popup =
+ Lui_web_util.child_element (Lui_web_nodes.dom_node renderer dropdown) 0
+ in
+ match W.Element.querySelector ".lui-combobox-status" popup with
+ | Some status -> status
+ | None ->
+ let status =
+ Lui_web_util.element renderer.web_document "div"
+ "lui-combobox-status"
+ [ ("role", "status"); ("aria-live", "polite");
+ ("aria-atomic", "true") ]
+ []
+ in
+ W.Element.appendChild (W.Element.asNode status) popup;
+ status
+
+let refresh_dropdown_item_roles renderer dropdown =
+ let listbox = Lui_web_nodes.dropdown_listbox renderer dropdown in
+ List.iter
+ (fun item ->
+ match Store.node renderer.web_store item with
+ | Some current ->
+ if Store.menu_item_row current then
+ if listbox then begin
+ W.Element.setAttribute "role" "option" current.platform_node;
+ W.Element.setAttribute "aria-selected"
+ (if
+ Store.property renderer.web_store item Selected
+ = Some (BoolValue true)
+ then "true"
+ else "false")
+ current.platform_node
+ end
+ else begin
+ W.Element.setAttribute "role" "menuitem" current.platform_node;
+ W.Element.removeAttribute "aria-selected" current.platform_node
+ end
+ | None -> ())
+ (Store.children renderer.web_store dropdown)
+
+let combobox_status_text item_count =
+ if item_count = 1 then "1 result available."
+ else string_of_int item_count ^ " results available."
+
+let refresh_combobox_list_state renderer dropdown =
+ (match picker_for_dropdown renderer dropdown with
+ | Some picker ->
+ (match Store.node renderer.web_store picker with
+ | Some current ->
+ if Store.standard_kind_is current Combobox then begin
+ let items = picker_menu_items renderer dropdown in
+ let item_count = List.length items in
+ let empty = items = [] in
+ let root = current.platform_node in
+ let control = Lui_web_util.child_element root 0 in
+ let trigger = Lui_web_util.child_element root 1 in
+ let positioner = Lui_web_nodes.dom_node renderer dropdown in
+ let popup = Lui_web_util.child_element positioner 0 in
+ let status = ensure_combobox_status renderer dropdown in
+ Lui_web_util.set_state_attribute control "data-list-empty" empty;
+ Lui_web_util.set_state_attribute trigger "data-list-empty" empty;
+ Lui_web_util.set_state_attribute positioner "data-empty" empty;
+ Lui_web_util.set_state_attribute popup "data-empty" empty;
+ W.Element.setTextContent status
+ (if empty then "No results." else combobox_status_text item_count);
+ if empty then clear_combobox_active renderer picker
+ else begin
+ let index =
+ match combobox_active_index renderer picker items with
+ | Some current_index -> current_index
+ | None -> 0
+ in
+ let expected_id =
+ Lui_web_util.node_dom_id (List.nth items index)
+ in
+ if
+ W.Element.getAttribute "aria-activedescendant" control
+ <> Some expected_id
+ then set_combobox_active renderer picker dropdown index
+ end;
+ if W.Element.hasAttribute "data-open" popup then
+ Lui_web_position.position_dropdown renderer dropdown
+ end
+ | None -> ())
+ | None -> ())
+
+let activate_menu_item renderer item =
+ W.HtmlElement.click
+ (W.Element.unsafeAsHtmlElement (Lui_web_nodes.dom_node renderer item))
+
+let activate_menu_item_bang = activate_menu_item
+
+(* --- dropdown open/close --- *)
+
+let set_dropdown_open renderer node open_ =
+ let positioner = Lui_web_nodes.dom_node renderer node in
+ let popup = Lui_web_util.child_element positioner 0 in
+ if open_ then begin
+ begin_popup_open popup;
+ ignore (Lui_web_position.position_dropdown renderer node);
+ Webapi.requestAnimationFrame (fun _time ->
+ match Store.node renderer.web_store node with
+ | Some _current -> Lui_web_position.position_dropdown renderer node
+ | None -> ())
+ end
+ else begin
+ begin_popup_close popup;
+ finish_popup_close_after_transition renderer.web_document popup 130
+ end
+
+let set_dropdown_open_bang = set_dropdown_open
+
+(* --- context menu core --- *)
+
+let direct_context_menu renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ List.find_opt
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.standard_kind_is child_node ContextMenu
+ && List.exists
+ (fun item ->
+ match Store.node renderer.web_store item with
+ | Some item_node ->
+ Store.standard_kind_is item_node MenuItem
+ | None -> false)
+ child_node.retained_children
+ | None -> false)
+ current.retained_children
+ | None -> None
+
+let direct_dropdown_menu renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ child_with_kind renderer current.retained_children DropdownMenu
+ | None -> None
+
+let hide_context_menu renderer =
+ match !(renderer.web_open_context_menu) with
+ | Some menu ->
+ W.Element.removeAttribute "data-open"
+ (Lui_web_nodes.dom_node renderer menu);
+ renderer.web_open_context_menu := None
+ | None -> ()
+
+let context_menu_focus_items renderer menu =
+ match Store.node renderer.web_store menu with
+ | Some current ->
+ List.filter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.menu_item_row child_node
+ && Store.enabled_node renderer child
+ | None -> false)
+ current.retained_children
+ | None -> []
+
+let focus_context_menu_item renderer menu index =
+ let items = context_menu_focus_items renderer menu in
+ if items <> [] then
+ W.HtmlElement.focus
+ (W.Element.unsafeAsHtmlElement
+ (Lui_web_nodes.dom_node renderer (List.nth items index)))
+
+let focus_context_menu_item_bang = focus_context_menu_item
+
+let focus_context_menu_host renderer menu =
+ match Store.node renderer.web_store menu with
+ | Some current ->
+ (match current.retained_parent with
+ | Some host ->
+ Lui_web_util.focus_element (Lui_web_nodes.dom_node renderer host)
+ | None -> ())
+ | None -> ()
+
+let set_context_position dom_node property value =
+ W.CssStyleDeclaration.setProperty property value ""
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement dom_node))
+
+let show_context_menu renderer menu x y =
+ hide_context_menu renderer;
+ let menu_node = Lui_web_nodes.dom_node renderer menu in
+ W.Element.setAttribute "data-open" "" menu_node;
+ let width = W.Element.clientWidth menu_node in
+ let height = W.Element.clientHeight menu_node in
+ let document_root = W.Document.documentElement renderer.web_document in
+ let viewport_width = W.Element.clientWidth document_root in
+ let viewport_height = W.Element.clientHeight document_root in
+ let left = max 8 (min x (viewport_width - width - 8)) in
+ let top = max 8 (min y (viewport_height - height - 8)) in
+ set_context_position menu_node "left" (string_of_int left ^ "px");
+ set_context_position menu_node "top" (string_of_int top ^ "px");
+ renderer.web_open_context_menu := Some menu;
+ let items = context_menu_focus_items renderer menu in
+ if items = [] then
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement menu_node)
+ else focus_context_menu_item renderer menu 0
+
+(* --- picker event wiring --- *)
+
+let attach_picker_press_event renderer node dom_node =
+ W.Element.addEventListener "click"
+ (fun _event ->
+ if Store.event_capability renderer node PressEnabled then
+ emit renderer (Press node))
+ dom_node
+
+let attach_picker_press_event_bang = attach_picker_press_event
+
+let attach_picker_trigger_events renderer node dom_node =
+ let current_pointer_type = ref "mouse" in
+ let suppress_click = ref false in
+ let press () =
+ if
+ Store.enabled_node renderer node
+ && Store.event_capability renderer node PressEnabled
+ then emit renderer (Press node)
+ in
+ W.Element.addEventListener "pointerdown"
+ (fun event ->
+ let method_ = Lui_web_util.pointer_type event in
+ current_pointer_type := method_;
+ W.Element.setAttribute "data-lui-open-method" method_ dom_node)
+ dom_node;
+ W.Element.addEventListener "mousedown"
+ (fun event ->
+ if W.MouseEvent.button (Lui_web_util.pointer_mouse_event event) = 0
+ then begin
+ W.Element.setAttribute "data-lui-open-method" !current_pointer_type
+ dom_node;
+ if !current_pointer_type = "touch" then W.Event.preventDefault event;
+ suppress_click := true;
+ ignore
+ (Js.Global.setTimeout ~f:(fun () -> suppress_click := false) 0);
+ press ()
+ end)
+ dom_node;
+ W.Element.addEventListener "click"
+ (fun _event ->
+ if !suppress_click then suppress_click := false
+ else begin
+ W.Element.setAttribute "data-lui-open-method" "keyboard" dom_node;
+ press ()
+ end)
+ dom_node
+
+let attach_picker_trigger_events_bang = attach_picker_trigger_events
+
+(* --- dropdown event wiring --- *)
+
+let dropdown_group_contains_event renderer node event =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ let target =
+ Lui_web_util.event_target_to_element (W.Event.target event)
+ in
+ W.Element.contains (W.Element.asNode target) current.platform_node
+ ||
+ (match current.retained_parent with
+ | Some parent ->
+ W.Element.contains (W.Element.asNode target)
+ (Lui_web_nodes.dom_node renderer parent)
+ | None -> false)
+ | None -> false
+
+let dropdown_submenu_trigger renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some candidate ->
+ (match Store.node renderer.web_store candidate with
+ | Some candidate_node ->
+ if Store.menu_item_row candidate_node then
+ Some candidate
+ else None
+ | None -> None)
+ | None -> None)
+ | None -> None
+
+let close_submenu_to_trigger renderer node trigger =
+ let trigger_node = Lui_web_nodes.dom_node renderer trigger in
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement trigger_node);
+ set_dropdown_open renderer node false;
+ W.Element.setAttribute "aria-expanded" "false" trigger_node
+
+let dropdown_navigate renderer node items current_index key event =
+ let navigation_key =
+ if key = "ArrowDown" then "ArrowRight"
+ else if key = "ArrowUp" then "ArrowLeft"
+ else key
+ in
+ match
+ Lui_web_focus.horizontal_focus_index navigation_key current_index
+ (List.length items)
+ with
+ | Some index ->
+ W.KeyboardEvent.preventDefault event;
+ focus_context_menu_item renderer node index
+ | None -> ()
+
+let dropdown_typeahead renderer node typeahead_buffer typeahead_timer items
+ current_index key event =
+ let query = String.lowercase_ascii (!typeahead_buffer ^ key) in
+ let start = match current_index with Some index -> index | None -> -1 in
+ typeahead_buffer := query;
+ reset_typeahead_later typeahead_buffer typeahead_timer;
+ let rec loop offset =
+ if offset <= List.length items then begin
+ let index = (start + offset) mod List.length items in
+ let label =
+ String.lowercase_ascii
+ (String.trim
+ (W.Element.textContent
+ (Lui_web_nodes.dom_node renderer (List.nth items index))))
+ in
+ if starts_with ~prefix:query label then begin
+ W.KeyboardEvent.preventDefault event;
+ focus_context_menu_item renderer node index
+ end
+ else loop (offset + 1)
+ end
+ in
+ loop 1
+
+let dropdown_key_handler renderer node typeahead_buffer typeahead_timer
+ event =
+ let key = W.KeyboardEvent.key event in
+ let items = context_menu_focus_items renderer node in
+ let event_target =
+ Lui_web_util.event_target_to_element (W.KeyboardEvent.target event)
+ in
+ let current_index =
+ Lui_web_focus.focused_child_index renderer items event_target 0
+ in
+ let submenu_trigger = dropdown_submenu_trigger renderer node in
+ if current_index <> None then begin
+ if key = "ArrowDown" || key = "ArrowUp" || key = "Home" || key = "End"
+ then dropdown_navigate renderer node items current_index key event
+ else if key = "ArrowRight" then begin
+ match current_index with
+ | Some index ->
+ (match direct_dropdown_menu renderer (List.nth items index) with
+ | Some submenu ->
+ W.KeyboardEvent.preventDefault event;
+ set_dropdown_open renderer submenu true;
+ focus_context_menu_item renderer submenu 0
+ | None -> ())
+ | None -> ()
+ end
+ else if key = "ArrowLeft" && submenu_trigger <> None then begin
+ match submenu_trigger with
+ | Some trigger ->
+ W.KeyboardEvent.preventDefault event;
+ close_submenu_to_trigger renderer node trigger
+ | None -> ()
+ end
+ else if key = "Escape" then begin
+ W.KeyboardEvent.preventDefault event;
+ match submenu_trigger with
+ | Some trigger -> close_submenu_to_trigger renderer node trigger
+ | None -> emit renderer (Dismiss node)
+ end
+ else if
+ String.length key = 1
+ && not (W.KeyboardEvent.metaKey event)
+ && not (W.KeyboardEvent.ctrlKey event)
+ then
+ dropdown_typeahead renderer node typeahead_buffer typeahead_timer
+ items current_index key event
+ end
+
+let attach_dropdown_events renderer node _dropdown_node =
+ let document = renderer.web_document in
+ let window =
+ W.HtmlDocument.defaultView (W.Document.unsafeAsHtmlDocument document)
+ in
+ let typeahead_buffer = ref "" in
+ let typeahead_timer = ref None in
+ let refresh_position _event =
+ Webapi.requestAnimationFrame (fun _time ->
+ match Store.node renderer.web_store node with
+ | Some _current -> Lui_web_position.position_dropdown renderer node
+ | None -> ())
+ in
+ let pointer_handler event =
+ if not (dropdown_group_contains_event renderer node event) then
+ emit renderer (Dismiss node);
+ refresh_position event
+ in
+ let key_handler event =
+ dropdown_key_handler renderer node typeahead_buffer typeahead_timer event
+ in
+ W.Document.addEventListener "pointerdown" pointer_handler document;
+ W.Document.addEventListener "click" refresh_position document;
+ (match window with
+ | Some current_window ->
+ W.Window.addEventListener "resize" refresh_position current_window
+ | None -> ());
+ W.Document.addKeyDownEventListener key_handler document;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ cancel_typeahead typeahead_timer;
+ W.Document.removeEventListener "pointerdown" pointer_handler document;
+ W.Document.removeEventListener "click" refresh_position document;
+ (match window with
+ | Some current_window ->
+ W.Window.removeEventListener "resize" refresh_position
+ current_window
+ | None -> ());
+ W.Document.removeKeyDownEventListener key_handler document)
+
+let attach_dropdown_events_bang = attach_dropdown_events
+
+(* --- context menu host wiring --- *)
+
+type context_host_state = {
+ timer : Js.Global.timeoutId option ref;
+ suppress_click : bool ref;
+ touch_pointer : int option ref;
+ touch_origin_x : int option ref;
+ touch_origin_y : int option ref;
+}
+
+let cancel_context_touch state =
+ (match !(state.timer) with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ state.timer := None;
+ state.touch_pointer := None;
+ state.touch_origin_x := None;
+ state.touch_origin_y := None
+
+let context_host_mouse_down renderer node event =
+ if W.MouseEvent.button event = 2 then
+ match direct_context_menu renderer node with
+ | Some menu ->
+ W.MouseEvent.preventDefault event;
+ W.MouseEvent.stopImmediatePropagation event;
+ show_context_menu renderer menu
+ (W.MouseEvent.clientX event)
+ (W.MouseEvent.clientY event)
+ | None -> ()
+
+let context_host_pointer_down renderer node state event =
+ if
+ Lui_web_util.pointer_type event = "touch"
+ && W.MouseEvent.button (Lui_web_util.pointer_mouse_event event) = 0
+ then
+ match direct_context_menu renderer node with
+ | Some menu ->
+ let x =
+ W.MouseEvent.clientX (Lui_web_util.pointer_mouse_event event)
+ in
+ let y =
+ W.MouseEvent.clientY (Lui_web_util.pointer_mouse_event event)
+ in
+ cancel_context_touch state;
+ state.touch_pointer := Some (Lui_web_util.pointer_id event);
+ state.touch_origin_x := Some x;
+ state.touch_origin_y := Some y;
+ state.timer :=
+ Some
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ state.timer := None;
+ state.touch_origin_x := None;
+ state.touch_origin_y := None;
+ state.suppress_click := true;
+ show_context_menu renderer menu x y)
+ 500)
+ | None -> ()
+
+let context_host_pointer_move state event =
+ match !(state.touch_pointer) with
+ | Some active_pointer_id ->
+ if active_pointer_id = Lui_web_util.pointer_id event then
+ (match (!(state.touch_origin_x), !(state.touch_origin_y)) with
+ | Some origin_x, Some origin_y ->
+ let mouse_event = Lui_web_util.pointer_mouse_event event in
+ let delta_x = abs (W.MouseEvent.clientX mouse_event - origin_x) in
+ let delta_y = abs (W.MouseEvent.clientY mouse_event - origin_y) in
+ if delta_x > 10 || delta_y > 10 then cancel_context_touch state
+ | _ -> ())
+ | None -> ()
+
+let context_host_pointer_end state event =
+ match !(state.touch_pointer) with
+ | Some active_pointer_id ->
+ if active_pointer_id = Lui_web_util.pointer_id event then
+ cancel_context_touch state
+ | None -> ()
+
+let context_host_click state event =
+ if !(state.suppress_click) then begin
+ state.suppress_click := false;
+ W.Event.preventDefault event;
+ W.Event.stopImmediatePropagation event
+ end
+
+let context_host_contextmenu renderer node event =
+ match direct_context_menu renderer node with
+ | Some _menu ->
+ W.Event.preventDefault event;
+ W.Event.stopImmediatePropagation event
+ | None -> ()
+
+let context_host_keydown renderer node host_node event =
+ let key = W.KeyboardEvent.key event in
+ if
+ key = "ContextMenu"
+ || (key = "F10" && W.KeyboardEvent.shiftKey event)
+ then
+ match direct_context_menu renderer node with
+ | Some menu ->
+ let bounds = W.Element.getBoundingClientRect host_node in
+ W.KeyboardEvent.preventDefault event;
+ show_context_menu renderer menu
+ (int_of_float (W.DomRect.left bounds))
+ (int_of_float (W.DomRect.bottom bounds))
+ | None -> ()
+
+let attach_context_host_events renderer node host_node =
+ let state =
+ { timer = ref None; suppress_click = ref false;
+ touch_pointer = ref None; touch_origin_x = ref None;
+ touch_origin_y = ref None }
+ in
+ W.Element.addMouseDownEventListener
+ (fun event -> context_host_mouse_down renderer node event)
+ host_node;
+ W.Element.addEventListener "pointerdown"
+ (fun event -> context_host_pointer_down renderer node state event)
+ host_node;
+ W.Element.addEventListener "pointermove"
+ (fun event -> context_host_pointer_move state event)
+ host_node;
+ W.Element.addEventListener "pointerup"
+ (fun event -> context_host_pointer_end state event)
+ host_node;
+ W.Element.addEventListener "pointercancel"
+ (fun event -> context_host_pointer_end state event)
+ host_node;
+ W.Element.addEventListener "click"
+ (fun event -> context_host_click state event)
+ host_node;
+ W.Element.addEventListener "contextmenu"
+ (fun event -> context_host_contextmenu renderer node event)
+ host_node;
+ W.Element.addKeyDownEventListener
+ (fun event -> context_host_keydown renderer node host_node event)
+ host_node
+
+let attach_context_host_events_bang = attach_context_host_events
+
+(* --- context menu document-level wiring --- *)
+
+let context_menu_key_handler renderer document node event =
+ if !(renderer.web_open_context_menu) = Some node then begin
+ let key = W.KeyboardEvent.key event in
+ if key = "Escape" then begin
+ W.KeyboardEvent.preventDefault event;
+ hide_context_menu renderer;
+ focus_context_menu_host renderer node
+ end
+ else if
+ key = "ArrowDown" || key = "ArrowUp" || key = "Home" || key = "End"
+ then begin
+ let items = context_menu_focus_items renderer node in
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ let current =
+ match W.HtmlDocument.activeElement html_document with
+ | Some focused ->
+ Lui_web_focus.focused_child_index renderer items focused 0
+ | None -> None
+ in
+ let navigation_key =
+ if key = "ArrowDown" then "ArrowRight"
+ else if key = "ArrowUp" then "ArrowLeft"
+ else key
+ in
+ match
+ Lui_web_focus.horizontal_focus_index navigation_key current
+ (List.length items)
+ with
+ | Some index ->
+ W.KeyboardEvent.preventDefault event;
+ focus_context_menu_item renderer node index
+ | None -> ()
+ end
+ end
+
+let attach_context_menu_events renderer node dom_node =
+ let document = renderer.web_document in
+ let pointer_handler event =
+ let target =
+ Lui_web_util.event_target_to_element (W.Event.target event)
+ in
+ if not (W.Element.contains (W.Element.asNode target) dom_node) then
+ hide_context_menu renderer
+ in
+ let key_handler event =
+ context_menu_key_handler renderer document node event
+ in
+ let focus_handler event =
+ let target =
+ Lui_web_util.event_target_to_element (W.Event.target event)
+ in
+ if
+ !(renderer.web_open_context_menu) = Some node
+ && not (W.Element.contains (W.Element.asNode target) dom_node)
+ then hide_context_menu renderer
+ in
+ let click_handler _event = hide_context_menu renderer in
+ W.Document.addEventListener "pointerdown" pointer_handler document;
+ W.Document.addKeyDownEventListener key_handler document;
+ W.Document.addEventListener "focusin" focus_handler document;
+ W.Element.addEventListener "click" click_handler dom_node;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ W.Document.removeEventListener "pointerdown" pointer_handler document;
+ W.Document.removeKeyDownEventListener key_handler document;
+ W.Document.removeEventListener "focusin" focus_handler document;
+ W.Element.removeEventListener "click" click_handler dom_node;
+ if !(renderer.web_open_context_menu) = Some node then
+ renderer.web_open_context_menu := None)
+
+let attach_context_menu_events_bang = attach_context_menu_events
+
+(* --- mount --- *)
+
+(* A dropdown hanging off a menu row (MenuItem/MenuTrigger) that lives inside
+ another menu opens to the side by default, like the original gallery's
+ explicit {:anchor "right"} submenu declaration. *)
+let nested_submenu renderer current =
+ match current.retained_parent with
+ | Some trigger ->
+ (match Store.node renderer.web_store trigger with
+ | Some trigger_node ->
+ (match trigger_node.retained_parent with
+ | Some container ->
+ (match Store.node renderer.web_store container with
+ | Some container_node ->
+ Store.standard_kind_is container_node DropdownMenu
+ | None -> false)
+ | None -> false)
+ | None -> false)
+ | None -> false
+
+let attach_submenu_hover renderer node current trigger =
+ let positioner = current.platform_node in
+ let popup = Lui_web_util.child_element current.platform_node 0 in
+ (match Store.property renderer.web_store node AnchorValue with
+ | Some _ -> ()
+ | None ->
+ if nested_submenu renderer current then
+ W.Element.setAttribute "data-anchor" "right" positioner);
+ let close_timer = ref None in
+ let grace_active = ref false in
+ let grace_x = ref 0.0 in
+ let grace_y = ref 0.0 in
+ let cancel_close () =
+ (match !close_timer with
+ | Some timer -> Js.Global.clearTimeout timer
+ | None -> ());
+ close_timer := None
+ in
+ let close_later () =
+ cancel_close ();
+ close_timer :=
+ Some
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ close_timer := None;
+ grace_active := false;
+ W.Element.setAttribute "aria-expanded" "false" trigger;
+ set_dropdown_open renderer node false)
+ 120)
+ in
+ let open_submenu _event =
+ cancel_close ();
+ grace_active := false;
+ W.Element.setAttribute "aria-expanded" "true" trigger;
+ set_dropdown_open renderer node true
+ in
+ let trigger_leave event =
+ let mouse_event = Lui_web_util.pointer_mouse_event event in
+ grace_active := true;
+ grace_x := float_of_int (W.MouseEvent.clientX mouse_event);
+ grace_y := float_of_int (W.MouseEvent.clientY mouse_event);
+ close_later ()
+ in
+ let popup_leave _event =
+ grace_active := false;
+ close_later ()
+ in
+ let pointer_move event =
+ if !grace_active then begin
+ let mouse_event = Lui_web_util.pointer_mouse_event event in
+ let point_x = float_of_int (W.MouseEvent.clientX mouse_event) in
+ let point_y = float_of_int (W.MouseEvent.clientY mouse_event) in
+ if
+ not
+ (Lui_web_position.submenu_corridor positioner popup !grace_x
+ !grace_y point_x point_y)
+ then grace_active := false;
+ close_later ()
+ end
+ in
+ let previous_cleanup = Hashtbl.find_opt renderer.web_cleanups node in
+ W.Element.setAttribute "data-submenu-trigger" "" trigger;
+ W.Element.setAttribute "aria-haspopup" "menu" trigger;
+ W.Element.setAttribute "aria-expanded" "false" trigger;
+ W.Element.setAttribute "data-submenu" "" positioner;
+ W.Element.setAttribute "role" "menu" popup;
+ W.Element.addEventListener "mouseenter" open_submenu trigger;
+ W.Element.addEventListener "focusin" open_submenu trigger;
+ W.Element.addEventListener "mouseleave" trigger_leave trigger;
+ W.Element.addEventListener "mouseenter" open_submenu popup;
+ W.Element.addEventListener "mouseleave" popup_leave popup;
+ W.Document.addEventListener "mousemove" pointer_move
+ renderer.web_document;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ (match previous_cleanup with
+ | Some cleanup -> cleanup ()
+ | None -> ());
+ cancel_close ();
+ W.Element.removeEventListener "mouseenter" open_submenu trigger;
+ W.Element.removeEventListener "focusin" open_submenu trigger;
+ W.Element.removeEventListener "mouseleave" trigger_leave trigger;
+ W.Element.removeEventListener "mouseenter" open_submenu popup;
+ W.Element.removeEventListener "mouseleave" popup_leave popup;
+ W.Document.removeEventListener "mousemove" pointer_move
+ renderer.web_document);
+ Lui_web_position.position_dropdown renderer node
+
+(* The batch that mounts a picker dropdown can still be mid-flight, with
+ the popup's items inserted by later ops in the same batch, so work that
+ touches the items has to wait for the synchronous apply to unwind. A
+ microtask runs as soon as the current task's JS completes, ahead of any
+ subsequently queued task. *)
+let after_batch_apply f =
+ ignore
+ (Js.Promise.resolve ()
+ |> Js.Promise.then_ (fun () ->
+ f ();
+ Js.Promise.resolve ()))
+
+let mount_picker_dropdown renderer node =
+ set_dropdown_open renderer node true;
+ match picker_for_dropdown renderer node with
+ | Some picker ->
+ let control = picker_control_element renderer picker in
+ let popup_id = Lui_web_util.node_dom_id node ^ "-popup" in
+ let previous_cleanup = Hashtbl.find_opt renderer.web_cleanups node in
+ W.Element.setAttribute "aria-controls" popup_id control;
+ (match Store.node renderer.web_store picker with
+ | Some picker_node ->
+ if Store.standard_kind_is picker_node Combobox then
+ after_batch_apply (fun () ->
+ match Store.node renderer.web_store node with
+ | Some _menu -> set_combobox_active renderer picker node 0
+ | None -> ())
+ else
+ after_batch_apply (fun () ->
+ match Store.node renderer.web_store node with
+ | Some _menu ->
+ focus_context_menu_item renderer node
+ (picker_selected_index renderer node)
+ | None -> ())
+ | None -> ());
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ (match previous_cleanup with
+ | Some cleanup -> cleanup ()
+ | None -> ());
+ W.Element.removeAttribute "aria-controls" control;
+ W.Element.removeAttribute "data-lui-active-index" control;
+ W.Element.removeAttribute "aria-activedescendant" control;
+ Lui_web_util.focus_element control)
+ | None -> ()
+
+let mount_dropdown renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ let popup = Lui_web_util.child_element current.platform_node 0 in
+ W.Element.setAttribute "role"
+ (if Lui_web_nodes.dropdown_listbox renderer node then "listbox"
+ else "menu")
+ popup;
+ W.Element.setAttribute "id"
+ (Lui_web_util.node_dom_id node ^ "-popup") popup;
+ refresh_dropdown_item_roles renderer node;
+ refresh_combobox_list_state renderer node;
+ (match current.retained_parent with
+ | Some parent ->
+ (match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if Store.menu_item_row parent_node then
+ ignore
+ (attach_submenu_hover renderer node current
+ parent_node.platform_node)
+ else mount_picker_dropdown renderer node
+ | None -> invalid_arg "dropdown parent is unavailable")
+ | None -> invalid_arg "dropdown requires an anchor parent")
+ | None -> invalid_arg "unknown dropdown node"
+
+let mount_dropdown_bang = mount_dropdown
+
+let update_picker_expanded renderer parent expanded =
+ match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ List.iter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some current ->
+ (match Store.standard_kind current with
+ | Some Select ->
+ W.Element.setAttribute "aria-expanded"
+ (if expanded then "true" else "false")
+ current.platform_node
+ | Some Combobox ->
+ W.Element.setAttribute "aria-expanded"
+ (if expanded then "true" else "false")
+ (Lui_web_util.child_element current.platform_node 0)
+ | _ -> ())
+ | None -> ())
+ parent_node.retained_children
+ | None -> ()
+
+let update_picker_expanded_bang = update_picker_expanded
+
+let remove_dropdown_after_exit document parent positioner =
+ let popup = Lui_web_util.child_element positioner 0 in
+ begin_popup_close popup;
+ W.Element.setAttribute "inert" "" popup;
+ after_transition document popup 130 true (fun () ->
+ if W.Element.contains (W.Element.asNode positioner) parent then
+ ignore
+ (W.Element.removeChild (W.Element.asNode positioner) parent))
diff --git a/platform/web/melange/popup/lui_web_overlay.ml b/platform/web/melange/popup/lui_web_overlay.ml
new file mode 100644
index 00000000..bfa289c3
--- /dev/null
+++ b/platform/web/melange/popup/lui_web_overlay.ml
@@ -0,0 +1,1104 @@
+(* Modal surfaces, anchored tooltips, and toasts: the modal open stack,
+ inert host attribute, sheet swipe-to-dismiss, modal focus trapping,
+ tooltip warm/show/hide timers, and toast swipe/auto-dismiss. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+
+(* matchMedia exposes an abstract mediaQueryList; "matches" is a plain
+ boolean property read — a typed accessor, not a cast. *)
+external media_query_matches : W.Window.mediaQueryList -> bool = "matches"
+ [@@mel.get]
+
+(* set-style! in the reference writes element.style.setProperty. *)
+let set_style_on element name value =
+ Lui_web_util.set_style
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement element))
+ name value
+
+let string_includes haystack needle =
+ let hlen = String.length haystack in
+ let nlen = String.length needle in
+ let rec search index =
+ if index + nlen > hlen then false
+ else if String.sub haystack index nlen = needle then true
+ else search (index + 1)
+ in
+ search 0
+
+(* string/replace in the reference replaces every occurrence. *)
+let string_replace_all haystack needle replacement =
+ let nlen = String.length needle in
+ if nlen = 0 then haystack
+ else begin
+ let buffer = Buffer.create (String.length haystack) in
+ let rec loop index =
+ if index + nlen <= String.length haystack
+ && String.sub haystack index nlen = needle
+ then begin
+ Buffer.add_string buffer replacement;
+ loop (index + nlen)
+ end
+ else if index < String.length haystack then begin
+ Buffer.add_char buffer haystack.[index];
+ loop (index + 1)
+ end
+ in
+ loop 0;
+ Buffer.contents buffer
+ end
+
+(* LG str on floats follows JS String(x): integral floats print without a
+ decimal point, which CSS requires for the swipe custom properties. *)
+let js_number_string (value : float) = Js.Float.toString value
+
+let clear_timeout slot =
+ (match !slot with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ slot := None
+
+(* Retained-node queries keyed by a nodes-map snapshot. *)
+
+let modal_node nodes node =
+ match Hashtbl.find_opt nodes node with
+ | Some current ->
+ (match Store.standard_kind current with
+ | Some kind -> modal_surface kind
+ | None -> false)
+ | None -> false
+
+let modal_node_ = modal_node
+
+let modal_layer_node = Lui_web_util.modal_layer_node
+
+let anchored_tooltip current = Store.anchored_tooltip current
+let anchored_tooltip_ = anchored_tooltip
+
+let anchored_tooltip_node nodes node =
+ match Hashtbl.find_opt nodes node with
+ | Some current -> anchored_tooltip current
+ | None -> false
+
+let anchored_tooltip_node_ = anchored_tooltip_node
+
+(* compact-sheet? mirrors the original: a simulated phone is always
+ compact; otherwise the document element width decides. *)
+let compact_sheet renderer =
+ match !(renderer.web_simulator_device) with
+ | Some device -> device.simulator_device_form_factor = SimulatorPhone
+ | None ->
+ let root = W.Document.documentElement renderer.web_document in
+ W.Element.clientWidth root <= 640
+
+let document_body_focused renderer =
+ let document = W.Document.unsafeAsHtmlDocument renderer.web_document in
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ (match W.HtmlDocument.body document with
+ | Some body -> W.Element.isSameNode (W.Element.asNode body) focused
+ | None -> false)
+ | None -> false
+
+(* Modal open stack. *)
+
+let topmost_modal renderer node =
+ let stack = !(renderer.web_modal_stack) in
+ stack <> [] && node = List.nth stack (List.length stack - 1)
+
+let remove_modal_from_stack renderer node =
+ renderer.web_modal_stack :=
+ List.filter
+ (fun current -> current <> node) !(renderer.web_modal_stack)
+
+let refresh_modal_host_inert renderer =
+ Lui_web_util.set_state_attribute
+ renderer.web_host "inert" (!(renderer.web_modal_stack) <> []);
+ true
+
+let refresh_modal_host_inert_bang = refresh_modal_host_inert
+
+(* Modal focus trapping. *)
+
+let modal_focus_selector =
+ "button:not([disabled]):not([hidden]),"
+ ^ "input:not([disabled]):not([hidden]),"
+ ^ "textarea:not([disabled]):not([hidden]),"
+ ^ "select:not([disabled]):not([hidden]),"
+ ^ "[tabindex]:not([tabindex=\"-1\"]):not([disabled]):not([hidden])"
+
+let modal_focus_items renderer parent =
+ let nodes =
+ W.Element.querySelectorAll
+ modal_focus_selector (Lui_web_nodes.dom_node renderer parent)
+ in
+ let rec collect index result =
+ if index = W.NodeList.length nodes then List.rev result
+ else
+ match W.NodeList.item index nodes with
+ | Some candidate ->
+ (match W.Element.ofNode candidate with
+ | Some candidate_element ->
+ collect (index + 1) (candidate_element :: result)
+ | None -> collect (index + 1) result)
+ | None -> collect (index + 1) result
+ in
+ collect 0 []
+
+let focused_element_index elements focused =
+ let rec scan items index =
+ match items with
+ | [] -> -1
+ | item :: rest ->
+ if W.Element.isSameNode (W.Element.asNode item) focused then index
+ else scan rest (index + 1)
+ in
+ scan elements 0
+
+(* Swipe guardrails shared by sheet and toast dismissal. *)
+
+let rec swipe_ignored_target target boundary =
+ if W.Element.isSameNode (W.Element.asNode target) boundary then false
+ else begin
+ let role = W.Element.getAttribute "role" target in
+ let class_name = W.Element.getAttribute "class" target in
+ let ignored =
+ W.Element.hasAttribute "data-lui-swipe-ignore" target
+ || W.Element.hasAttribute "type" target
+ || W.Element.hasAttribute "href" target
+ || role = Some "button"
+ ||
+ (match class_name with
+ | Some value ->
+ string_includes value "lui-textarea"
+ || string_includes value "lui-input"
+ | None -> false)
+ in
+ if ignored then true
+ else
+ match W.Element.parentElement target with
+ | Some parent -> swipe_ignored_target parent boundary
+ | None -> false
+ end
+
+let rec sheet_scroll_blocks_swipe target boundary =
+ if W.Element.isSameNode (W.Element.asNode target) boundary then false
+ else if
+ W.Element.scrollHeight target > W.Element.clientHeight target
+ && W.Element.scrollTop target > 0.5
+ then true
+ else
+ match W.Element.parentElement target with
+ | Some parent -> sheet_scroll_blocks_swipe parent boundary
+ | None -> false
+
+(* Popup transitions. *)
+
+let begin_popup_open popup =
+ W.Element.removeAttribute "data-closed" popup;
+ W.Element.removeAttribute "data-ending-style" popup;
+ W.Element.setAttribute "data-open" "" popup;
+ W.Element.setAttribute "data-starting-style" "" popup;
+ Webapi.requestAnimationFrame
+ (fun _time -> W.Element.removeAttribute "data-starting-style" popup);
+ true
+
+let begin_popup_open_bang = begin_popup_open
+
+let begin_popup_close popup =
+ W.Element.removeAttribute "data-open" popup;
+ W.Element.setAttribute "data-closed" "" popup;
+ W.Element.setAttribute "data-ending-style" "" popup;
+ true
+
+let begin_popup_close_bang = begin_popup_close
+
+let prefers_reduced_motion document =
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ match W.HtmlDocument.defaultView html_document with
+ | Some window ->
+ media_query_matches
+ (W.Window.matchMedia "(prefers-reduced-motion: reduce)" window)
+ | None -> false
+
+let transition_event_from target event =
+ W.Element.isSameNode
+ (W.Element.asNode
+ (W.EventTarget.unsafeAsElement (W.Event.target event)))
+ target
+
+let after_transition document target fallback_duration finish_on_cancel
+ complete =
+ if prefers_reduced_motion document then begin
+ ignore (complete ());
+ true
+ end
+ else begin
+ let finished = ref false in
+ let timer = ref None in
+ let finish_ref = ref (fun () -> true) in
+ let transition_handler event =
+ if transition_event_from target event then
+ ignore (!(finish_ref) ())
+ in
+ let finish () =
+ if not !finished then begin
+ finished := true;
+ (match !timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ W.Element.removeEventListener
+ "transitionend" transition_handler target;
+ if finish_on_cancel then
+ W.Element.removeEventListener
+ "transitioncancel" transition_handler target;
+ ignore (complete ())
+ end;
+ true
+ in
+ finish_ref := finish;
+ W.Element.addEventListener "transitionend" transition_handler target;
+ if finish_on_cancel then
+ W.Element.addEventListener
+ "transitioncancel" transition_handler target;
+ timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () -> ignore (finish ()))
+ fallback_duration);
+ true
+ end
+
+let after_transition_bang = after_transition
+
+let finish_popup_close_after_transition document popup duration =
+ ignore
+ (after_transition document popup duration true (fun () ->
+ if W.Element.getAttribute "data-ending-style" popup = Some ""
+ then W.Element.removeAttribute "data-ending-style" popup;
+ true));
+ true
+
+let finish_popup_close_after_transition_bang =
+ finish_popup_close_after_transition
+
+(* Modal event wiring. *)
+
+type modal_swipe_state = {
+ swipe_pointer : int option ref;
+ swipe_start_x : float ref;
+ swipe_start_y : float ref;
+ swipe_current_y : float ref;
+ swipe_start_time : float ref;
+ swipe_axis : string option ref;
+}
+
+type modal_context = {
+ modal_renderer : web_renderer;
+ modal_node_id : int;
+ modal_dom_node : Dom.element;
+ modal_layer : Dom.element;
+ modal_backdrop : Dom.element;
+ modal_sheet : bool;
+ modal_swipe : modal_swipe_state;
+}
+
+let modal_reset_swipe ctx =
+ let state = ctx.modal_swipe in
+ state.swipe_pointer := None;
+ state.swipe_axis := None;
+ W.Element.removeAttribute "data-swiping" ctx.modal_dom_node;
+ W.Element.removeAttribute "data-swipe-direction" ctx.modal_dom_node;
+ set_style_on ctx.modal_dom_node "--drawer-swipe-movement-y" "0px";
+ set_style_on ctx.modal_backdrop "--drawer-swipe-progress" "1";
+ true
+
+let modal_dismiss ctx =
+ if
+ topmost_modal ctx.modal_renderer ctx.modal_node_id
+ && W.Element.getAttribute "data-lui-modal-state" ctx.modal_layer
+ = Some "open"
+ then
+ ignore
+ (!(ctx.modal_renderer.web_event_handler)
+ (Dismiss ctx.modal_node_id));
+ true
+
+let modal_pointer_down ctx event =
+ let target = W.EventTarget.unsafeAsElement (W.Event.target event) in
+ let compact = compact_sheet ctx.modal_renderer in
+ let ignored = swipe_ignored_target target ctx.modal_dom_node in
+ let scroll_blocked =
+ sheet_scroll_blocks_swipe target ctx.modal_dom_node
+ in
+ let mouse = Lui_web_util.pointer_mouse_event event in
+ if
+ ctx.modal_sheet && compact
+ && Lui_web_util.pointer_type event = "touch"
+ && W.MouseEvent.button mouse = 0
+ && (not ignored) && not scroll_blocked
+ then begin
+ let x = float_of_int (W.MouseEvent.clientX mouse) in
+ let y = float_of_int (W.MouseEvent.clientY mouse) in
+ let state = ctx.modal_swipe in
+ state.swipe_pointer := Some (Lui_web_util.pointer_id event);
+ state.swipe_start_x := x;
+ state.swipe_start_y := y;
+ state.swipe_current_y := y;
+ state.swipe_start_time := W.Event.timeStamp event;
+ if W.Event.isTrusted event then
+ W.Element.setPointerCapture
+ (W.PointerEvent.pointerId (Lui_web_util.as_pointer_event event))
+ ctx.modal_dom_node
+ end;
+ ()
+
+let modal_pointer_move ctx event =
+ let state = ctx.modal_swipe in
+ match !(state.swipe_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ let mouse = Lui_web_util.pointer_mouse_event event in
+ let delta_x =
+ Float.abs
+ (float_of_int (W.MouseEvent.clientX mouse)
+ -. !(state.swipe_start_x))
+ in
+ let delta_y =
+ float_of_int (W.MouseEvent.clientY mouse)
+ -. !(state.swipe_start_y)
+ in
+ if
+ !(state.swipe_axis) = None
+ && max delta_x (Float.abs delta_y) > 8.0
+ then
+ state.swipe_axis :=
+ Some
+ (if delta_x > Float.abs delta_y then "horizontal"
+ else "vertical");
+ if !(state.swipe_axis) = Some "vertical" && delta_y > 0.0 then begin
+ W.Event.preventDefault event;
+ state.swipe_current_y :=
+ float_of_int (W.MouseEvent.clientY mouse);
+ W.Element.setAttribute "data-swiping" "" ctx.modal_dom_node;
+ W.Element.setAttribute
+ "data-swipe-direction" "down" ctx.modal_dom_node;
+ set_style_on ctx.modal_dom_node "--drawer-swipe-movement-y"
+ (js_number_string delta_y ^ "px");
+ set_style_on ctx.modal_backdrop "--drawer-swipe-progress"
+ (js_number_string
+ (max 0.0
+ (1.0
+ -. delta_y
+ /. float_of_int
+ (W.Element.clientHeight ctx.modal_dom_node))))
+ end
+ | _ -> ()
+
+let modal_pointer_end ctx event =
+ let state = ctx.modal_swipe in
+ match !(state.swipe_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ let delta =
+ max 0.0 (!(state.swipe_current_y) -. !(state.swipe_start_y))
+ in
+ let threshold =
+ max 96.0
+ (0.25
+ *. float_of_int (W.Element.clientHeight ctx.modal_dom_node))
+ in
+ let duration =
+ max 1.0 (W.Event.timeStamp event -. !(state.swipe_start_time))
+ in
+ let velocity = delta /. duration in
+ ignore (modal_reset_swipe ctx);
+ if delta > threshold || (delta >= 48.0 && velocity >= 0.5) then
+ ignore (modal_dismiss ctx)
+ | _ -> ()
+
+let modal_pointer_cancel ctx event =
+ match !(ctx.modal_swipe.swipe_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ ignore (modal_reset_swipe ctx)
+ | _ -> ()
+
+let modal_focus_trap_wrap event items focused backwards =
+ let index = focused_element_index items focused in
+ if
+ items <> []
+ && (index = -1
+ || (backwards && index = 0)
+ || ((not backwards) && index = List.length items - 1))
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ Lui_web_util.focus_element
+ (if backwards then List.nth items (List.length items - 1)
+ else List.nth items 0)
+ end
+
+let modal_key_handler ctx event =
+ if topmost_modal ctx.modal_renderer ctx.modal_node_id then begin
+ let key = W.KeyboardEvent.key event in
+ if key = "Escape" then begin
+ W.KeyboardEvent.preventDefault event;
+ ignore (modal_dismiss ctx)
+ end
+ else if key = "Tab" then begin
+ let items =
+ modal_focus_items ctx.modal_renderer ctx.modal_node_id
+ in
+ let focused =
+ W.EventTarget.unsafeAsElement (W.KeyboardEvent.target event)
+ in
+ let backwards = W.KeyboardEvent.shiftKey event in
+ modal_focus_trap_wrap event items focused backwards
+ end
+ end
+
+let attach_modal_events renderer node dom_node =
+ let document = renderer.web_document in
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ let previous_focus =
+ if document_body_focused renderer then
+ !(renderer.web_modal_return_focus)
+ else W.HtmlDocument.activeElement html_document
+ in
+ renderer.web_modal_return_focus := None;
+ let layer = modal_layer_node dom_node in
+ let ctx = {
+ modal_renderer = renderer;
+ modal_node_id = node;
+ modal_dom_node = dom_node;
+ modal_layer = layer;
+ modal_backdrop = Lui_web_util.child_element layer 0;
+ modal_sheet =
+ (match Store.node renderer.web_store node with
+ | Some current -> Store.standard_kind_is current Sheet
+ | None -> false);
+ modal_swipe = {
+ swipe_pointer = ref None;
+ swipe_start_x = ref 0.0;
+ swipe_start_y = ref 0.0;
+ swipe_current_y = ref 0.0;
+ swipe_start_time = ref 0.0;
+ swipe_axis = ref None;
+ };
+ } in
+ let click_handler _event = ignore (modal_dismiss ctx) in
+ let pointer_down_handler event = modal_pointer_down ctx event in
+ let pointer_move_handler event = modal_pointer_move ctx event in
+ let pointer_end_handler event = modal_pointer_end ctx event in
+ let pointer_cancel_handler event = modal_pointer_cancel ctx event in
+ let key_handler event = modal_key_handler ctx event in
+ W.Element.addEventListener "click" click_handler ctx.modal_backdrop;
+ if ctx.modal_sheet then begin
+ W.Element.addEventListener "pointerdown" pointer_down_handler dom_node;
+ W.Element.addEventListener "pointermove" pointer_move_handler dom_node;
+ W.Element.addEventListener "pointerup" pointer_end_handler dom_node;
+ W.Element.addEventListener
+ "pointercancel" pointer_cancel_handler dom_node
+ end;
+ W.Document.addKeyDownEventListener key_handler document;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ remove_modal_from_stack renderer node;
+ W.Element.setAttribute "data-lui-modal-state" "closed" layer;
+ W.Element.removeAttribute "data-open" layer;
+ W.Element.setAttribute "data-closed" "" layer;
+ W.Element.setAttribute "data-ending-style" "" layer;
+ W.Element.removeAttribute "data-open" dom_node;
+ W.Element.setAttribute "data-closed" "" dom_node;
+ W.Element.setAttribute "data-ending-style" "" dom_node;
+ W.Element.setAttribute "inert" "" layer;
+ ignore (refresh_modal_host_inert renderer);
+ W.Element.removeEventListener "click" click_handler
+ ctx.modal_backdrop;
+ if ctx.modal_sheet then begin
+ ignore (modal_reset_swipe ctx);
+ W.Element.removeEventListener
+ "pointerdown" pointer_down_handler dom_node;
+ W.Element.removeEventListener
+ "pointermove" pointer_move_handler dom_node;
+ W.Element.removeEventListener
+ "pointerup" pointer_end_handler dom_node;
+ W.Element.removeEventListener
+ "pointercancel" pointer_cancel_handler dom_node
+ end;
+ W.Document.removeKeyDownEventListener key_handler document;
+ (Lui_web_focus.restore_focus renderer : Dom.element option -> unit)
+ previous_focus;
+ ignore true)
+
+let attach_modal_events_bang = attach_modal_events
+
+(* Focus bookkeeping: the element focused before a modal opened is
+ remembered briefly so dismiss can restore it. *)
+let record_modal_return_focus renderer element =
+ renderer.web_modal_return_focus := Some element;
+ ignore
+ (Js.Global.setTimeout ~f:(fun () ->
+ (match !(renderer.web_modal_return_focus) with
+ | Some current ->
+ if W.Element.isSameNode (W.Element.asNode current) element
+ then renderer.web_modal_return_focus := None
+ | None -> ()))
+ 0);
+ true
+
+let record_modal_return_focus_bang = record_modal_return_focus
+
+(* Modal lifecycle. *)
+
+let open_modal renderer node dom_node =
+ let layer = modal_layer_node dom_node in
+ if
+ W.Element.getAttribute "data-lui-modal-state" layer <> Some "open"
+ then begin
+ W.Element.removeAttribute "hidden" layer;
+ W.Element.removeAttribute "inert" layer;
+ W.Element.removeAttribute "data-closed" layer;
+ W.Element.removeAttribute "data-ending-style" layer;
+ W.Element.setAttribute "data-open" "" layer;
+ W.Element.setAttribute "data-starting-style" "" layer;
+ W.Element.removeAttribute "data-closed" dom_node;
+ W.Element.removeAttribute "data-ending-style" dom_node;
+ W.Element.setAttribute "data-open" "" dom_node;
+ W.Element.setAttribute "data-starting-style" "" dom_node;
+ W.Element.setAttribute "data-lui-modal-state" "open" layer;
+ renderer.web_modal_stack := !(renderer.web_modal_stack) @ [node];
+ ignore (refresh_modal_host_inert renderer);
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement dom_node);
+ Webapi.requestAnimationFrame (fun _time ->
+ W.Element.removeAttribute "data-starting-style" layer;
+ W.Element.removeAttribute "data-starting-style" dom_node)
+ end;
+ ()
+
+let open_modal_bang = open_modal
+
+let remove_modal_layer_after_exit document parent layer surface kind =
+ let transition_target =
+ if kind = Some Sheet then surface
+ else Lui_web_util.child_element layer 0
+ in
+ let duration = if kind = Some Sheet then 470 else 170 in
+ after_transition document transition_target duration true (fun () ->
+ if W.Element.contains (W.Element.asNode layer) parent then
+ ignore (W.Element.removeChild (W.Element.asNode layer) parent);
+ W.Element.removeAttribute "data-ending-style" surface;
+ true)
+
+let remove_modal_layer_after_exit_bang = remove_modal_layer_after_exit
+
+(* Anchored tooltips. *)
+
+let tooltip_delay renderer node = Store.tooltip_delay renderer node
+
+let set_tooltip_open renderer node open_flag =
+ let tooltip = Lui_web_nodes.dom_node renderer node in
+ if open_flag then begin
+ (match !(renderer.web_open_tooltip) with
+ | Some previous ->
+ if previous <> node then
+ (match Store.node renderer.web_store previous with
+ | Some _current ->
+ let previous_tooltip =
+ Lui_web_nodes.dom_node renderer previous
+ in
+ ignore (begin_popup_close previous_tooltip);
+ ignore
+ (finish_popup_close_after_transition
+ renderer.web_document previous_tooltip 120)
+ | None -> ())
+ | None -> ());
+ renderer.web_open_tooltip := Some node;
+ ignore (begin_popup_open tooltip);
+ ignore (Lui_web_position.position_tooltip renderer node);
+ Webapi.requestAnimationFrame (fun _time ->
+ match Store.node renderer.web_store node with
+ | Some _current ->
+ ignore (Lui_web_position.position_tooltip renderer node)
+ | None -> ())
+ end
+ else begin
+ ignore (begin_popup_close tooltip);
+ ignore
+ (finish_popup_close_after_transition renderer.web_document tooltip
+ 120);
+ if !(renderer.web_open_tooltip) = Some node then
+ renderer.web_open_tooltip := None
+ end;
+ ()
+
+let set_tooltip_open_bang = set_tooltip_open
+
+let add_tooltip_description trigger tooltip_id =
+ (match W.Element.getAttribute "aria-describedby" trigger with
+ | Some current ->
+ if
+ not
+ (string_includes
+ (" " ^ current ^ " ") (" " ^ tooltip_id ^ " "))
+ then
+ W.Element.setAttribute "aria-describedby"
+ (current ^ " " ^ tooltip_id) trigger
+ | None ->
+ W.Element.setAttribute "aria-describedby" tooltip_id trigger);
+ true
+
+let remove_tooltip_description trigger tooltip_id =
+ (match W.Element.getAttribute "aria-describedby" trigger with
+ | Some current ->
+ let next =
+ String.trim (string_replace_all current tooltip_id "")
+ in
+ if next = "" then
+ W.Element.removeAttribute "aria-describedby" trigger
+ else W.Element.setAttribute "aria-describedby" next trigger
+ | None -> ());
+ true
+
+(* Tooltip timers: show/hide delays plus the "warm" window that skips the
+ delay when the user moves between anchored triggers. *)
+
+type tooltip_state = {
+ pointer_inside : bool ref;
+ origin : string ref;
+ show_timer : Js.Global.timeoutId option ref;
+ hide_timer : Js.Global.timeoutId option ref;
+ warm_timer : Js.Global.timeoutId option ref;
+}
+
+type tooltip_context = {
+ tooltip_renderer : web_renderer;
+ tooltip_node_id : int;
+ tooltip_state : tooltip_state;
+}
+
+let tooltip_cancel_show ctx = clear_timeout ctx.tooltip_state.show_timer
+let tooltip_cancel_hide ctx = clear_timeout ctx.tooltip_state.hide_timer
+
+let tooltip_cancel_warm ctx =
+ clear_timeout ctx.tooltip_state.warm_timer;
+ ctx.tooltip_renderer.web_tooltip_warm := false
+
+let tooltip_cancel_all ctx =
+ tooltip_cancel_show ctx;
+ tooltip_cancel_hide ctx
+
+let tooltip_warm ctx =
+ tooltip_cancel_warm ctx;
+ ctx.tooltip_renderer.web_tooltip_warm := true;
+ ctx.tooltip_state.warm_timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () ->
+ ctx.tooltip_state.warm_timer := None;
+ ctx.tooltip_renderer.web_tooltip_warm := false)
+ 400)
+
+let tooltip_show ctx next_origin =
+ tooltip_cancel_all ctx;
+ ctx.tooltip_state.origin := next_origin;
+ set_tooltip_open ctx.tooltip_renderer ctx.tooltip_node_id true
+
+let tooltip_hide ctx warm =
+ tooltip_cancel_all ctx;
+ if warm && !(ctx.tooltip_state.origin) = "pointer" then
+ tooltip_warm ctx;
+ set_tooltip_open ctx.tooltip_renderer ctx.tooltip_node_id false;
+ ctx.tooltip_state.origin := ""
+
+let tooltip_pointer_enter ctx event =
+ if Lui_web_util.pointer_type event <> "touch" then begin
+ ctx.tooltip_state.pointer_inside := true;
+ tooltip_cancel_hide ctx;
+ let delay =
+ if !(ctx.tooltip_renderer.web_tooltip_warm) then 0
+ else tooltip_delay ctx.tooltip_renderer ctx.tooltip_node_id
+ in
+ if delay = 0 then tooltip_show ctx "pointer"
+ else
+ ctx.tooltip_state.show_timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () ->
+ ctx.tooltip_state.show_timer := None;
+ tooltip_show ctx "pointer")
+ delay)
+ end
+
+let tooltip_pointer_leave ctx _event =
+ ctx.tooltip_state.pointer_inside := false;
+ tooltip_cancel_show ctx;
+ ctx.tooltip_state.hide_timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () ->
+ ctx.tooltip_state.hide_timer := None;
+ tooltip_hide ctx true)
+ 50)
+
+let tooltip_focus_in ctx _event = tooltip_show ctx "focus"
+
+let tooltip_focus_out ctx _event =
+ tooltip_cancel_hide ctx;
+ ctx.tooltip_state.hide_timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () ->
+ ctx.tooltip_state.hide_timer := None;
+ if not !(ctx.tooltip_state.pointer_inside) then
+ tooltip_hide ctx false)
+ 0)
+
+let tooltip_press ctx _event =
+ tooltip_cancel_warm ctx;
+ tooltip_hide ctx false
+
+let tooltip_key ctx event =
+ if
+ W.KeyboardEvent.key event = "Escape"
+ && !(ctx.tooltip_renderer.web_open_tooltip)
+ = Some ctx.tooltip_node_id
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ tooltip_cancel_warm ctx;
+ tooltip_hide ctx false
+ end
+
+let tooltip_refresh_position ctx _event =
+ if !(ctx.tooltip_renderer.web_open_tooltip) = Some ctx.tooltip_node_id
+ then
+ ignore
+ (Lui_web_position.position_tooltip ctx.tooltip_renderer
+ ctx.tooltip_node_id)
+
+let mount_tooltip renderer node tooltip =
+ let document = renderer.web_document in
+ let window =
+ W.HtmlDocument.defaultView (W.Document.unsafeAsHtmlDocument document)
+ in
+ let trigger = Lui_web_nodes.dropdown_anchor_node renderer node in
+ let tooltip_id = Lui_web_util.node_dom_id node in
+ let ctx = {
+ tooltip_renderer = renderer;
+ tooltip_node_id = node;
+ tooltip_state = {
+ pointer_inside = ref false;
+ origin = ref "";
+ show_timer = ref None;
+ hide_timer = ref None;
+ warm_timer = ref None;
+ };
+ } in
+ let pointer_enter_handler event = tooltip_pointer_enter ctx event in
+ let pointer_leave_handler event = tooltip_pointer_leave ctx event in
+ let focus_in_handler event = tooltip_focus_in ctx event in
+ let focus_out_handler event = tooltip_focus_out ctx event in
+ let press_handler event = tooltip_press ctx event in
+ let key_handler event = tooltip_key ctx event in
+ let resize_handler event = tooltip_refresh_position ctx event in
+ ignore (add_tooltip_description trigger tooltip_id);
+ W.Element.addEventListener "pointerenter" pointer_enter_handler trigger;
+ W.Element.addEventListener "pointerleave" pointer_leave_handler trigger;
+ W.Element.addEventListener "focusin" focus_in_handler trigger;
+ W.Element.addEventListener "focusout" focus_out_handler trigger;
+ W.Element.addEventListener "pointerdown" press_handler trigger;
+ (match window with
+ | Some current_window ->
+ W.Window.addEventListener "resize" resize_handler current_window
+ | None -> ());
+ W.Document.addKeyDownEventListener key_handler document;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ tooltip_cancel_all ctx;
+ tooltip_cancel_warm ctx;
+ W.Element.removeAttribute "data-open" tooltip;
+ if !(renderer.web_open_tooltip) = Some node then
+ renderer.web_open_tooltip := None;
+ ignore (remove_tooltip_description trigger tooltip_id);
+ W.Element.removeEventListener
+ "pointerenter" pointer_enter_handler trigger;
+ W.Element.removeEventListener
+ "pointerleave" pointer_leave_handler trigger;
+ W.Element.removeEventListener "focusin" focus_in_handler trigger;
+ W.Element.removeEventListener "focusout" focus_out_handler trigger;
+ W.Element.removeEventListener "pointerdown" press_handler trigger;
+ (match window with
+ | Some current_window ->
+ W.Window.removeEventListener
+ "resize" resize_handler current_window
+ | None -> ());
+ W.Document.removeKeyDownEventListener key_handler document;
+ ignore true)
+
+let mount_tooltip_bang = mount_tooltip
+
+(* Toasts. *)
+
+let toast_duration renderer node = Store.toast_duration renderer node
+
+let first_toast_node renderer toast =
+ let children = W.Element.children renderer.web_toast_viewport in
+ match W.HtmlCollection.item 0 children with
+ | Some first_toast ->
+ W.Element.isSameNode (W.Element.asNode first_toast) toast
+ | None -> false
+
+let first_toast_node_ = first_toast_node
+
+type toast_state = {
+ toast_timer : Js.Global.timeoutId option ref;
+ pointer_inside : bool ref;
+ focus_inside : bool ref;
+ active_pointer : int option ref;
+ start_x : int option ref;
+ start_y : int option ref;
+ current_x : int ref;
+ current_y : int ref;
+ toast_axis : string option ref;
+}
+
+type toast_context = {
+ toast_renderer : web_renderer;
+ toast_node_id : int;
+ toast_element : Dom.element;
+ toast_state : toast_state;
+}
+
+let toast_reset_swipe ctx =
+ let state = ctx.toast_state in
+ let toast = ctx.toast_element in
+ state.active_pointer := None;
+ state.start_x := None;
+ state.start_y := None;
+ state.toast_axis := None;
+ W.Element.removeAttribute "data-swiping" toast;
+ W.Element.removeAttribute "data-swipe-direction" toast;
+ set_style_on toast "--toast-swipe-movement-x" "0px";
+ set_style_on toast "--toast-swipe-movement-y" "0px"
+
+let toast_cancel ctx = clear_timeout ctx.toast_state.toast_timer
+
+let toast_dismiss ctx =
+ toast_cancel ctx;
+ ignore
+ (!(ctx.toast_renderer.web_event_handler) (Dismiss ctx.toast_node_id))
+
+let toast_schedule ctx =
+ toast_cancel ctx;
+ let duration =
+ toast_duration ctx.toast_renderer ctx.toast_node_id
+ in
+ if duration > 0 then
+ ctx.toast_state.toast_timer :=
+ Some
+ (Js.Global.setTimeout ~f:(fun () ->
+ ctx.toast_state.toast_timer := None;
+ toast_dismiss ctx)
+ duration)
+
+let toast_resume ctx =
+ if
+ (not !(ctx.toast_state.pointer_inside))
+ && not !(ctx.toast_state.focus_inside)
+ then toast_schedule ctx
+
+let toast_pointer_enter ctx _event =
+ ctx.toast_state.pointer_inside := true;
+ toast_cancel ctx
+
+let toast_pointer_leave ctx _event =
+ ctx.toast_state.pointer_inside := false;
+ toast_resume ctx
+
+let toast_focus_in ctx _event =
+ ctx.toast_state.focus_inside := true;
+ toast_cancel ctx
+
+let toast_focus_out ctx _event =
+ ctx.toast_state.focus_inside := false;
+ toast_resume ctx
+
+let toast_pointer_down ctx event =
+ let target = W.EventTarget.unsafeAsElement (W.Event.target event) in
+ let interactive = swipe_ignored_target target ctx.toast_element in
+ let mouse = Lui_web_util.pointer_mouse_event event in
+ if W.MouseEvent.button mouse = 0 && not interactive then begin
+ let x = W.MouseEvent.clientX mouse in
+ let y = W.MouseEvent.clientY mouse in
+ let state = ctx.toast_state in
+ state.active_pointer := Some (Lui_web_util.pointer_id event);
+ state.start_x := Some x;
+ state.start_y := Some y;
+ state.current_x := x;
+ state.current_y := y;
+ if W.Event.isTrusted event then
+ W.Element.setPointerCapture
+ (W.PointerEvent.pointerId (Lui_web_util.as_pointer_event event))
+ ctx.toast_element;
+ toast_cancel ctx
+ end
+
+let toast_swipe_apply ctx event axis x y origin_x origin_y =
+ let toast = ctx.toast_element in
+ let delta_x = x - origin_x in
+ let delta_y = y - origin_y in
+ let dampened delta =
+ if delta < 0 then
+ -int_of_float (Float.sqrt (float_of_int (abs delta)))
+ else delta
+ in
+ if axis = "horizontal" then begin
+ let movement = dampened delta_x in
+ W.Event.preventDefault event;
+ W.Element.setAttribute "data-swiping" "" toast;
+ W.Element.setAttribute "data-swipe-direction"
+ (if delta_x < 0 then "left" else "right") toast;
+ set_style_on toast "--toast-swipe-movement-x"
+ (string_of_int movement ^ "px")
+ end
+ else begin
+ let movement = dampened delta_y in
+ W.Event.preventDefault event;
+ W.Element.setAttribute "data-swiping" "" toast;
+ W.Element.setAttribute "data-swipe-direction"
+ (if delta_y < 0 then "up" else "down") toast;
+ set_style_on toast "--toast-swipe-movement-y"
+ (string_of_int movement ^ "px")
+ end
+
+let toast_pointer_move ctx event =
+ let state = ctx.toast_state in
+ match !(state.active_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ (match !(state.start_x), !(state.start_y) with
+ | Some origin_x, Some origin_y ->
+ let mouse = Lui_web_util.pointer_mouse_event event in
+ let x = W.MouseEvent.clientX mouse in
+ let y = W.MouseEvent.clientY mouse in
+ let delta_x = x - origin_x in
+ let delta_y = y - origin_y in
+ state.current_x := x;
+ state.current_y := y;
+ if
+ !(state.toast_axis) = None
+ && max (abs delta_x) (abs delta_y) > 4
+ then
+ state.toast_axis :=
+ Some
+ (if abs delta_x > abs delta_y then "horizontal"
+ else "vertical");
+ (match !(state.toast_axis) with
+ | Some axis ->
+ toast_swipe_apply ctx event axis x y origin_x origin_y
+ | None -> ())
+ | _ -> ())
+ | _ -> ()
+
+let toast_pointer_up ctx event =
+ let state = ctx.toast_state in
+ match !(state.active_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ (match !(state.start_x), !(state.start_y) with
+ | Some origin_x, Some origin_y ->
+ let delta_x = !(state.current_x) - origin_x in
+ let delta_y = !(state.current_y) - origin_y in
+ let should_dismiss =
+ match !(state.toast_axis) with
+ | Some axis ->
+ if axis = "horizontal" then delta_x > 40
+ else delta_y > 40
+ | None -> false
+ in
+ state.active_pointer := None;
+ state.start_x := None;
+ state.start_y := None;
+ if should_dismiss then toast_dismiss ctx
+ else begin
+ toast_reset_swipe ctx;
+ toast_resume ctx
+ end
+ | _ -> ())
+ | _ -> ()
+
+let toast_pointer_cancel ctx event =
+ match !(ctx.toast_state.active_pointer) with
+ | Some active_pointer_id
+ when active_pointer_id = Lui_web_util.pointer_id event ->
+ toast_reset_swipe ctx;
+ toast_resume ctx
+ | _ -> ()
+
+let toast_key ctx event =
+ if
+ W.KeyboardEvent.key event = "F6"
+ && first_toast_node ctx.toast_renderer ctx.toast_element
+ then begin
+ W.KeyboardEvent.preventDefault event;
+ W.HtmlElement.focus
+ (W.Element.unsafeAsHtmlElement ctx.toast_element)
+ end
+
+let mount_toast renderer node toast =
+ let document = renderer.web_document in
+ let ctx = {
+ toast_renderer = renderer;
+ toast_node_id = node;
+ toast_element = toast;
+ toast_state = {
+ toast_timer = ref None;
+ pointer_inside = ref false;
+ focus_inside = ref false;
+ active_pointer = ref None;
+ start_x = ref None;
+ start_y = ref None;
+ current_x = ref 0;
+ current_y = ref 0;
+ toast_axis = ref None;
+ };
+ } in
+ let pointer_enter_handler event = toast_pointer_enter ctx event in
+ let pointer_leave_handler event = toast_pointer_leave ctx event in
+ let focus_in_handler event = toast_focus_in ctx event in
+ let focus_out_handler event = toast_focus_out ctx event in
+ let pointer_down_handler event = toast_pointer_down ctx event in
+ let pointer_move_handler event = toast_pointer_move ctx event in
+ let pointer_up_handler event = toast_pointer_up ctx event in
+ let pointer_cancel_handler event = toast_pointer_cancel ctx event in
+ let key_handler event = toast_key ctx event in
+ let previous_cleanup = Hashtbl.find_opt renderer.web_cleanups node in
+ toast_schedule ctx;
+ W.Element.addEventListener "pointerenter" pointer_enter_handler toast;
+ W.Element.addEventListener "pointerleave" pointer_leave_handler toast;
+ W.Element.addEventListener "focusin" focus_in_handler toast;
+ W.Element.addEventListener "focusout" focus_out_handler toast;
+ W.Element.addEventListener "pointerdown" pointer_down_handler toast;
+ W.Element.addEventListener "pointermove" pointer_move_handler toast;
+ W.Element.addEventListener "pointerup" pointer_up_handler toast;
+ W.Element.addEventListener "pointercancel" pointer_cancel_handler toast;
+ W.Document.addKeyDownEventListener key_handler document;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ (match previous_cleanup with
+ | Some cleanup -> cleanup ()
+ | None -> ());
+ toast_cancel ctx;
+ W.Element.removeEventListener
+ "pointerenter" pointer_enter_handler toast;
+ W.Element.removeEventListener
+ "pointerleave" pointer_leave_handler toast;
+ W.Element.removeEventListener "focusin" focus_in_handler toast;
+ W.Element.removeEventListener "focusout" focus_out_handler toast;
+ W.Element.removeEventListener
+ "pointerdown" pointer_down_handler toast;
+ W.Element.removeEventListener
+ "pointermove" pointer_move_handler toast;
+ W.Element.removeEventListener
+ "pointerup" pointer_up_handler toast;
+ W.Element.removeEventListener
+ "pointercancel" pointer_cancel_handler toast;
+ W.Document.removeKeyDownEventListener key_handler document;
+ ignore true)
+
+let mount_toast_bang = mount_toast
diff --git a/platform/web/melange/popup/lui_web_position.ml b/platform/web/melange/popup/lui_web_position.ml
new file mode 100644
index 00000000..5107e468
--- /dev/null
+++ b/platform/web/melange/popup/lui_web_position.ml
@@ -0,0 +1,421 @@
+(* Popup geometry, open/close transitions, select-item alignment, and the
+ submenu pointer corridor.
+ Source: /tmp/lui-web-ref/web.cljc lines 3137-3345 and 5439-5597. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+module Nodes = Lui_web_nodes
+
+(* melange-webapi exposes Window.matchMedia but no accessor for the result's
+ [matches] flag; this is a property getter, not a coercion. *)
+external media_query_list_matches : W.Window.mediaQueryList -> bool
+ = "matches" [@@mel.get]
+
+let css_px value = Js.Float.toString value ^ "px"
+
+let set_style element name value =
+ Util.set_style
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement element))
+ name value
+
+let clamp_popup_axis value size viewport_size =
+ let edge = 8.0 in
+ let maximum = max edge (viewport_size -. size -. edge) in
+ max edge (min value maximum)
+
+let resolved_popup_side preferred anchor_bounds popup_width popup_height
+ viewport_width viewport_height offset =
+ let above_space = W.DomRect.top anchor_bounds -. offset -. 8.0 in
+ let below_space =
+ viewport_height -. W.DomRect.bottom anchor_bounds -. offset -. 8.0
+ in
+ let left_space = W.DomRect.left anchor_bounds -. offset -. 8.0 in
+ let right_space =
+ viewport_width -. W.DomRect.right anchor_bounds -. offset -. 8.0
+ in
+ match preferred with
+ | "above" ->
+ if popup_height <= above_space || above_space >= below_space then
+ "above"
+ else "below"
+ | "left" ->
+ if popup_width <= left_space || left_space >= right_space then "left"
+ else "right"
+ | "right" ->
+ if popup_width <= right_space || right_space >= left_space then "right"
+ else "left"
+ | _ ->
+ if popup_height <= below_space || below_space >= above_space then
+ "below"
+ else "above"
+
+let position_anchored document positioner popup anchor_bounds preferred
+ alignment offset =
+ let root = W.Document.documentElement document in
+ let viewport_width = float_of_int (W.Element.clientWidth root) in
+ let viewport_height = float_of_int (W.Element.clientHeight root) in
+ let popup_bounds = W.Element.getBoundingClientRect popup in
+ let popup_element = W.Element.unsafeAsHtmlElement popup in
+ let popup_width =
+ 1.0
+ +. max
+ (float_of_int (W.HtmlElement.offsetWidth popup_element))
+ (W.DomRect.width popup_bounds)
+ in
+ let popup_height =
+ 1.0
+ +. max
+ (float_of_int (W.HtmlElement.offsetHeight popup_element))
+ (W.DomRect.height popup_bounds)
+ in
+ let side =
+ resolved_popup_side preferred anchor_bounds popup_width popup_height
+ viewport_width viewport_height offset
+ in
+ let vertical = side = "above" || side = "below" in
+ let aligned_left =
+ match alignment with
+ | "center" ->
+ W.DomRect.left anchor_bounds +. (W.DomRect.width anchor_bounds /. 2.0)
+ -. (popup_width /. 2.0)
+ | "end" -> W.DomRect.right anchor_bounds -. popup_width
+ | _ -> W.DomRect.left anchor_bounds
+ in
+ let aligned_top =
+ match alignment with
+ | "center" ->
+ W.DomRect.top anchor_bounds +. (W.DomRect.height anchor_bounds /. 2.0)
+ -. (popup_height /. 2.0)
+ | "end" -> W.DomRect.bottom anchor_bounds -. popup_height
+ | _ -> W.DomRect.top anchor_bounds
+ in
+ let left =
+ clamp_popup_axis
+ (if vertical then aligned_left
+ else if side = "left" then
+ W.DomRect.left anchor_bounds -. popup_width -. offset
+ else W.DomRect.right anchor_bounds +. offset)
+ popup_width viewport_width
+ in
+ let top =
+ clamp_popup_axis
+ (if vertical then
+ if side = "above" then
+ W.DomRect.top anchor_bounds -. popup_height -. offset
+ else W.DomRect.bottom anchor_bounds +. offset
+ else aligned_top)
+ popup_height viewport_height
+ in
+ W.Element.setAttribute "data-side" side positioner;
+ if not (W.Element.isSameNode (W.Element.asNode popup) positioner) then
+ W.Element.setAttribute "data-side" side popup;
+ set_style positioner "left" (css_px left);
+ set_style positioner "top" (css_px top)
+
+let position_anchored_bang = position_anchored
+
+let position_tooltip renderer node =
+ let tooltip = Nodes.dom_node renderer node in
+ let anchor = Nodes.dropdown_anchor_node renderer node in
+ let anchor_bounds = W.Element.getBoundingClientRect anchor in
+ let offset = Nodes.dropdown_offset renderer node in
+ let side = Nodes.dropdown_side tooltip in
+ let alignment =
+ match W.Element.getAttribute "data-anchor-alignment" tooltip with
+ | Some value -> value
+ | None -> "start"
+ in
+ position_anchored renderer.web_document tooltip tooltip anchor_bounds side
+ alignment offset
+
+let position_tooltip_bang = position_tooltip
+
+let begin_popup_open popup =
+ W.Element.removeAttribute "data-closed" popup;
+ W.Element.removeAttribute "data-ending-style" popup;
+ W.Element.setAttribute "data-open" "" popup;
+ W.Element.setAttribute "data-starting-style" "" popup;
+ Webapi.requestAnimationFrame (fun _time ->
+ W.Element.removeAttribute "data-starting-style" popup)
+
+let begin_popup_open_bang = begin_popup_open
+
+let begin_popup_close popup =
+ W.Element.removeAttribute "data-open" popup;
+ W.Element.setAttribute "data-closed" "" popup;
+ W.Element.setAttribute "data-ending-style" "" popup
+
+let begin_popup_close_bang = begin_popup_close
+
+let prefers_reduced_motion document =
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ match W.HtmlDocument.defaultView html_document with
+ | Some window ->
+ media_query_list_matches
+ (W.Window.matchMedia "(prefers-reduced-motion: reduce)" window)
+ | None -> false
+
+let prefers_reduced_motion_ = prefers_reduced_motion
+
+let transition_event_from target event =
+ W.Element.isSameNode
+ (W.Element.asNode
+ (W.EventTarget.unsafeAsElement (W.Event.target event)))
+ target
+
+let transition_event_from_ = transition_event_from
+
+let after_transition document target fallback_duration finish_on_cancel
+ complete =
+ if prefers_reduced_motion document then complete ()
+ else begin
+ let finished = ref false in
+ let timer = ref None in
+ let rec finish () =
+ if not !finished then begin
+ finished := true;
+ (match !timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ W.Element.removeEventListener "transitionend" transition_handler
+ target;
+ if finish_on_cancel then
+ W.Element.removeEventListener "transitioncancel" transition_handler
+ target;
+ complete ()
+ end
+ and transition_handler (event : Dom.event) =
+ if transition_event_from target event then finish ()
+ in
+ W.Element.addEventListener "transitionend" transition_handler target;
+ if finish_on_cancel then
+ W.Element.addEventListener "transitioncancel" transition_handler target;
+ timer :=
+ Some (Js.Global.setTimeout ~f:(fun () -> finish ()) fallback_duration)
+ end
+
+let after_transition_bang = after_transition
+
+let finish_popup_close_after_transition document popup duration =
+ after_transition document popup duration true (fun () ->
+ if W.Element.getAttribute "data-ending-style" popup = Some "" then
+ W.Element.removeAttribute "data-ending-style" popup)
+
+let finish_popup_close_after_transition_bang =
+ finish_popup_close_after_transition
+
+(* Select/combobox lookup helpers. The menu module owns the picker behavior,
+ but position sits below it in the layering, so the queries it needs are
+ replicated here against the retained store. *)
+let picker_under_parent renderer parent =
+ List.find_opt
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.standard_kind_is child_node Select
+ || Store.standard_kind_is child_node Combobox
+ | None -> false)
+ (Store.children renderer.web_store parent)
+
+let picker_for_dropdown renderer dropdown =
+ match Store.node renderer.web_store dropdown with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent -> picker_under_parent renderer parent
+ | None -> None)
+ | None -> None
+
+let picker_control_element renderer picker =
+ let picker_element = Nodes.dom_node renderer picker in
+ match Store.node renderer.web_store picker with
+ | Some current ->
+ if Store.standard_kind_is current Combobox then
+ Util.child_element picker_element 0
+ else picker_element
+ | None -> invalid_arg "unknown picker node"
+
+let picker_menu_items renderer dropdown =
+ match Store.node renderer.web_store dropdown with
+ | Some current ->
+ List.filter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some child_node ->
+ Store.menu_item_row child_node
+ && Store.enabled_node renderer child
+ | None -> false)
+ current.retained_children
+ | None -> []
+
+let picker_selected_index renderer dropdown =
+ let rec search items index =
+ match items with
+ | [] -> 0
+ | item :: rest ->
+ if Store.selected_property renderer item then index
+ else search rest (index + 1)
+ in
+ search (picker_menu_items renderer dropdown) 0
+
+let align_selected_menu_item renderer dropdown positioner popup anchor
+ anchor_bounds items =
+ let root = W.Document.documentElement renderer.web_document in
+ let viewport_width = float_of_int (W.Element.clientWidth root) in
+ let viewport_height = float_of_int (W.Element.clientHeight root) in
+ let edge_threshold = 20.0 in
+ if
+ W.DomRect.top anchor_bounds < edge_threshold
+ || W.DomRect.bottom anchor_bounds > viewport_height -. edge_threshold
+ then false
+ else begin
+ set_style popup "transition" "none";
+ set_style popup "transform" "none";
+ let selected =
+ Nodes.dom_node renderer
+ (List.nth items (picker_selected_index renderer dropdown))
+ in
+ let value = Util.child_element anchor 0 in
+ let label = Util.child_element selected 1 in
+ let positioner_bounds = W.Element.getBoundingClientRect positioner in
+ let popup_bounds = W.Element.getBoundingClientRect popup in
+ let value_bounds = W.Element.getBoundingClientRect value in
+ let label_bounds = W.Element.getBoundingClientRect label in
+ let value_center =
+ W.DomRect.top value_bounds +. (W.DomRect.height value_bounds /. 2.0)
+ in
+ let label_center =
+ W.DomRect.top label_bounds +. (W.DomRect.height label_bounds /. 2.0)
+ in
+ let left =
+ W.DomRect.left positioner_bounds
+ +. (W.DomRect.left value_bounds -. W.DomRect.left label_bounds)
+ in
+ let top =
+ W.DomRect.top positioner_bounds +. (value_center -. label_center)
+ in
+ let fits =
+ left >= 8.0
+ && left +. W.DomRect.width popup_bounds <= viewport_width -. 8.0
+ && top >= 8.0
+ && top +. W.DomRect.height popup_bounds <= viewport_height -. 8.0
+ in
+ set_style popup "transform" "";
+ set_style popup "transition" "";
+ if fits then begin
+ W.Element.setAttribute "data-side" "none" positioner;
+ W.Element.setAttribute "data-side" "none" popup;
+ set_style positioner "left" (css_px left);
+ set_style positioner "top" (css_px top);
+ true
+ end
+ else false
+ end
+
+let align_select_item_with_trigger renderer dropdown positioner popup anchor
+ anchor_bounds =
+ match picker_for_dropdown renderer dropdown with
+ | None -> false
+ | Some picker ->
+ (match Store.node renderer.web_store picker with
+ | None -> false
+ | Some picker_node ->
+ let control = picker_control_element renderer picker in
+ let open_method =
+ match W.Element.getAttribute "data-lui-open-method" control with
+ | Some value -> value
+ | None -> "keyboard"
+ in
+ let items = picker_menu_items renderer dropdown in
+ if
+ Store.standard_kind_is picker_node Select
+ && open_method <> "touch"
+ && items <> []
+ then
+ align_selected_menu_item renderer dropdown positioner popup
+ anchor anchor_bounds items
+ else false)
+
+let align_select_item_with_trigger_bang = align_select_item_with_trigger
+
+let position_dropdown renderer node =
+ let positioner = Nodes.dom_node renderer node in
+ let popup = Util.child_element positioner 0 in
+ let anchor = Nodes.dropdown_anchor_node renderer node in
+ let anchor_bounds = W.Element.getBoundingClientRect anchor in
+ let visible =
+ W.DomRect.width anchor_bounds > 0.0
+ || W.DomRect.height anchor_bounds > 0.0
+ in
+ Util.set_state_attribute positioner "hidden" (not visible);
+ if visible then begin
+ let offset = Nodes.dropdown_offset renderer node in
+ let side = Nodes.dropdown_side positioner in
+ let alignment =
+ match W.Element.getAttribute "data-anchor-alignment" positioner with
+ | Some value -> value
+ | None -> "start"
+ in
+ position_anchored renderer.web_document positioner popup anchor_bounds
+ side alignment offset;
+ ignore
+ (align_select_item_with_trigger renderer node positioner popup anchor
+ anchor_bounds)
+ end
+
+let position_dropdown_bang = position_dropdown
+
+let point_in_triangle point_x point_y ax ay bx by cx cy =
+ let cross_a =
+ ((point_x -. bx) *. (ay -. by)) -. ((ax -. bx) *. (point_y -. by))
+ in
+ let cross_b =
+ ((point_x -. cx) *. (by -. cy)) -. ((bx -. cx) *. (point_y -. cy))
+ in
+ let cross_c =
+ ((point_x -. ax) *. (cy -. ay)) -. ((cx -. ax) *. (point_y -. ay))
+ in
+ let has_negative = cross_a < 0.0 || cross_b < 0.0 || cross_c < 0.0 in
+ let has_positive = cross_a > 0.0 || cross_b > 0.0 || cross_c > 0.0 in
+ not (has_negative && has_positive)
+
+let point_in_triangle_ = point_in_triangle
+
+let submenu_corridor positioner popup leave_x leave_y point_x point_y =
+ let bounds = W.Element.getBoundingClientRect popup in
+ let buffer = 4.0 in
+ let side =
+ match W.Element.getAttribute "data-side" positioner with
+ | Some value -> value
+ | None -> Nodes.dropdown_side positioner
+ in
+ match side with
+ | "left" ->
+ point_in_triangle point_x point_y (leave_x +. buffer) leave_y
+ (W.DomRect.right bounds)
+ (W.DomRect.top bounds -. buffer)
+ (W.DomRect.right bounds)
+ (W.DomRect.bottom bounds +. buffer)
+ | "above" ->
+ point_in_triangle point_x point_y leave_x (leave_y +. buffer)
+ (W.DomRect.left bounds -. buffer)
+ (W.DomRect.bottom bounds)
+ (W.DomRect.right bounds +. buffer)
+ (W.DomRect.bottom bounds)
+ | "below" ->
+ point_in_triangle point_x point_y leave_x (leave_y -. buffer)
+ (W.DomRect.left bounds -. buffer)
+ (W.DomRect.top bounds)
+ (W.DomRect.right bounds +. buffer)
+ (W.DomRect.top bounds)
+ | _ ->
+ point_in_triangle point_x point_y (leave_x -. buffer) leave_y
+ (W.DomRect.left bounds)
+ (W.DomRect.top bounds -. buffer)
+ (W.DomRect.left bounds)
+ (W.DomRect.bottom bounds +. buffer)
+
+let submenu_corridor_ = submenu_corridor
diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml
new file mode 100644
index 00000000..a7d514d3
--- /dev/null
+++ b/platform/web/melange/render/lui_web_props.ml
@@ -0,0 +1,699 @@
+(* Property application for the LUI web (DOM) backend: apply_property! and
+ remove_property! plus the DOM refresh helpers they share. Ported from
+ web.cljc — see PORTING.md. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+module Widgets = Lui_web_widgets
+module Focus = Lui_web_focus
+module Nodes = Lui_web_nodes
+
+let set_style dom_node name value =
+ let scope = W.HtmlElement.style (W.Element.unsafeAsHtmlElement dom_node) in
+ Util.set_style scope name value
+
+(* webapi declares mediaQueryList but exposes no `matches` accessor; the LG
+ source read it through a dict lookup on the same value. *)
+external media_query_matches : W.Window.mediaQueryList -> bool = "matches"
+ [@@mel.get]
+
+let prefers_reduced_motion document =
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ match W.HtmlDocument.defaultView html_document with
+ | Some window ->
+ media_query_matches
+ (W.Window.matchMedia "(prefers-reduced-motion: reduce)" window)
+ | None -> false
+
+let transition_event_from target event =
+ W.Element.isSameNode
+ (W.Element.asNode
+ (W.EventTarget.unsafeAsElement (W.Event.target event)))
+ target
+
+let after_transition document target fallback_duration finish_on_cancel
+ complete =
+ if prefers_reduced_motion document then complete ()
+ else begin
+ let finished = ref false in
+ let timer = ref None in
+ let finish_ref = ref (fun () -> ()) in
+ let transition_handler event =
+ if transition_event_from target event then !finish_ref ()
+ in
+ let finish () =
+ if not !finished then begin
+ finished := true;
+ (match !timer with
+ | Some timer_id -> Js.Global.clearTimeout timer_id
+ | None -> ());
+ W.Element.removeEventListener "transitionend" transition_handler
+ target;
+ if finish_on_cancel then
+ W.Element.removeEventListener "transitioncancel" transition_handler
+ target;
+ complete ()
+ end
+ in
+ finish_ref := finish;
+ W.Element.addEventListener "transitionend" transition_handler target;
+ if finish_on_cancel then
+ W.Element.addEventListener "transitioncancel" transition_handler target;
+ timer := Some (Js.Global.setTimeout ~f:finish fallback_duration)
+ end
+
+let finish_accordion_close panel =
+ if W.Element.hasAttribute "data-ending-style" panel then begin
+ W.Element.removeAttribute "data-ending-style" panel;
+ W.Element.setAttribute "hidden" "" panel
+ end
+
+let open_accordion renderer dom_node panel =
+ W.Element.removeAttribute "data-closed" dom_node;
+ W.Element.setAttribute "data-open" "" dom_node;
+ W.Element.removeAttribute "hidden" panel;
+ W.Element.removeAttribute "data-closed" panel;
+ W.Element.removeAttribute "data-ending-style" panel;
+ W.Element.setAttribute "data-open" "" panel;
+ set_style panel "--lui-accordion-panel-height"
+ (string_of_int (W.Element.scrollHeight panel) ^ "px");
+ W.Element.setAttribute "data-starting-style" "" panel;
+ Webapi.requestAnimationFrame (fun _time ->
+ if W.Element.hasAttribute "data-open" panel then
+ W.Element.removeAttribute "data-starting-style" panel);
+ if prefers_reduced_motion renderer.web_document then
+ set_style panel "--lui-accordion-panel-height" "auto"
+ else
+ ignore
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ if W.Element.hasAttribute "data-open" panel then
+ set_style panel "--lui-accordion-panel-height" "auto")
+ 190)
+
+let close_accordion renderer dom_node panel =
+ W.Element.removeAttribute "data-open" dom_node;
+ W.Element.setAttribute "data-closed" "" dom_node;
+ if not (W.Element.hasAttribute "hidden" panel) then begin
+ set_style panel "--lui-accordion-panel-height"
+ (string_of_int (W.Element.scrollHeight panel) ^ "px");
+ ignore
+ (W.HtmlElement.offsetHeight (W.Element.unsafeAsHtmlElement panel));
+ W.Element.removeAttribute "data-open" panel;
+ W.Element.removeAttribute "data-starting-style" panel;
+ W.Element.setAttribute "data-closed" "" panel;
+ if prefers_reduced_motion renderer.web_document then begin
+ W.Element.setAttribute "data-ending-style" "" panel;
+ finish_accordion_close panel
+ end
+ else begin
+ after_transition renderer.web_document panel 190 false
+ (fun () -> finish_accordion_close panel);
+ W.Element.setAttribute "data-ending-style" "" panel
+ end
+ end
+
+let set_accordion_open renderer _node dom_node opened =
+ let trigger = Util.accordion_trigger_node dom_node in
+ let panel = Util.accordion_panel_node dom_node in
+ W.Element.setAttribute "aria-expanded"
+ (if opened then "true" else "false") trigger;
+ if opened then open_accordion renderer dom_node panel
+ else close_accordion renderer dom_node panel
+
+let set_accordion_open_bang = set_accordion_open
+
+let main_alignment_value alignment =
+ match alignment with
+ | "start" -> "flex-start"
+ | "center" -> "center"
+ | "end" -> "flex-end"
+ | "space_between" -> "space-between"
+ | _ -> invalid_arg "invalid main alignment"
+
+let cross_alignment_value alignment =
+ match alignment with
+ | "stretch" -> "stretch"
+ | "start" -> "flex-start"
+ | "center" -> "center"
+ | "end" -> "flex-end"
+ | _ -> invalid_arg "invalid cross alignment"
+
+let select_display_text renderer node =
+ match Store.property renderer.web_store node TextValue with
+ | Some (StringValue text) ->
+ if text <> "" then text
+ else
+ (match Store.property renderer.web_store node PlaceholderValue with
+ | Some (StringValue placeholder) -> placeholder
+ | _ -> "")
+ | _ ->
+ (match Store.property renderer.web_store node PlaceholderValue with
+ | Some (StringValue placeholder) -> placeholder
+ | _ -> "")
+
+let refresh_node_class renderer node kind dom_node =
+ let style_class =
+ match Store.property renderer.web_store node StyleClass with
+ | Some (StringValue value) -> value
+ | _ -> ""
+ in
+ let tree_class =
+ if Store.treeitem renderer node then "lui-tree-item" else ""
+ in
+ W.Element.setClassName
+ (if kind = DropdownMenu then Util.child_element dom_node 0 else dom_node)
+ (String.trim
+ (Nodes.base_class_name kind ^ " " ^ tree_class ^ " " ^ style_class))
+
+let refresh_node_class_bang = refresh_node_class
+
+let set_text_control_value dom_node text =
+ let control = Util.text_control_node dom_node in
+ if text <> W.HtmlInputElement.value control then
+ W.HtmlInputElement.setValue control text
+
+let set_visible_text kind dom_node text =
+ let target =
+ if Store.direct_toggle kind then Util.toggle_label_node dom_node
+ else if
+ Store.button_like kind || kind = MenuItem || kind = MenuTrigger
+ then Util.button_label_node dom_node
+ else dom_node
+ in
+ if text <> W.Element.textContent target then
+ W.Element.setTextContent target text
+
+let apply_text_value renderer node kind dom_node text =
+ match kind with
+ | Alert -> W.Element.setTextContent (Util.child_element dom_node 0) text
+ | Bubble -> W.Element.setTextContent (Util.child_element dom_node 1) text
+ | Accordion ->
+ W.Element.setTextContent (Util.accordion_label_node dom_node) text
+ | Step ->
+ W.Element.setTextContent (Util.child_element dom_node 1) text;
+ Widgets.update_stepper_parent renderer node
+ | Dialog | Sheet ->
+ W.Element.setTextContent
+ (Util.child_element (Util.child_element dom_node 0) 0) text
+ | Avatar ->
+ W.Element.setTextContent (Util.child_element dom_node 1) text;
+ Widgets.update_avatar renderer node dom_node
+ | Select ->
+ W.Element.setTextContent
+ (Util.child_element dom_node 0)
+ (select_display_text renderer node)
+ | TextField | SecureField | Input | SearchField | Textarea | Combobox ->
+ set_text_control_value dom_node text
+ | _ -> set_visible_text kind dom_node text
+
+let apply_text_value_bang = apply_text_value
+
+let apply_enabled renderer node kind dom_node enabled =
+ if kind = BottomTab then begin
+ (match Widgets.bottom_tab_trigger renderer node with
+ | Some trigger ->
+ if enabled then begin
+ W.Element.removeAttribute "disabled" trigger;
+ W.Element.setAttribute "aria-disabled" "false" trigger
+ end
+ else begin
+ W.Element.setAttribute "disabled" "disabled" trigger;
+ W.Element.setAttribute "aria-disabled" "true" trigger
+ end
+ | None -> ());
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent -> Widgets.refresh_bottom_tabs renderer parent
+ | None -> ())
+ | None -> ()
+ end
+ else begin
+ let control_node =
+ if Store.direct_toggle kind then Util.child_element dom_node 0
+ else if kind = Combobox then Util.child_element dom_node 0
+ else dom_node
+ in
+ if enabled then W.Element.removeAttribute "disabled" control_node
+ else W.Element.setAttribute "disabled" "disabled" control_node;
+ if kind = Combobox then begin
+ let trigger = Util.child_element dom_node 1 in
+ if enabled then W.Element.removeAttribute "disabled" trigger
+ else W.Element.setAttribute "disabled" "disabled" trigger;
+ Util.set_state_attribute dom_node "data-disabled" (not enabled)
+ end;
+ if Store.direct_toggle kind then
+ Util.set_state_attribute dom_node "data-disabled" (not enabled);
+ if Store.treeitem renderer node then
+ W.Element.setAttribute "aria-disabled"
+ (if enabled then "false" else "true") dom_node;
+ if Store.node_has_ancestor_kind renderer.web_store node Toolbar then
+ ignore
+ (Focus.apply_toolbar_disabled_semantics renderer node)
+ end
+
+let apply_grid_columns dom_node columns =
+ if columns = 0 then begin
+ set_style dom_node "grid-auto-flow" "column";
+ set_style dom_node "grid-auto-columns" "minmax(0, 1fr)";
+ set_style dom_node "grid-template-columns" "none"
+ end
+ else begin
+ set_style dom_node "grid-auto-flow" "row";
+ set_style dom_node "grid-auto-columns" "auto";
+ set_style dom_node "grid-template-columns"
+ ("repeat(" ^ string_of_int columns ^ ", minmax(0, 1fr))")
+ end
+
+let apply_gap renderer node kind dom_node gap =
+ if kind = Split then Lui_web_split.update_split renderer node
+ else set_style dom_node "gap" (string_of_int gap ^ "px");
+ if kind = TableRow then
+ set_style dom_node "--lui-table-gap" (string_of_int gap ^ "px")
+
+let apply_placeholder renderer node kind dom_node placeholder =
+ if kind = Select then
+ W.Element.setTextContent
+ (Util.child_element dom_node 0)
+ (select_display_text renderer node)
+ else
+ W.HtmlInputElement.setPlaceholder (Util.text_control_node dom_node)
+ placeholder
+
+let apply_accessibility_label kind dom_node label =
+ if kind = BottomTabs then
+ W.Element.setAttribute "aria-label" label
+ (Util.bottom_tabs_bar_node dom_node)
+ else if kind = Split then
+ W.Element.setAttribute "aria-label" (label ^ " divider")
+ (Util.child_element dom_node 1)
+ else
+ W.Element.setAttribute "aria-label" label
+ (if Store.direct_toggle kind then Util.child_element dom_node 0
+ else dom_node)
+
+let apply_checked kind dom_node checked =
+ if kind = Toggle then begin
+ Util.set_state_attribute dom_node "data-checked" checked;
+ W.Element.setAttribute "aria-pressed"
+ (if checked then "true" else "false") dom_node
+ end
+ else begin
+ W.HtmlInputElement.setChecked (Util.text_control_node dom_node) checked;
+ Util.set_state_attribute dom_node "data-checked" checked;
+ W.Element.setAttribute "aria-checked"
+ (if checked then "true" else "false") (Util.child_element dom_node 0)
+ end
+
+let apply_progress_value renderer node kind dom_node value =
+ if kind = Split then Lui_web_split.reconcile_split renderer node dom_node value
+ else if kind = Progress then Widgets.update_progress renderer node dom_node
+ else
+ W.HtmlInputElement.setValue (Util.text_control_node dom_node)
+ (Js.Float.toString value)
+
+let apply_inline_icon_name renderer node kind dom_node name =
+ if kind = BottomTab then
+ (match Widgets.bottom_tab_trigger renderer node with
+ | Some trigger ->
+ let icon = Util.child_element trigger 0 in
+ W.Element.setAttribute "data-name" name icon;
+ Widgets.update_icon_name renderer icon name
+ | None -> ())
+ else if kind = TimelineItem then
+ Widgets.update_timeline_indicator renderer node dom_node
+ else begin
+ let icon =
+ if kind = ListItem then dom_node else Util.button_icon_node dom_node
+ in
+ W.Element.setAttribute "data-name" name icon;
+ Widgets.update_icon_name renderer icon name
+ end
+
+let apply_selected renderer node kind dom_node selected =
+ if kind = BottomTab then
+ (match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent -> Widgets.refresh_bottom_tabs renderer parent
+ | None -> ())
+ | None -> ())
+ else if kind = Accordion then
+ set_accordion_open renderer node dom_node selected
+ else if
+ kind = TableRow || kind = TimelineItem || Store.treeitem renderer node
+ then begin
+ Util.set_state_attribute dom_node "data-selected" selected;
+ W.Element.setAttribute "aria-selected"
+ (if selected then "true" else "false") dom_node
+ end
+ else begin
+ Util.set_state_attribute dom_node "data-selected" selected;
+ W.Element.setAttribute
+ (if kind = MenuItem || Focus.direct_tab_trigger renderer node then
+ "aria-selected"
+ else "aria-pressed")
+ (if selected then "true" else "false") dom_node
+ end
+
+let apply_autofocus dom_node autofocus =
+ if autofocus then begin
+ W.Element.setAttribute "autofocus" "autofocus" dom_node;
+ ignore
+ (Js.Global.setTimeout
+ ~f:(fun () ->
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement dom_node))
+ 0)
+ end
+ else W.Element.removeAttribute "autofocus" dom_node
+
+let apply_pressable_target kind dom_node enabled =
+ if kind = Text then begin
+ Util.set_state_attribute dom_node "data-pressable" enabled;
+ if enabled then begin
+ W.Element.setAttribute "role" "button" dom_node;
+ W.Element.setAttribute "tabindex" "0" dom_node
+ end
+ else begin
+ W.Element.removeAttribute "role" dom_node;
+ W.Element.removeAttribute "tabindex" dom_node
+ end
+ end
+
+let apply_pressable_cell kind dom_node enabled =
+ if kind = TableCell then begin
+ Util.set_state_attribute dom_node "data-pressable" enabled;
+ if enabled then W.Element.setAttribute "tabindex" "0" dom_node
+ else W.Element.removeAttribute "tabindex" dom_node
+ end
+
+let apply_pressable_timeline_item kind dom_node enabled =
+ if kind = TimelineItem then begin
+ Util.set_state_attribute dom_node "data-pressable" enabled;
+ if enabled then begin
+ W.Element.setAttribute "tabindex" "0" dom_node;
+ W.Element.removeAttribute "hidden" (Util.child_element dom_node 2)
+ end
+ else begin
+ W.Element.removeAttribute "tabindex" dom_node;
+ W.Element.setAttribute "hidden" "" (Util.child_element dom_node 2)
+ end
+ end
+
+let apply_press_enabled kind dom_node enabled =
+ Util.set_state_attribute dom_node "data-press-enabled" enabled;
+ apply_pressable_target kind dom_node enabled;
+ apply_pressable_cell kind dom_node enabled;
+ apply_pressable_timeline_item kind dom_node enabled;
+ if kind = BottomTab then
+ Util.set_state_attribute dom_node "data-press-enabled" enabled
+
+let apply_title renderer node kind dom_node title =
+ if kind = BottomTab then
+ (match Widgets.bottom_tab_trigger renderer node with
+ | Some trigger ->
+ W.Element.setTextContent (Util.child_element trigger 1) title
+ | None -> ())
+ else begin
+ W.Element.setTextContent
+ (Util.child_element (Util.child_element dom_node 1) 0)
+ title;
+ W.Element.setAttribute "aria-label" title dom_node
+ end
+
+let apply_media_source renderer node kind dom_node =
+ if kind = Avatar then Widgets.update_avatar renderer node dom_node
+ else Widgets.update_image renderer node dom_node
+
+(* container-relative-frame: fills (or min-sizes against) the nearest
+ container. Axes and inset arrive as separate properties, so each is cached
+ on the element and the styles recomputed on either update. *)
+let apply_container_frame dom_node axes inset =
+ let inset_px = "calc(100% - " ^ string_of_int inset ^ "px)" in
+ match axes with
+ | "horizontal" -> set_style dom_node "width" "100%"
+ | "vertical" -> set_style dom_node "height" "100%"
+ | "both" ->
+ set_style dom_node "width" "100%";
+ set_style dom_node "height" "100%"
+ | "min-horizontal" -> set_style dom_node "min-width" inset_px
+ | "min-vertical" -> set_style dom_node "min-height" inset_px
+ | "min-both" ->
+ set_style dom_node "min-width" inset_px;
+ set_style dom_node "min-height" inset_px
+ | _ -> ()
+
+let apply_frame_axes dom_node axes =
+ W.Element.setAttribute "data-lui-frame-axes" axes dom_node;
+ let inset =
+ match W.Element.getAttribute "data-lui-frame-inset" dom_node with
+ | Some value -> int_of_string_opt value |> Option.value ~default:0
+ | None -> 0
+ in
+ apply_container_frame dom_node axes inset
+
+let apply_frame_inset dom_node inset =
+ W.Element.setAttribute "data-lui-frame-inset" (string_of_int inset) dom_node;
+ match W.Element.getAttribute "data-lui-frame-axes" dom_node with
+ | Some axes -> apply_container_frame dom_node axes inset
+ | None -> ()
+
+let apply_anchor_offset kind dom_node offset =
+ set_style dom_node "--lui-anchor-offset" (Js.Float.toString offset ^ "px");
+ if kind = Tooltip then
+ W.Element.setAttribute "data-anchor-offset"
+ (Js.Float.toString offset) dom_node
+
+let rec apply_property renderer node kind dom_node property value =
+ match (property, value) with
+ | TextValue, StringValue text ->
+ apply_text_value renderer node kind dom_node text
+ | Enabled, BoolValue enabled ->
+ apply_enabled renderer node kind dom_node enabled
+ | Gap, IntValue gap -> apply_gap renderer node kind dom_node gap
+ | MainAlignment, StringValue alignment ->
+ set_style dom_node "justify-content" (main_alignment_value alignment)
+ | CrossAlignment, StringValue alignment ->
+ set_style dom_node "align-items" (cross_alignment_value alignment)
+ | GrowValue, FloatValue grow ->
+ set_style dom_node "flex-grow" (Js.Float.toString grow)
+ | GridColumns, IntValue columns -> apply_grid_columns dom_node columns
+ | PaddingValue, IntValue padding ->
+ set_style dom_node "padding" (string_of_int padding ^ "px");
+ set_style dom_node "--lui-content-padding"
+ (string_of_int padding ^ "px")
+ | PaddingHorizontal, IntValue padding ->
+ set_style dom_node "padding-inline" (string_of_int padding ^ "px")
+ | PaddingVertical, IntValue padding ->
+ set_style dom_node "padding-block" (string_of_int padding ^ "px")
+ | BackgroundValue, StringValue background ->
+ set_style dom_node "background" (Util.web_color_value background)
+ | ForegroundValue, StringValue foreground ->
+ set_style dom_node "color" (Util.web_color_value foreground)
+ | BorderColorValue, StringValue border ->
+ set_style dom_node "border-color" (Util.web_color_value border)
+ | BorderWidth, IntValue width ->
+ set_style dom_node "border-style" "solid";
+ set_style dom_node "border-width" (string_of_int width ^ "px")
+ | CornerRadius, IntValue radius ->
+ set_style dom_node "border-radius" (string_of_int radius ^ "px")
+ | WidthValue, IntValue width ->
+ set_style dom_node "width" (string_of_int width ^ "px");
+ if kind = Image then Widgets.update_image renderer node dom_node;
+ if kind = Bubble then
+ W.Element.setAttribute "data-width" "explicit" dom_node
+ | HeightValue, IntValue height ->
+ set_style dom_node "height" (string_of_int height ^ "px");
+ if kind = Image then Widgets.update_image renderer node dom_node
+ | MinWidth, IntValue width ->
+ set_style dom_node "min-width" (string_of_int width ^ "px")
+ | MaxWidth, IntValue width ->
+ set_style dom_node "max-width" (string_of_int width ^ "px")
+ | MinHeight, IntValue height ->
+ set_style dom_node "min-height" (string_of_int height ^ "px")
+ | MaxHeight, IntValue height ->
+ set_style dom_node "max-height" (string_of_int height ^ "px")
+ | PlaceholderValue, StringValue placeholder ->
+ apply_placeholder renderer node kind dom_node placeholder
+ | AccessibilityLabel, StringValue label ->
+ apply_accessibility_label kind dom_node label
+ | AccessibilityIdentifier, StringValue identifier ->
+ W.Element.setAttribute "id" identifier dom_node
+ | StyleClass, StringValue _class_name ->
+ refresh_node_class renderer node kind dom_node
+ | HeadingLevel, IntValue level ->
+ W.Element.setAttribute "aria-level" (string_of_int level) dom_node
+ | _ -> apply_secondary_property renderer node kind dom_node property value
+
+and apply_secondary_property renderer node kind dom_node property value =
+ match (property, value) with
+ | Checked, BoolValue checked -> apply_checked kind dom_node checked
+ | ProgressValue, FloatValue value ->
+ apply_progress_value renderer node kind dom_node value
+ | ResizeDuration, IntValue _duration ->
+ Lui_web_split.update_split renderer node
+ | ResizeEasing, StringValue _easing ->
+ Lui_web_split.update_split renderer node
+ | ResizeOrigin, FloatValue _origin ->
+ Lui_web_split.update_split renderer node
+ | OrientationValue, StringValue orientation ->
+ W.Element.setAttribute "data-orientation" orientation dom_node;
+ W.Element.setAttribute "aria-orientation" orientation dom_node
+ | SizeValue, StringValue size ->
+ W.Element.setAttribute "data-size" size dom_node
+ | IconName, StringValue name ->
+ W.Element.setAttribute "data-name" name dom_node;
+ Widgets.update_icon_name renderer dom_node name
+ | VariantValue, StringValue variant ->
+ W.Element.setAttribute "data-variant" variant dom_node
+ | InlineIconName, StringValue name ->
+ apply_inline_icon_name renderer node kind dom_node name
+ | IconPlacementValue, StringValue placement ->
+ W.Element.setAttribute "data-icon-placement" placement dom_node
+ | Selected, BoolValue selected ->
+ apply_selected renderer node kind dom_node selected
+ | Autofocus, BoolValue autofocus -> apply_autofocus dom_node autofocus
+ | SubmitOnEnter, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-submit-on-enter" enabled
+ | LongPressEnabled, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-long-press-enabled" enabled
+ | ChangeEnabled, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-change-enabled" enabled
+ | ToggleEnabled, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-toggle-enabled" enabled
+ | PressEnabled, BoolValue enabled ->
+ apply_press_enabled kind dom_node enabled
+ | RoleValue, StringValue role ->
+ W.Element.setAttribute "role" role dom_node;
+ W.Element.removeAttribute "aria-pressed" dom_node;
+ refresh_node_class renderer node kind dom_node
+ | TreeLevel, IntValue level ->
+ W.Element.setAttribute "aria-level" (string_of_int level) dom_node
+ | Expanded, BoolValue expanded ->
+ Util.set_state_attribute dom_node "data-expanded" expanded;
+ W.Element.setAttribute "aria-expanded"
+ (if expanded then "true" else "false") dom_node
+ | SubmitEnabled, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-submit-enabled" enabled
+ | DoublePressEnabled, BoolValue enabled ->
+ Util.set_state_attribute dom_node "data-double-press-enabled" enabled
+ | ImageIdValue, IntValue _image_id ->
+ apply_media_source renderer node kind dom_node
+ | SurfaceIdValue, IntValue _surface_id ->
+ Widgets.update_media_surface renderer node dom_node
+ | ActiveIndex, IntValue _active ->
+ Widgets.update_stepper renderer node
+ | TitleValue, StringValue title ->
+ apply_title renderer node kind dom_node title
+ | DescriptionValue, StringValue description ->
+ Util.set_optional_text
+ (if modal_surface kind then
+ Util.child_element (Util.child_element dom_node 0) 1
+ else Util.child_element (Util.child_element dom_node 1) 1)
+ description
+ | MetaValue, StringValue meta ->
+ Util.set_optional_text
+ (Util.child_element (Util.child_element dom_node 1) 2)
+ meta
+ | IndicatorValue, StringValue _indicator ->
+ Widgets.update_timeline_indicator renderer node dom_node
+ | Connector, BoolValue connector ->
+ Util.set_state_attribute
+ (Util.child_element (Util.child_element dom_node 0) 1)
+ "hidden" (not connector)
+ | SourceX, FloatValue _value | SourceY, FloatValue _value
+ | SourceWidth, FloatValue _value | SourceHeight, FloatValue _value ->
+ apply_media_source renderer node kind dom_node
+ | AnchorValue, StringValue anchor ->
+ W.Element.setAttribute "data-anchor" anchor dom_node;
+ if kind = Tooltip then
+ W.Element.setAttribute "data-anchor-alignment" "start" dom_node
+ | AnchorAlignmentValue, StringValue alignment ->
+ W.Element.setAttribute "data-anchor-alignment" alignment dom_node
+ | AnchorOffset, FloatValue offset ->
+ apply_anchor_offset kind dom_node offset
+ | TooltipDelay, IntValue delay ->
+ W.Element.setAttribute "data-tooltip-delay"
+ (string_of_int delay) dom_node
+ | DurationValue, IntValue duration ->
+ W.Element.setAttribute "data-duration" (string_of_int duration)
+ dom_node
+ | TextAlignment, StringValue alignment ->
+ if kind = Bubble then
+ W.Element.setAttribute "data-reactions-alignment" alignment dom_node
+ else set_style dom_node "text-align" alignment
+ | ContainerRelativeFrameValue, StringValue axes ->
+ apply_frame_axes dom_node axes
+ | ContainerRelativeFrameInset, IntValue inset ->
+ apply_frame_inset dom_node inset
+ | _ ->
+ invalid_arg
+ ("invalid DOM property value: " ^ Lui_wire_schema.property_name property)
+
+let apply_property_bang = apply_property
+
+let remove_property renderer node kind dom_node property =
+ match Store.node renderer.web_store node with
+ | Some _current ->
+ (match property with
+ | TextValue -> apply_text_value renderer node kind dom_node ""
+ | Enabled ->
+ apply_property renderer node kind dom_node Enabled
+ (BoolValue true)
+ | Gap -> set_style dom_node "gap" ""
+ | MainAlignment -> set_style dom_node "justify-content" ""
+ | CrossAlignment -> set_style dom_node "align-items" ""
+ | GrowValue -> set_style dom_node "flex-grow" ""
+ | GridColumns ->
+ set_style dom_node "grid-auto-flow" "";
+ set_style dom_node "grid-auto-columns" "";
+ set_style dom_node "grid-template-columns" ""
+ | PaddingValue ->
+ set_style dom_node "padding" "";
+ set_style dom_node "--lui-content-padding" ""
+ | PaddingHorizontal -> set_style dom_node "padding-inline" ""
+ | PaddingVertical -> set_style dom_node "padding-block" ""
+ | BackgroundValue -> set_style dom_node "background" ""
+ | ForegroundValue -> set_style dom_node "color" ""
+ | BorderColorValue -> set_style dom_node "border-color" ""
+ | BorderWidth ->
+ set_style dom_node "border-style" "";
+ set_style dom_node "border-width" ""
+ | CornerRadius -> set_style dom_node "border-radius" ""
+ | WidthValue -> set_style dom_node "width" ""
+ | HeightValue -> set_style dom_node "height" ""
+ | MinWidth -> set_style dom_node "min-width" ""
+ | MaxWidth -> set_style dom_node "max-width" ""
+ | MinHeight -> set_style dom_node "min-height" ""
+ | MaxHeight -> set_style dom_node "max-height" ""
+ | ContainerRelativeFrameValue ->
+ W.Element.removeAttribute "data-lui-frame-axes" dom_node;
+ set_style dom_node "width" "";
+ set_style dom_node "height" "";
+ set_style dom_node "min-width" "";
+ set_style dom_node "min-height" ""
+ | ContainerRelativeFrameInset ->
+ W.Element.removeAttribute "data-lui-frame-inset" dom_node
+ | PlaceholderValue ->
+ W.HtmlInputElement.setPlaceholder (Util.text_control_node dom_node)
+ ""
+ | AccessibilityLabel ->
+ W.Element.removeAttribute "aria-label"
+ (if Store.direct_toggle kind then Util.child_element dom_node 0
+ else dom_node)
+ | AccessibilityIdentifier -> W.Element.removeAttribute "id" dom_node
+ | OrientationValue ->
+ if kind = Tabs then begin
+ W.Element.setAttribute "data-orientation" "horizontal" dom_node;
+ W.Element.setAttribute "aria-orientation" "horizontal" dom_node
+ end
+ | StyleClass -> refresh_node_class renderer node kind dom_node
+ | _ -> ())
+ | None -> invalid_arg "unknown DOM node"
+
+let remove_property_bang = remove_property
diff --git a/platform/web/melange/shell/lui_web.ml b/platform/web/melange/shell/lui_web.ml
new file mode 100644
index 00000000..fb9dac88
--- /dev/null
+++ b/platform/web/melange/shell/lui_web.ml
@@ -0,0 +1,169 @@
+(* Public surface of the LUI web DOM backend: renderer construction, the
+ Lui_protocol backend, mount, and the query API. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+
+let create_with_extensions host app_icons registry adapters =
+ let document =
+ match W.Element.ownerDocument host with
+ | document -> document
+ in
+ let portal_root = W.Document.createElement "div" document in
+ let toast_viewport = W.Document.createElement "div" document in
+ let html_document = W.Document.unsafeAsHtmlDocument document in
+ W.Element.setClassName portal_root "lui-popup-portal";
+ W.Element.setClassName toast_viewport "lui-toast-viewport";
+ W.Element.setAttribute "role" "region" toast_viewport;
+ W.Element.setAttribute "aria-label" "Notifications" toast_viewport;
+ W.Element.setAttribute "tabindex" "-1" toast_viewport;
+ W.Element.appendChild (W.Element.asNode toast_viewport) portal_root;
+ W.Element.setAttribute "data-lui-root" "" host;
+ (match W.HtmlDocument.body html_document with
+ | Some body -> W.Element.appendChild (W.Element.asNode portal_root) body
+ | None -> invalid_arg "document body is unavailable");
+ let web_extension_adapters = Hashtbl.create 8 in
+ String_map.iter
+ (fun name adapter -> Hashtbl.replace web_extension_adapters name adapter)
+ adapters;
+ { web_store = Store.create_store ();
+ web_document = document;
+ web_host = host;
+ web_portal_root = portal_root;
+ web_simulator_platform = ref None;
+ web_simulator_device = ref None;
+ web_simulator_keyboard_visible = ref false;
+ web_toast_viewport = toast_viewport;
+ web_event_handler = ref (fun _event -> true);
+ web_app_icons = app_icons;
+ web_images = Hashtbl.create 8;
+ web_media_surfaces = Hashtbl.create 4;
+ web_cleanups = Hashtbl.create 8;
+ web_modal_stack = ref [];
+ web_modal_return_focus = ref None;
+ web_open_tooltip = ref None;
+ web_tooltip_warm = ref false;
+ web_open_context_menu = ref None;
+ web_splits = Hashtbl.create 4;
+ web_extension_registry = registry;
+ web_extension_adapters }
+
+let create_simulator_with_extensions host platform app_icons registry adapters =
+ let renderer = create_with_extensions host app_icons registry adapters in
+ ignore (Lui_web_simulator.set_simulator_platform renderer platform);
+ ignore
+ (Lui_web_simulator.set_simulator_device renderer
+ (Lui_web_simulator.simulator_device platform SimulatorPhone
+ SimulatorPortrait));
+ ignore (Lui_web_simulator.attach_simulator_keyboard_events renderer);
+ renderer
+
+let create_simulator ?(app_icons = String_map.empty) host platform =
+ create_simulator_with_extensions host platform app_icons
+ (Lui_extension.registry ()) String_map.empty
+
+let create ?(app_icons = String_map.empty) host =
+ create_with_extensions host app_icons (Lui_extension.registry ())
+ String_map.empty
+
+let extension_adapter = Lui_web_extensions.extension_adapter
+let extension_platform_node = Lui_web_extensions.extension_platform_node
+
+let apply_extension_property =
+ Lui_web_extensions.apply_extension_property
+
+let remove_extension_property =
+ Lui_web_extensions.remove_extension_property
+
+let cleanup_extension_node = Lui_web_extensions.cleanup_extension_node
+
+let set_event_handler renderer handler =
+ renderer.web_event_handler := handler;
+ true
+
+let backend renderer =
+ { backend_profile = profile WebOS WebHost;
+ apply_batch =
+ (fun batch ->
+ let previous_nodes = Hashtbl.copy renderer.web_store.retained_nodes in
+ (try
+ ignore
+ (Store.apply_batch_with_extensions renderer.web_store
+ (fun kind -> Lui_web_nodes.platform_node renderer kind)
+ (fun node identifier ->
+ Lui_web_extensions.extension_platform_node renderer node
+ identifier)
+ renderer.web_extension_registry (fun _batch -> true) batch)
+ with Invalid_argument msg -> invalid_arg ("store batch: " ^ msg));
+ (try Lui_web_apply.apply_dom_batch renderer previous_nodes batch
+ with Invalid_argument msg -> invalid_arg ("dom batch: " ^ msg));
+ true) }
+
+let mount renderer root host =
+ W.Element.appendChild
+ (W.Element.asNode (Lui_web_nodes.dom_node renderer root))
+ host;
+ Lui_web_split.update_splits_under renderer root
+
+let rec first_section_title renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ let kind = Store.standard_kind current in
+ let title = Store.property renderer.web_store node TextValue in
+ let title_text =
+ match title with
+ | Some (StringValue value) when value <> "" -> Some value
+ | _ -> None
+ in
+ if (kind = Some Heading || kind = Some Text) && title_text <> None then
+ title_text
+ else
+ let rec search = function
+ | [] -> None
+ | child :: rest ->
+ (match first_section_title renderer child with
+ | Some _ as found -> found
+ | None -> search rest)
+ in
+ search current.retained_children
+ | None -> None
+
+let root_sections renderer root =
+ let store = renderer.web_store in
+ let root_children = Store.children store root in
+ let children =
+ match Store.node store root with
+ | Some current ->
+ if
+ Store.standard_kind current = Some Root
+ && List.length root_children = 1
+ then Store.children store (List.hd root_children)
+ else root_children
+ | None -> root_children
+ in
+ List.map
+ (fun page ->
+ let title =
+ match first_section_title renderer page with
+ | Some found -> found
+ | None -> "Component " ^ string_of_int page
+ in
+ { root_section_node = page; root_section_title = title })
+ children
+
+let some_node value = Some value
+
+let node renderer node_id =
+ match Store.node renderer.web_store node_id with
+ | Some current -> Some current.platform_node
+ | None -> None
+
+let property renderer node_id property =
+ Store.property renderer.web_store node_id property
+
+let children renderer node_id = Store.children renderer.web_store node_id
+let node_count renderer = Store.node_count renderer.web_store
+let batches renderer = Store.batches renderer.web_store
diff --git a/platform/web/melange/shell/lui_web.mli b/platform/web/melange/shell/lui_web.mli
new file mode 100644
index 00000000..7000b5ab
--- /dev/null
+++ b/platform/web/melange/shell/lui_web.mli
@@ -0,0 +1,45 @@
+(* LUI web (DOM) backend — public API. *)
+
+open Lui_protocol
+open Lui_web_types
+
+val create_with_extensions :
+ web_node ->
+ string String_map.t ->
+ Lui_extension.extension_registry ->
+ web_extension_adapter String_map.t ->
+ web_renderer
+
+val create_simulator_with_extensions :
+ web_node ->
+ operating_system ->
+ string String_map.t ->
+ Lui_extension.extension_registry ->
+ web_extension_adapter String_map.t ->
+ web_renderer
+
+val create_simulator :
+ ?app_icons:string String_map.t -> web_node -> operating_system -> web_renderer
+
+val create : ?app_icons:string String_map.t -> web_node -> web_renderer
+
+val set_event_handler : web_renderer -> (event -> bool) -> bool
+
+val extension_adapter : web_renderer -> string -> web_extension_adapter
+val extension_platform_node : web_renderer -> int -> string -> web_node
+val apply_extension_property :
+ web_renderer -> int -> string -> wire_value -> unit
+val remove_extension_property : web_renderer -> int -> string -> unit
+val cleanup_extension_node :
+ web_renderer -> (int, web_node retained_node) Hashtbl.t -> int -> unit
+
+val backend : web_renderer -> backend
+val mount : web_renderer -> int -> web_node -> unit
+val root_sections : web_renderer -> int -> root_section list
+
+val some_node : web_node -> web_node option
+val node : web_renderer -> int -> web_node option
+val property : web_renderer -> int -> property -> wire_value option
+val children : web_renderer -> int -> int list
+val node_count : web_renderer -> int
+val batches : web_renderer -> patch_batch list
diff --git a/platform/web/melange/shell/lui_web_apply.ml b/platform/web/melange/shell/lui_web_apply.ml
new file mode 100644
index 00000000..228780e7
--- /dev/null
+++ b/platform/web/melange/shell/lui_web_apply.ml
@@ -0,0 +1,411 @@
+(* DOM application of retained patch batches — port of web.cljc apply-dom-op. *)
+
+open Lui_protocol
+open Lui_web_types
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Nodes = Lui_web_nodes
+module Util = Lui_web_util
+module Ext = Lui_web_extensions
+
+let prev_node previous_nodes node_id = Hashtbl.find_opt previous_nodes node_id
+
+let prev_kind_is previous_nodes node_id expected =
+ match prev_node previous_nodes node_id with
+ | Some current -> Store.standard_kind_is current expected
+ | None -> false
+
+let prev_modal previous_nodes node_id =
+ match prev_node previous_nodes node_id with
+ | Some current -> (
+ match Store.standard_kind current with
+ | Some kind -> modal_surface kind
+ | None -> false)
+ | None -> false
+
+let prev_anchored_tooltip previous_nodes node_id =
+ match prev_node previous_nodes node_id with
+ | Some current -> Store.anchored_tooltip current
+ | None -> false
+
+let retained_content_container current dom_node =
+ match Store.standard_kind current with
+ | Some kind -> Util.content_container kind dom_node
+ | None -> dom_node
+
+let dom_child_container renderer node dom_node =
+ match Store.node renderer.web_store node with
+ | Some current -> retained_content_container current dom_node
+ | None -> dom_node
+
+let dom_child_container_before renderer previous_nodes node dom_node =
+ match Store.node renderer.web_store node with
+ | Some current -> retained_content_container current dom_node
+ | None -> (
+ match prev_node previous_nodes node with
+ | Some previous -> retained_content_container previous dom_node
+ | None -> dom_node)
+
+let portal_parent renderer previous_nodes parent child =
+ if prev_kind_is previous_nodes child Toast then renderer.web_toast_viewport
+ else if
+ prev_kind_is previous_nodes child DropdownMenu
+ || prev_modal previous_nodes child
+ || prev_anchored_tooltip previous_nodes child
+ then renderer.web_portal_root
+ else if prev_kind_is previous_nodes child ContextMenu then
+ Util.document_body renderer
+ else
+ dom_child_container_before renderer previous_nodes parent
+ (Nodes.dom_node_before renderer previous_nodes parent)
+
+let cleanup_node renderer node =
+ match Hashtbl.find_opt renderer.web_cleanups node with
+ | Some cleanup ->
+ cleanup ();
+ Hashtbl.remove renderer.web_cleanups node
+ | None -> ()
+
+let child_hidden_in_parent renderer child =
+ match Store.node renderer.web_store child with
+ | Some child_node -> (
+ match Store.standard_kind child_node with
+ | Some (ContextMenu | DropdownMenu | Toast) -> true
+ | Some kind -> modal_surface kind
+ | None -> Store.anchored_tooltip child_node)
+ | None -> true
+
+let visible_child_index renderer parent index =
+ match Store.node renderer.web_store parent with
+ | None -> index
+ | Some current ->
+ let rec loop children source_index result =
+ if source_index >= index then result
+ else
+ match children with
+ | [] -> result
+ | child :: rest ->
+ loop rest (source_index + 1)
+ (if child_hidden_in_parent renderer child then result
+ else result + 1)
+ in
+ loop current.retained_children 0 0
+
+let focused_descendant renderer dom_node =
+ let document =
+ W.Document.unsafeAsHtmlDocument renderer.web_document
+ in
+ match W.HtmlDocument.activeElement document with
+ | Some focused ->
+ if W.Element.contains (W.Element.asNode focused) dom_node then
+ Some focused
+ else None
+ | None -> None
+
+let refresh_structured_children renderer parent =
+ match Store.node renderer.web_store parent with
+ | Some current -> (
+ match Store.standard_kind current with
+ | Some Stepper -> Lui_web_widgets.update_stepper renderer parent
+ | Some Timeline -> Lui_web_widgets.update_timeline renderer parent
+ | _ -> ())
+ | None -> ()
+
+let refresh_dropdown_parent renderer parent =
+ match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if Store.standard_kind_is parent_node DropdownMenu then begin
+ Lui_web_menu.refresh_dropdown_item_roles renderer parent;
+ ignore (Lui_web_menu.refresh_combobox_list_state renderer parent)
+ end
+ | None -> ()
+
+let refresh_parent_for_prop renderer node property =
+ match Store.node renderer.web_store node with
+ | Some current -> (
+ match current.retained_parent with
+ | Some parent -> (
+ if property = MinWidth then
+ Lui_web_split.update_split renderer parent;
+ match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if
+ Store.standard_kind_is parent_node Tabs
+ && (property = Selected || property = Enabled)
+ then
+ Lui_web_focus.refresh_tabs_roving renderer.web_store
+ renderer.web_document parent;
+ if
+ Store.standard_kind_is parent_node BottomTabs
+ && (property = Selected || property = Enabled)
+ then Lui_web_widgets.refresh_bottom_tabs renderer parent;
+ if Store.standard_kind_is parent_node DropdownMenu then
+ ignore
+ (Lui_web_menu.refresh_combobox_list_state renderer parent)
+ | None -> ())
+ | None -> ())
+ | None -> ()
+
+let apply_create renderer node kind =
+ let created = Nodes.dom_node renderer node in
+ W.Element.setAttribute "id" (Util.node_dom_id node) created;
+ if kind = Accordion then Util.initialize_accordion_semantics node created;
+ Lui_web_events.attach_events renderer node kind created
+
+let insert_menu_item_role renderer _child current parent =
+ if Store.menu_item_row current then
+ match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if
+ Store.standard_kind_is parent_node ContextMenu
+ || (Store.standard_kind_is parent_node DropdownMenu
+ && not (Nodes.dropdown_listbox renderer parent))
+ then begin
+ W.Element.setAttribute "role" "menuitem" current.platform_node;
+ W.Element.removeAttribute "aria-selected" current.platform_node
+ end
+ | None -> ()
+
+let mount_inserted_child renderer child current =
+ match Store.standard_kind current with
+ | Some Radio -> Lui_web_focus.update_radio_group renderer child
+ | Some DropdownMenu ->
+ (match current.retained_parent with
+ | Some parent ->
+ Lui_web_menu.update_picker_expanded renderer parent true
+ | None -> ());
+ Lui_web_menu.mount_dropdown renderer child
+ | Some (Dialog | Sheet) ->
+ Lui_web_overlay.open_modal renderer child current.platform_node
+ | Some Tooltip ->
+ if Store.anchored_tooltip current then
+ Lui_web_overlay.mount_tooltip renderer child current.platform_node
+ | Some Toast ->
+ Lui_web_overlay.mount_toast renderer child current.platform_node
+ | _ -> ()
+
+let insert_child_dom renderer parent child index =
+ let parent_dom = Nodes.dom_node renderer parent in
+ let child_dom = Nodes.dom_node renderer child in
+ match Store.node renderer.web_store child with
+ | None -> invalid_arg "unknown DOM child"
+ | Some current -> (
+ match Store.standard_kind current with
+ | Some BottomTab -> (
+ match Store.node renderer.web_store parent with
+ | Some parent_node
+ when Store.standard_kind_is parent_node BottomTabs ->
+ Util.insert_dom_child
+ (Util.bottom_tabs_pages_node parent_dom) child_dom index;
+ ignore
+ (Lui_web_widgets.create_bottom_tab_trigger renderer parent
+ child index);
+ Lui_web_widgets.refresh_bottom_tabs renderer parent
+ | _ ->
+ Util.insert_dom_child
+ (dom_child_container renderer parent parent_dom) child_dom
+ (visible_child_index renderer parent index))
+ | Some Toast ->
+ W.Element.appendChild (W.Element.asNode child_dom)
+ renderer.web_toast_viewport
+ | Some DropdownMenu ->
+ W.Element.appendChild (W.Element.asNode child_dom)
+ renderer.web_portal_root
+ | Some Tooltip when Store.anchored_tooltip current ->
+ W.Element.appendChild (W.Element.asNode child_dom)
+ renderer.web_portal_root
+ | Some kind when modal_surface kind ->
+ W.Element.appendChild
+ (W.Element.asNode (Util.modal_layer_node child_dom))
+ renderer.web_portal_root
+ | Some ContextMenu ->
+ W.Element.appendChild (W.Element.asNode child_dom)
+ (Util.document_body renderer)
+ | _ ->
+ Util.insert_dom_child
+ (dom_child_container renderer parent parent_dom) child_dom
+ (visible_child_index renderer parent index))
+
+let apply_insert_child renderer parent child index =
+ insert_child_dom renderer parent child index;
+ Lui_web_split.update_split renderer parent;
+ Lui_web_focus.refresh_button_context renderer child;
+ Lui_web_split.update_split renderer parent;
+ refresh_structured_children renderer parent;
+ (match Store.node renderer.web_store child with
+ | Some current ->
+ insert_menu_item_role renderer child current parent;
+ mount_inserted_child renderer child current
+ | None -> ());
+ refresh_dropdown_parent renderer parent
+
+let remove_bottom_tab renderer parent child =
+ let tabs_dom = Nodes.dom_node renderer parent in
+ let pages = Util.bottom_tabs_pages_node tabs_dom in
+ let bar = Util.bottom_tabs_bar_node tabs_dom in
+ ignore
+ (W.Element.removeChild
+ (W.Element.asNode (Nodes.dom_node renderer child)) pages);
+ match
+ W.Element.querySelector ("#" ^ Util.bottom_tab_trigger_id child) bar
+ with
+ | Some trigger ->
+ ignore (W.Element.removeChild (W.Element.asNode trigger) bar)
+ | None -> ()
+
+let clear_submenu_trigger _renderer previous_nodes parent =
+ match prev_node previous_nodes parent with
+ | Some parent_node ->
+ if Store.menu_item_row parent_node then begin
+ W.Element.removeAttribute "data-submenu-trigger"
+ parent_node.platform_node;
+ W.Element.removeAttribute "aria-haspopup" parent_node.platform_node;
+ W.Element.removeAttribute "aria-expanded" parent_node.platform_node
+ end
+ | None -> ()
+
+let apply_remove_child renderer previous_nodes parent child =
+ let surface = Nodes.dom_node_before renderer previous_nodes child in
+ let modal = prev_modal previous_nodes child in
+ let bottom_tab = prev_kind_is previous_nodes child BottomTab in
+ let bottom_tabs = prev_kind_is previous_nodes parent BottomTabs in
+ let child_node =
+ if modal then Util.modal_layer_node surface else surface
+ in
+ let parent_node = portal_parent renderer previous_nodes parent child in
+ (if bottom_tab && bottom_tabs then remove_bottom_tab renderer parent child
+ else if modal then
+ match prev_node previous_nodes child with
+ | Some previous ->
+ ignore
+ (Lui_web_overlay.remove_modal_layer_after_exit
+ renderer.web_document parent_node child_node surface
+ (Store.standard_kind previous))
+ | None -> ()
+ else if prev_kind_is previous_nodes child DropdownMenu then
+ Lui_web_menu.remove_dropdown_after_exit renderer.web_document parent_node
+ child_node
+ else
+ ignore (W.Element.removeChild (W.Element.asNode child_node) parent_node));
+ Lui_web_focus.refresh_button_context renderer child;
+ refresh_structured_children renderer parent;
+ (match prev_node previous_nodes parent with
+ | Some parent_node ->
+ if Store.standard_kind_is parent_node BottomTabs then
+ Lui_web_widgets.refresh_bottom_tabs renderer parent
+ | None -> ());
+ (match prev_node previous_nodes child with
+ | Some previous ->
+ if Store.standard_kind_is previous DropdownMenu then begin
+ Lui_web_menu.update_picker_expanded renderer parent false;
+ clear_submenu_trigger renderer previous_nodes parent
+ end
+ | None -> ());
+ refresh_dropdown_parent renderer parent
+
+let move_bottom_tab renderer parent child index =
+ let tabs_dom = Nodes.dom_node renderer parent in
+ let pages = Util.bottom_tabs_pages_node tabs_dom in
+ let bar = Util.bottom_tabs_bar_node tabs_dom in
+ let child_node = Nodes.dom_node renderer child in
+ ignore (W.Element.removeChild (W.Element.asNode child_node) pages);
+ Util.insert_dom_child pages child_node index;
+ match Lui_web_widgets.bottom_tab_trigger renderer child with
+ | Some trigger ->
+ ignore (W.Element.removeChild (W.Element.asNode trigger) bar);
+ Util.insert_dom_child bar trigger index
+ | None -> ()
+
+let apply_move_child renderer previous_nodes parent child index =
+ let dropdown = prev_kind_is previous_nodes child DropdownMenu in
+ let modal = prev_modal previous_nodes child in
+ let tooltip = prev_anchored_tooltip previous_nodes child in
+ let toast = prev_kind_is previous_nodes child Toast in
+ let metadata = prev_kind_is previous_nodes child ContextMenu in
+ let bottom_tab =
+ match Store.node renderer.web_store child with
+ | Some current -> Store.standard_kind_is current BottomTab
+ | None -> false
+ in
+ let bottom_tabs =
+ match Store.node renderer.web_store parent with
+ | Some current -> Store.standard_kind_is current BottomTabs
+ | None -> false
+ in
+ let parent_node = portal_parent renderer previous_nodes parent child in
+ let surface_node = Nodes.dom_node_before renderer previous_nodes child in
+ let child_node =
+ if modal then Util.modal_layer_node surface_node else surface_node
+ in
+ let focused = focused_descendant renderer surface_node in
+ if bottom_tab && bottom_tabs then move_bottom_tab renderer parent child index
+ else begin
+ ignore (W.Element.removeChild (W.Element.asNode child_node) parent_node);
+ if dropdown || modal || tooltip || toast || metadata then
+ W.Element.appendChild (W.Element.asNode child_node) parent_node
+ else
+ Util.insert_dom_child parent_node child_node
+ (visible_child_index renderer parent index)
+ end;
+ Lui_web_split.update_split renderer parent;
+ refresh_structured_children renderer parent;
+ if bottom_tab && bottom_tabs then
+ Lui_web_widgets.refresh_bottom_tabs renderer parent;
+ refresh_dropdown_parent renderer parent;
+ if dropdown then Lui_web_position.position_dropdown renderer child;
+ if tooltip && W.Element.hasAttribute "data-open" surface_node then
+ Lui_web_position.position_tooltip renderer child;
+ Lui_web_focus.restore_focus renderer focused
+
+let apply_set_prop renderer node property value =
+ match Store.node renderer.web_store node with
+ | Some current -> (
+ match Store.standard_kind current with
+ | Some kind ->
+ Lui_web_props.apply_property renderer node kind
+ current.platform_node property value;
+ refresh_parent_for_prop renderer node property
+ | None -> invalid_arg "standard property targets extension node")
+ | None -> invalid_arg "unknown DOM node"
+
+let apply_remove_prop renderer node property =
+ (match Store.node renderer.web_store node with
+ | Some current -> (
+ match Store.standard_kind current with
+ | Some kind ->
+ Lui_web_props.remove_property renderer node kind
+ current.platform_node property;
+ refresh_parent_for_prop renderer node property
+ | None -> invalid_arg "standard property targets extension node")
+ | None -> ())
+
+let apply_dom_op renderer previous_nodes operation =
+ match operation with
+ | CreateNode (node, kind) -> apply_create renderer node kind
+ | CreateExtension (node, _identifier, _fingerprint) ->
+ W.Element.setAttribute "id" (Util.node_dom_id node)
+ (Nodes.dom_node renderer node)
+ | DropNode node ->
+ Ext.cleanup_extension_node renderer previous_nodes node;
+ cleanup_node renderer node
+ | SetProp (node, property, value) ->
+ apply_set_prop renderer node property value
+ | RemoveProp (node, property) -> apply_remove_prop renderer node property
+ | SetExtensionProp (node, property, value) ->
+ Ext.apply_extension_property renderer node property value
+ | RemoveExtensionProp (node, property) ->
+ Ext.remove_extension_property renderer node property
+ | InsertChild (parent, child, index) ->
+ apply_insert_child renderer parent child index
+ | RemoveChild (parent, child) ->
+ apply_remove_child renderer previous_nodes parent child
+ | MoveChild (parent, child, index) ->
+ apply_move_child renderer previous_nodes parent child index
+
+let apply_dom_batch renderer previous_nodes batch =
+ List.iter
+ (fun operation -> apply_dom_op renderer previous_nodes operation)
+ batch.ops;
+ ignore (Lui_web_focus.update_all_horizontal_group_roving renderer);
+ ignore (Lui_web_focus.update_all_tree_roving renderer);
+ ignore (Lui_web_focus.update_all_toolbar_roving renderer)
diff --git a/platform/web/melange/shell/lui_web_extensions.ml b/platform/web/melange/shell/lui_web_extensions.ml
new file mode 100644
index 00000000..3a31155b
--- /dev/null
+++ b/platform/web/melange/shell/lui_web_extensions.ml
@@ -0,0 +1,50 @@
+(* Extension adapter plumbing: JS-implemented components behind the retained
+ extension node type. *)
+
+open Lui_protocol
+open Lui_web_types
+module Store = Lui_web_store
+
+let extension_adapter renderer identifier =
+ match Hashtbl.find_opt renderer.web_extension_adapters identifier with
+ | Some adapter -> adapter
+ | None -> invalid_arg "web extension adapter is not registered"
+
+let extension_platform_node renderer node identifier =
+ let adapter = extension_adapter renderer identifier in
+ let emit name values =
+ ignore
+ (!(renderer.web_event_handler)
+ (ExtensionEvent (node, identifier, name, values)))
+ in
+ adapter.web_extension_create node renderer.web_document emit
+
+let apply_extension_property renderer node property value =
+ match Store.node renderer.web_store node with
+ | Some current -> (
+ match Store.extension_identity current with
+ | Some (identifier, _) ->
+ (extension_adapter renderer identifier).web_extension_set_property
+ current.platform_node property value
+ | None -> invalid_arg "extension property targets standard DOM node")
+ | None -> invalid_arg "unknown DOM node"
+
+let remove_extension_property renderer node property =
+ match Store.node renderer.web_store node with
+ | Some current -> (
+ match Store.extension_identity current with
+ | Some (identifier, _) ->
+ (extension_adapter renderer identifier).web_extension_remove_property
+ current.platform_node property
+ | None -> invalid_arg "extension property targets standard DOM node")
+ | None -> invalid_arg "unknown DOM node"
+
+let cleanup_extension_node renderer previous_nodes node =
+ match Hashtbl.find_opt previous_nodes node with
+ | Some current -> (
+ match Store.extension_identity current with
+ | Some (identifier, _) ->
+ (extension_adapter renderer identifier).web_extension_cleanup
+ current.platform_node
+ | None -> ())
+ | None -> ()
diff --git a/platform/web/melange/shell/lui_web_simulator.ml b/platform/web/melange/shell/lui_web_simulator.ml
new file mode 100644
index 00000000..4d6cec40
--- /dev/null
+++ b/platform/web/melange/shell/lui_web_simulator.ml
@@ -0,0 +1,209 @@
+(* Device emulation for the web backend: platform/form-factor/orientation
+ attributes and CSS variables on the host and portal root, plus the soft
+ keyboard visibility tracking driven by focusin/focusout on text entries. *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+
+let simulator_platform_name platform =
+ match platform with
+ | IOS -> "ios"
+ | AndroidOS -> "android"
+ | _ -> invalid_arg "web simulator platform must be iOS or Android"
+
+let simulator_form_factor_name form_factor =
+ match form_factor with
+ | SimulatorPhone -> "phone"
+ | SimulatorTablet -> "tablet"
+
+let simulator_orientation_name orientation =
+ match orientation with
+ | SimulatorPortrait -> "portrait"
+ | SimulatorLandscape -> "landscape"
+
+let simulator_pointer_name pointer =
+ match pointer with
+ | SimulatorTouch -> "touch"
+ | SimulatorHybrid -> "hybrid"
+
+let simulator_device platform form_factor orientation =
+ let ios = platform = IOS in
+ let tablet = form_factor = SimulatorTablet in
+ let portrait = orientation = SimulatorPortrait in
+ let portrait_width = if tablet then (if ios then 1024 else 800) else if ios then 390 else 412 in
+ let portrait_height = if tablet then (if ios then 1366 else 1280) else if ios then 844 else 915 in
+ let landscape_phone = (not tablet) && not portrait in
+ let android_landscape = (not ios) && not portrait in
+ ignore (simulator_platform_name platform);
+ ignore (simulator_form_factor_name form_factor);
+ ignore (simulator_orientation_name orientation);
+ { simulator_device_platform = platform;
+ simulator_device_form_factor = form_factor;
+ simulator_device_orientation = orientation;
+ simulator_device_pointer =
+ (if tablet then SimulatorHybrid else SimulatorTouch);
+ simulator_device_width =
+ (if portrait then portrait_width else portrait_height);
+ simulator_device_height =
+ (if portrait then portrait_height else portrait_width);
+ simulator_device_scale =
+ (if ios && not tablet then 3.0
+ else if (not ios) && not tablet then 2.625
+ else 2.0);
+ simulator_device_safe_top =
+ (if portrait then (if ios && not tablet then 47 else 24)
+ else if tablet then 24
+ else 0);
+ simulator_device_safe_right =
+ (if landscape_phone then (if ios then 47 else 24)
+ else if android_landscape then 24
+ else 0);
+ simulator_device_safe_bottom =
+ (if portrait then
+ (if ios && not tablet then 34 else if ios then 20 else 24)
+ else if ios then (if tablet then 20 else 21)
+ else 0);
+ simulator_device_safe_left =
+ (if landscape_phone then (if ios then 47 else 24)
+ else if android_landscape then 24
+ else 0);
+ simulator_device_keyboard_height =
+ (if portrait then (if tablet then 350 else if ios then 291 else 300)
+ else if tablet then 280
+ else if ios then 162
+ else 220) }
+
+let set_style scope property value =
+ W.CssStyleDeclaration.setProperty property value ""
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement scope))
+
+let apply_simulator_device_to_scope scope device keyboard_visible =
+ W.Element.setAttribute "data-lui-form-factor"
+ (simulator_form_factor_name device.simulator_device_form_factor) scope;
+ W.Element.setAttribute "data-lui-orientation"
+ (simulator_orientation_name device.simulator_device_orientation) scope;
+ W.Element.setAttribute "data-lui-pointer"
+ (simulator_pointer_name device.simulator_device_pointer) scope;
+ W.Element.setAttribute "data-lui-keyboard"
+ (if keyboard_visible then "visible" else "hidden") scope;
+ set_style scope "--lui-viewport-width"
+ (string_of_int device.simulator_device_width ^ "px");
+ set_style scope "--lui-viewport-height"
+ (string_of_int device.simulator_device_height ^ "px");
+ set_style scope "--lui-device-scale"
+ (Js.Float.toString device.simulator_device_scale);
+ set_style scope "--lui-safe-area-top"
+ (string_of_int device.simulator_device_safe_top ^ "px");
+ set_style scope "--lui-safe-area-right"
+ (string_of_int device.simulator_device_safe_right ^ "px");
+ set_style scope "--lui-safe-area-bottom"
+ (string_of_int device.simulator_device_safe_bottom ^ "px");
+ set_style scope "--lui-safe-area-left"
+ (string_of_int device.simulator_device_safe_left ^ "px");
+ set_style scope "--lui-keyboard-height"
+ (string_of_int
+ (if keyboard_visible then device.simulator_device_keyboard_height else 0)
+ ^ "px")
+
+let apply_simulator_device_to_scope_bang = apply_simulator_device_to_scope
+
+let set_simulator_device renderer device =
+ let keyboard_visible = !(renderer.web_simulator_keyboard_visible) in
+ apply_simulator_device_to_scope renderer.web_host device keyboard_visible;
+ apply_simulator_device_to_scope renderer.web_portal_root device
+ keyboard_visible;
+ renderer.web_simulator_device := Some device;
+ true
+
+let set_simulator_device_bang = set_simulator_device
+
+let set_simulator_keyboard_visible renderer visible =
+ match !(renderer.web_simulator_device) with
+ | Some device ->
+ renderer.web_simulator_keyboard_visible := visible;
+ set_simulator_device renderer device
+ | None -> invalid_arg "web simulator device is unavailable"
+
+let set_simulator_keyboard_visible_bang = set_simulator_keyboard_visible
+
+let set_simulator_form_factor renderer form_factor =
+ match !(renderer.web_simulator_device) with
+ | Some device ->
+ set_simulator_device renderer
+ (simulator_device device.simulator_device_platform form_factor
+ device.simulator_device_orientation)
+ | None -> invalid_arg "web simulator device is unavailable"
+
+let set_simulator_form_factor_bang = set_simulator_form_factor
+
+let rotate_simulator renderer =
+ match !(renderer.web_simulator_device) with
+ | Some device ->
+ set_simulator_device renderer
+ (simulator_device device.simulator_device_platform
+ device.simulator_device_form_factor
+ (match device.simulator_device_orientation with
+ | SimulatorPortrait -> SimulatorLandscape
+ | SimulatorLandscape -> SimulatorPortrait))
+ | None -> invalid_arg "web simulator device is unavailable"
+
+let rotate_simulator_bang = rotate_simulator
+
+let set_simulator_platform renderer platform =
+ let name = simulator_platform_name platform in
+ W.Element.setAttribute "data-lui-platform" name renderer.web_host;
+ W.Element.setAttribute "data-lui-platform" name renderer.web_portal_root;
+ renderer.web_simulator_platform := Some platform;
+ (match !(renderer.web_simulator_device) with
+ | Some device ->
+ ignore
+ (set_simulator_device renderer
+ (simulator_device platform device.simulator_device_form_factor
+ device.simulator_device_orientation))
+ | None -> ());
+ true
+
+let set_simulator_platform_bang = set_simulator_platform
+
+let simulator_text_entry element =
+ let class_name = W.Element.className element in
+ class_name = "lui-text-field" || class_name = "lui-input"
+ || class_name = "lui-search-field" || class_name = "lui-textarea"
+ || class_name = "lui-combobox-control"
+
+let simulator_text_entry_ = simulator_text_entry
+
+let compact_sheet renderer =
+ match !(renderer.web_simulator_device) with
+ | Some device -> device.simulator_device_form_factor = SimulatorPhone
+ | None ->
+ let root = W.Document.documentElement renderer.web_document in
+ W.Element.clientWidth root <= 640
+
+let compact_sheet_ = compact_sheet
+
+let attach_simulator_keyboard_events renderer =
+ List.iter
+ (fun scope ->
+ W.Element.addEventListener "focusin"
+ (fun event ->
+ let target =
+ W.EventTarget.unsafeAsElement (W.Event.target event)
+ in
+ if simulator_text_entry target then
+ ignore (set_simulator_keyboard_visible renderer true))
+ scope;
+ W.Element.addEventListener "focusout"
+ (fun event ->
+ let target =
+ W.EventTarget.unsafeAsElement (W.Event.target event)
+ in
+ if simulator_text_entry target then
+ ignore (set_simulator_keyboard_visible renderer false))
+ scope)
+ [ renderer.web_host; renderer.web_portal_root ];
+ true
+
+let attach_simulator_keyboard_events_bang = attach_simulator_keyboard_events
diff --git a/platform/web/melange/widgets/lui_web_split.ml b/platform/web/melange/widgets/lui_web_split.ml
new file mode 100644
index 00000000..6bea6391
--- /dev/null
+++ b/platform/web/melange/widgets/lui_web_split.ml
@@ -0,0 +1,228 @@
+(* Split panes: fraction math, divider layout, and drag/keyboard
+ interaction. Ported from web.cljc (split-base-fraction …
+ attach-split-events!). *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+
+let float_string value = Js.Float.toString value
+
+let set_style element property value =
+ Util.set_style
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement element))
+ property value
+
+let split_base_fraction value =
+ if Float.is_finite value && value > 0.0 then Float.min value 1.0 else 0.5
+
+let split_int_property renderer node property fallback =
+ match Store.property renderer.web_store node property with
+ | Some (IntValue value) -> value
+ | _ -> fallback
+
+let split_child_minimum renderer node index =
+ let children = Store.children renderer.web_store node in
+ if index < List.length children then
+ split_int_property renderer (List.nth children index) MinWidth 0
+ else 0
+
+let effective_split_fraction renderer node value =
+ let root = Lui_web_nodes.dom_node renderer node in
+ let gap = split_int_property renderer node Gap 9 in
+ let available = W.Element.clientWidth root - gap in
+ let first_minimum = split_child_minimum renderer node 0 in
+ let second_minimum = split_child_minimum renderer node 1 in
+ if available <= 0 then 0.5
+ else
+ let available_float = Float.of_int available in
+ let low = Float.of_int first_minimum /. available_float in
+ let high = 1.0 -. (Float.of_int second_minimum /. available_float) in
+ if low > high then
+ low /. Float.max (low +. (1.0 -. high)) 0.0001
+ else Float.min (Float.max (split_base_fraction value) low) high
+
+let split_timing_function renderer node =
+ match Store.property renderer.web_store node ResizeEasing with
+ | Some (StringValue "linear") -> "linear"
+ | Some (StringValue "emphasized") -> "cubic-bezier(0.2, 0, 0, 1)"
+ | Some (StringValue "spring") -> "cubic-bezier(0.16, 1.2, 0.3, 1)"
+ | _ -> "ease-in-out"
+
+let render_split renderer node root value animated =
+ let fraction = effective_split_fraction renderer node value in
+ let gap = split_int_property renderer node Gap 9 in
+ let gap_float = Float.of_int gap in
+ let first_minimum = split_child_minimum renderer node 0 in
+ let second_minimum = split_child_minimum renderer node 1 in
+ let panes = Util.child_element root 0 in
+ let divider = Util.child_element root 1 in
+ let duration =
+ if animated then split_int_property renderer node ResizeDuration 0 else 0
+ in
+ set_style panes "grid-template-columns"
+ ("minmax(" ^ string_of_int first_minimum ^ "px, "
+ ^ float_string fraction ^ "fr) minmax("
+ ^ string_of_int second_minimum ^ "px, "
+ ^ float_string (1.0 -. fraction) ^ "fr)");
+ set_style panes "column-gap" (string_of_int gap ^ "px");
+ set_style divider "left"
+ ("calc(" ^ float_string (fraction *. 100.0) ^ "% - "
+ ^ float_string (fraction *. gap_float) ^ "px)");
+ set_style divider "width" (string_of_int gap ^ "px");
+ set_style panes "transition-property" "grid-template-columns";
+ set_style divider "transition-property" "left";
+ set_style panes "transition-duration" (string_of_int duration ^ "ms");
+ set_style divider "transition-duration" (string_of_int duration ^ "ms");
+ set_style panes "transition-timing-function"
+ (split_timing_function renderer node);
+ set_style divider "transition-timing-function"
+ (split_timing_function renderer node);
+ W.Element.setAttribute "aria-valuenow" (float_string fraction) divider
+
+let render_split_bang = render_split
+
+let split_progress_source renderer node =
+ match Store.property renderer.web_store node ProgressValue with
+ | Some (FloatValue value) -> value
+ | _ -> 0.0
+
+let replace_split_state renderer node source current =
+ Hashtbl.replace renderer.web_splits node
+ { web_split_source = source; web_split_current = current }
+
+let reconcile_split renderer node root source =
+ match Hashtbl.find_opt renderer.web_splits node with
+ | Some state ->
+ let source_changed = source <> state.web_split_source in
+ let current = state.web_split_current in
+ let next_current =
+ if source_changed then
+ if Float.abs (split_base_fraction source -. current) < 0.000001 then
+ current
+ else split_base_fraction source
+ else current
+ in
+ replace_split_state renderer node source next_current;
+ render_split renderer node root next_current source_changed
+ | None ->
+ let duration = split_int_property renderer node ResizeDuration 0 in
+ let origin =
+ match Store.property renderer.web_store node ResizeOrigin with
+ | Some (FloatValue value) -> Some value
+ | _ -> None
+ in
+ let start =
+ match origin with
+ | Some value ->
+ if duration > 0 then split_base_fraction value
+ else split_base_fraction source
+ | None -> split_base_fraction source
+ in
+ replace_split_state renderer node source start;
+ render_split renderer node root start false;
+ if duration > 0 && start <> split_base_fraction source then
+ Webapi.requestAnimationFrame (fun _time ->
+ replace_split_state renderer node source
+ (split_base_fraction source);
+ render_split renderer node root (split_base_fraction source) true)
+
+let reconcile_split_bang = reconcile_split
+
+let update_split renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ if Store.standard_kind_is current Split then
+ reconcile_split renderer node current.platform_node
+ (split_progress_source renderer node)
+ | None -> ()
+
+let update_split_bang = update_split
+
+let rec update_splits_under renderer node =
+ update_split renderer node;
+ List.iter
+ (fun child -> update_splits_under renderer child)
+ (Store.children renderer.web_store node)
+
+let update_splits_under_bang = update_splits_under
+
+let attach_split_events renderer node root =
+ let divider = Util.child_element root 1 in
+ let document = renderer.web_document in
+ let dragging = ref false in
+ let adjust delta =
+ let current =
+ match Hashtbl.find_opt renderer.web_splits node with
+ | Some state -> state.web_split_current
+ | None -> 0.5
+ in
+ let next = effective_split_fraction renderer node (current +. delta) in
+ let source = split_progress_source renderer node in
+ replace_split_state renderer node source next;
+ render_split renderer node root next false;
+ ignore (!(renderer.web_event_handler) (ValueChanged (node, next)))
+ in
+ let move event =
+ if !dragging then begin
+ let bounds = W.Element.getBoundingClientRect root in
+ let gap = split_int_property renderer node Gap 9 in
+ let available = W.DomRect.width bounds -. Float.of_int gap in
+ let pointer =
+ Float.of_int (W.MouseEvent.clientX event) -. W.DomRect.left bounds
+ in
+ let raw =
+ (pointer -. (Float.of_int gap /. 2.0)) /. Float.max available 1.0
+ in
+ let current = effective_split_fraction renderer node raw in
+ let source = split_progress_source renderer node in
+ replace_split_state renderer node source current;
+ render_split renderer node root current false;
+ ignore (!(renderer.web_event_handler) (ValueChanged (node, current)))
+ end
+ in
+ let stop _event = dragging := false in
+ let resize_observer =
+ Webapi.ResizeObserver.make (fun _entries ->
+ match Hashtbl.find_opt renderer.web_splits node with
+ | Some state ->
+ render_split renderer node root state.web_split_current false
+ | None -> ())
+ in
+ W.Element.addMouseDownEventListener
+ (fun event ->
+ if W.MouseEvent.button event = 0 then begin
+ W.MouseEvent.preventDefault event;
+ dragging := true
+ end)
+ divider;
+ W.Document.addMouseMoveEventListener move document;
+ W.Document.addMouseUpEventListener stop document;
+ Webapi.ResizeObserver.observe resize_observer root;
+ W.Element.addKeyDownEventListener
+ (fun event ->
+ (match W.KeyboardEvent.key event with
+ | "ArrowLeft" ->
+ W.KeyboardEvent.preventDefault event;
+ adjust (-0.05)
+ | "ArrowRight" ->
+ W.KeyboardEvent.preventDefault event;
+ adjust 0.05
+ | "Home" ->
+ W.KeyboardEvent.preventDefault event;
+ adjust (-1.0)
+ | "End" ->
+ W.KeyboardEvent.preventDefault event;
+ adjust 1.0
+ | _ -> ()))
+ divider;
+ Hashtbl.replace renderer.web_cleanups node (fun () ->
+ W.Document.removeMouseMoveEventListener move document;
+ W.Document.removeMouseUpEventListener stop document;
+ Webapi.ResizeObserver.disconnect resize_observer;
+ Hashtbl.remove renderer.web_splits node)
+
+let attach_split_events_bang = attach_split_events
diff --git a/platform/web/melange/widgets/lui_web_widgets.ml b/platform/web/melange/widgets/lui_web_widgets.ml
new file mode 100644
index 00000000..653f8e69
--- /dev/null
+++ b/platform/web/melange/widgets/lui_web_widgets.ml
@@ -0,0 +1,505 @@
+(* Widgets: icons, avatar/image/media-surface registries, stepper,
+ bottom tabs, timeline, progress, and select display text. Ported from
+ web.cljc (update-icon-name! … select-display-text). *)
+
+open Lui_protocol
+open Lui_web_types
+
+module W = Webapi.Dom
+module Store = Lui_web_store
+module Util = Lui_web_util
+
+let float_string value = Js.Float.toString value
+
+let set_style element property value =
+ Util.set_style
+ (W.HtmlElement.style (W.Element.unsafeAsHtmlElement element))
+ property value
+
+let update_icon_name renderer dom_node name =
+ let element_style =
+ W.HtmlElement.style (W.Element.unsafeAsHtmlElement dom_node)
+ in
+ if String.starts_with ~prefix:"app:" name then begin
+ let bare_name = String.sub name 4 (String.length name - 4) in
+ let image =
+ match String_map.find_opt bare_name renderer.web_app_icons with
+ | Some url -> Util.css_url url
+ | None -> "url(\"./icons/missing.svg\")"
+ in
+ W.CssStyleDeclaration.setProperty "--lui-icon-image" image ""
+ element_style
+ end
+ else
+ W.CssStyleDeclaration.setProperty "--lui-icon-image"
+ (Util.css_url ("./icons/" ^ name ^ ".svg"))
+ "" element_style
+
+let update_icon_name_bang = update_icon_name
+
+let avatar_float renderer node property fallback =
+ match Store.property renderer.web_store node property with
+ | Some (FloatValue value) -> value
+ | _ -> fallback
+
+let media_size renderer node property fallback =
+ match Store.property renderer.web_store node property with
+ | Some (IntValue value) -> Float.of_int value
+ | _ -> fallback
+
+let registered_image renderer node =
+ match Store.property renderer.web_store node ImageIdValue with
+ | Some (IntValue image_id) ->
+ if image_id = 0 then None
+ else Hashtbl.find_opt renderer.web_images image_id
+ | _ -> None
+
+let registered_avatar_image renderer node = registered_image renderer node
+
+(* Shared crop math: positions [target] so the source rect covers it at the
+ given scale. *)
+let apply_crop element resource source_x source_y scale_x scale_y =
+ set_style element "width"
+ (float_string (resource.web_image_width *. scale_x) ^ "px");
+ set_style element "height"
+ (float_string (resource.web_image_height *. scale_y) ^ "px");
+ set_style element "left"
+ (float_string (Float.neg source_x *. scale_x) ^ "px");
+ set_style element "top"
+ (float_string (Float.neg source_y *. scale_y) ^ "px")
+
+let fill_image element object_fit =
+ set_style element "width" "100%";
+ set_style element "height" "100%";
+ set_style element "left" "0";
+ set_style element "top" "0";
+ set_style element "object-fit" object_fit
+
+let image_source renderer node =
+ let source_x = avatar_float renderer node SourceX 0.0 in
+ let source_y = avatar_float renderer node SourceY 0.0 in
+ let source_width = avatar_float renderer node SourceWidth 0.0 in
+ let source_height = avatar_float renderer node SourceHeight 0.0 in
+ (source_x, source_y, source_width, source_height)
+
+let update_avatar renderer node dom_node =
+ let image_node = Util.child_element dom_node 0 in
+ let initials_node = Util.child_element dom_node 1 in
+ match registered_avatar_image renderer node with
+ | Some resource ->
+ let source_x, source_y, source_width, source_height =
+ image_source renderer node
+ in
+ let cropped = source_width > 0.0 in
+ W.Element.setAttribute "src" resource.web_image_url image_node;
+ Util.set_state_attribute image_node "hidden" false;
+ Util.set_state_attribute initials_node "hidden" true;
+ if cropped then begin
+ let size = 40.0 in
+ let scale =
+ Float.max (size /. source_width) (size /. source_height)
+ in
+ let crop_width = source_width *. scale in
+ let crop_height = source_height *. scale in
+ set_style image_node "width"
+ (float_string (resource.web_image_width *. scale) ^ "px");
+ set_style image_node "height"
+ (float_string (resource.web_image_height *. scale) ^ "px");
+ set_style image_node "left"
+ (float_string
+ (Float.neg source_x *. scale +. ((size -. crop_width) /. 2.0))
+ ^ "px");
+ set_style image_node "top"
+ (float_string
+ (Float.neg source_y *. scale +. ((size -. crop_height) /. 2.0))
+ ^ "px");
+ set_style image_node "object-fit" "fill"
+ end
+ else fill_image image_node "cover"
+ | None ->
+ W.Element.removeAttribute "src" image_node;
+ Util.set_state_attribute image_node "hidden" true;
+ Util.set_state_attribute initials_node "hidden" false
+
+let update_avatar_bang = update_avatar
+
+let update_image renderer node dom_node =
+ let pixels = Util.child_element dom_node 0 in
+ match registered_image renderer node with
+ | Some resource ->
+ let source_x, source_y, source_width, source_height =
+ image_source renderer node
+ in
+ let cropped = source_width > 0.0 in
+ W.Element.setAttribute "src" resource.web_image_url pixels;
+ Util.set_state_attribute pixels "hidden" false;
+ if cropped then begin
+ let target_width =
+ media_size renderer node WidthValue source_width
+ in
+ let target_height =
+ media_size renderer node HeightValue source_height
+ in
+ let scale_x = target_width /. source_width in
+ let scale_y = target_height /. source_height in
+ apply_crop pixels resource source_x source_y scale_x scale_y;
+ set_style pixels "object-fit" "fill"
+ end
+ else fill_image pixels "fill"
+ | None ->
+ W.Element.removeAttribute "src" pixels;
+ Util.set_state_attribute pixels "hidden" true
+
+let update_image_bang = update_image
+
+let surface_placeholder_color surface_id =
+ "rgb("
+ ^ string_of_int (64 + (surface_id * 37 mod 64))
+ ^ ", "
+ ^ string_of_int (64 + (surface_id * 57 mod 64))
+ ^ ", "
+ ^ string_of_int (64 + (surface_id * 83 mod 64))
+ ^ ")"
+
+let update_media_surface renderer node dom_node =
+ let frame = Util.child_element dom_node 0 in
+ match Store.property renderer.web_store node SurfaceIdValue with
+ | Some (IntValue surface_id) ->
+ (match
+ if surface_id = 0 then None
+ else Hashtbl.find_opt renderer.web_media_surfaces surface_id
+ with
+ | Some resource ->
+ set_style dom_node "background-color" "transparent";
+ W.Element.setAttribute "src" resource.web_image_url frame;
+ Util.set_state_attribute frame "hidden" false
+ | None ->
+ set_style dom_node "background-color"
+ (if surface_id = 0 then "transparent"
+ else surface_placeholder_color surface_id);
+ W.Element.removeAttribute "src" frame;
+ Util.set_state_attribute frame "hidden" true)
+ | _ ->
+ set_style dom_node "background-color" "transparent";
+ W.Element.removeAttribute "src" frame;
+ Util.set_state_attribute frame "hidden" true
+
+let update_media_surface_bang = update_media_surface
+
+let refresh_image_id renderer image_id =
+ Hashtbl.iter
+ (fun node current ->
+ if
+ (Store.standard_kind_is current Avatar
+ || Store.standard_kind_is current Image)
+ && Property_map.find_opt ImageIdValue current.retained_properties
+ = Some (IntValue image_id)
+ then
+ if Store.standard_kind_is current Avatar then
+ update_avatar renderer node current.platform_node
+ else update_image renderer node current.platform_node)
+ (Store.nodes renderer.web_store);
+ true
+
+let refresh_image_id_bang = refresh_image_id
+
+let validate_positive id dims what =
+ if id <= 0 then invalid_arg (what ^ " id must be positive");
+ let width, height = dims in
+ if
+ (not (Float.is_finite width))
+ || (not (Float.is_finite height))
+ || width <= 0.0 || height <= 0.0
+ then invalid_arg (what ^ " dimensions must be positive")
+
+let register_image renderer image_id url width height =
+ validate_positive image_id (width, height) "registered image";
+ Hashtbl.replace renderer.web_images image_id
+ { web_image_url = url;
+ web_image_width = width;
+ web_image_height = height };
+ refresh_image_id renderer image_id
+
+let register_image_bang = register_image
+
+let unregister_image renderer image_id =
+ if image_id <= 0 then
+ invalid_arg "registered image id must be positive";
+ if Hashtbl.mem renderer.web_images image_id then begin
+ Hashtbl.remove renderer.web_images image_id;
+ ignore (refresh_image_id renderer image_id)
+ end;
+ true
+
+let unregister_image_bang = unregister_image
+
+let refresh_media_surface_id renderer surface_id =
+ Hashtbl.iter
+ (fun node current ->
+ if
+ Store.standard_kind_is current MediaSurface
+ && Property_map.find_opt SurfaceIdValue current.retained_properties
+ = Some (IntValue surface_id)
+ then update_media_surface renderer node current.platform_node)
+ (Store.nodes renderer.web_store);
+ true
+
+let refresh_media_surface_id_bang = refresh_media_surface_id
+
+let present_media_surface_frame renderer surface_id url width height =
+ validate_positive surface_id (width, height) "media surface";
+ Hashtbl.replace renderer.web_media_surfaces surface_id
+ { web_image_url = url;
+ web_image_width = width;
+ web_image_height = height };
+ refresh_media_surface_id renderer surface_id
+
+let present_media_surface_frame_bang = present_media_surface_frame
+
+let unregister_media_surface renderer surface_id =
+ if surface_id <= 0 then invalid_arg "media surface id must be positive";
+ if Hashtbl.mem renderer.web_media_surfaces surface_id then begin
+ Hashtbl.remove renderer.web_media_surfaces surface_id;
+ ignore (refresh_media_surface_id renderer surface_id)
+ end;
+ true
+
+let unregister_media_surface_bang = unregister_media_surface
+
+let main_alignment_value alignment =
+ match alignment with
+ | "start" -> "flex-start"
+ | "center" -> "center"
+ | "end" -> "flex-end"
+ | "space_between" -> "space-between"
+ | _ -> invalid_arg "invalid main alignment"
+
+let cross_alignment_value alignment =
+ match alignment with
+ | "stretch" -> "stretch"
+ | "start" -> "flex-start"
+ | "center" -> "center"
+ | "end" -> "flex-end"
+ | _ -> invalid_arg "invalid cross alignment"
+
+let string_property renderer node property =
+ match Store.property renderer.web_store node property with
+ | Some (StringValue value) -> value
+ | _ -> ""
+
+let update_stepper renderer node =
+ let children = Store.children renderer.web_store node in
+ let current =
+ match Store.node renderer.web_store node with
+ | Some current -> current
+ | None -> invalid_arg "unknown Stepper"
+ in
+ let active = int_property current.retained_properties ActiveIndex 0 in
+ let count = List.length children in
+ List.iteri
+ (fun index child ->
+ let step = Lui_web_nodes.dom_node renderer child in
+ let indicator = Util.child_element step 0 in
+ let label = string_property renderer child TextValue in
+ let state =
+ if index < active then "completed"
+ else if index = active then "active"
+ else "pending"
+ in
+ W.Element.setAttribute "data-state" state step;
+ W.Element.setAttribute "aria-label"
+ (label ^ " (" ^ state ^ ")") step;
+ W.Element.setAttribute "aria-posinset"
+ (string_of_int (index + 1)) step;
+ W.Element.setAttribute "aria-setsize" (string_of_int count) step;
+ (if state = "active" then
+ W.Element.setAttribute "aria-current" "step" step
+ else W.Element.removeAttribute "aria-current" step);
+ (if state = "completed" then begin
+ W.Element.setTextContent indicator "";
+ W.Element.setAttribute "data-name" "check" indicator;
+ update_icon_name renderer indicator "check"
+ end
+ else begin
+ W.Element.removeAttribute "data-name" indicator;
+ set_style indicator "--lui-icon-image" "none";
+ W.Element.setTextContent indicator (string_of_int (index + 1))
+ end);
+ let connector = Util.child_element step 2 in
+ if index = count - 1 then W.Element.setAttribute "hidden" "" connector
+ else W.Element.removeAttribute "hidden" connector)
+ children
+
+let update_stepper_bang = update_stepper
+
+let bottom_tab_trigger renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ W.Element.querySelector
+ ("#" ^ Util.bottom_tab_trigger_id node)
+ (Lui_web_nodes.dom_node renderer parent)
+ | None -> None)
+ | None -> None
+
+let bottom_tab_string_property renderer node property =
+ match Store.property renderer.web_store node property with
+ | Some (StringValue value) -> value
+ | _ -> ""
+
+let refresh_bottom_tabs renderer tabs =
+ let children = Store.children renderer.web_store tabs in
+ let selected =
+ match
+ List.find_opt
+ (fun child ->
+ Store.property renderer.web_store child Selected
+ = Some (BoolValue true))
+ children
+ with
+ | Some child -> Some child
+ | None -> (match children with [] -> None | first :: _ -> Some first)
+ in
+ List.iter
+ (fun child ->
+ match Store.node renderer.web_store child with
+ | Some current ->
+ let active = selected = Some child in
+ let panel = current.platform_node in
+ Util.set_state_attribute panel "hidden" (not active);
+ Util.set_state_attribute panel "inert" (not active);
+ (match bottom_tab_trigger renderer child with
+ | Some trigger ->
+ W.Element.setAttribute "aria-selected"
+ (if active then "true" else "false") trigger;
+ W.Element.setAttribute "tabindex"
+ (if active then "0" else "-1") trigger
+ | None -> ())
+ | None -> ())
+ children
+
+let refresh_bottom_tabs_bang = refresh_bottom_tabs
+
+let create_bottom_tab_trigger renderer tabs node index =
+ let document = renderer.web_document in
+ let panel = Lui_web_nodes.dom_node renderer node in
+ let panel_id = Util.node_dom_id node in
+ let trigger_id = Util.bottom_tab_trigger_id node in
+ let icon_name = bottom_tab_string_property renderer node InlineIconName in
+ let title = bottom_tab_string_property renderer node TitleValue in
+ let icon =
+ Util.element document "span" "lui-icon" [ ("aria-hidden", "true") ] []
+ in
+ let label = Util.element document "span" "lui-bottom-tabs-label" [] [] in
+ let trigger =
+ Util.element document "button" "lui-bottom-tabs-tab"
+ [ ("type", "button"); ("role", "tab"); ("id", trigger_id);
+ ("aria-controls", panel_id); ("aria-selected", "false");
+ ("tabindex", "-1") ]
+ [ icon; label ]
+ in
+ let enabled = Store.enabled_node renderer node in
+ let press _event =
+ if
+ Store.enabled_node renderer node
+ && Store.event_capability renderer node PressEnabled
+ then begin
+ W.HtmlElement.focus (W.Element.unsafeAsHtmlElement trigger);
+ ignore (!(renderer.web_event_handler) (Press node))
+ end
+ in
+ W.Element.setAttribute "aria-labelledby" trigger_id panel;
+ W.Element.setTextContent label title;
+ W.Element.setAttribute "data-name" icon_name icon;
+ update_icon_name renderer icon icon_name;
+ (if enabled then begin
+ W.Element.removeAttribute "disabled" trigger;
+ W.Element.setAttribute "aria-disabled" "false" trigger
+ end
+ else begin
+ W.Element.setAttribute "disabled" "disabled" trigger;
+ W.Element.setAttribute "aria-disabled" "true" trigger
+ end);
+ W.Element.addEventListener "click" press trigger;
+ Util.insert_dom_child
+ (Util.bottom_tabs_bar_node (Lui_web_nodes.dom_node renderer tabs))
+ trigger index;
+ trigger
+
+let create_bottom_tab_trigger_bang = create_bottom_tab_trigger
+
+let update_stepper_parent renderer node =
+ match Store.node renderer.web_store node with
+ | Some current ->
+ (match current.retained_parent with
+ | Some parent ->
+ (match Store.node renderer.web_store parent with
+ | Some parent_node ->
+ if Store.standard_kind_is parent_node Stepper then
+ update_stepper renderer parent
+ | None -> ())
+ | None -> ())
+ | None -> ()
+
+let update_stepper_parent_bang = update_stepper_parent
+
+let update_timeline renderer node =
+ let children = Store.children renderer.web_store node in
+ let count = List.length children in
+ List.iteri
+ (fun index child ->
+ let item = Lui_web_nodes.dom_node renderer child in
+ W.Element.setAttribute "aria-posinset"
+ (string_of_int (index + 1)) item;
+ W.Element.setAttribute "aria-setsize" (string_of_int count) item)
+ children
+
+let update_timeline_bang = update_timeline
+
+let update_timeline_indicator renderer node dom_node =
+ let indicator = Util.child_element (Util.child_element dom_node 0) 0 in
+ let icon = string_property renderer node InlineIconName in
+ let text = string_property renderer node IndicatorValue in
+ if icon <> "" then begin
+ W.Element.setTextContent indicator "";
+ W.Element.setAttribute "data-name" icon indicator;
+ update_icon_name renderer indicator icon
+ end
+ else begin
+ W.Element.removeAttribute "data-name" indicator;
+ set_style indicator "--lui-icon-image" "none";
+ W.Element.setTextContent indicator text;
+ if text = "" then W.Element.setAttribute "data-dot" "" indicator
+ else W.Element.removeAttribute "data-dot" indicator
+ end
+
+let update_timeline_indicator_bang = update_timeline_indicator
+
+let progress_float renderer node =
+ match Store.property renderer.web_store node ProgressValue with
+ | Some (FloatValue value) -> value
+ | _ -> 0.0
+
+let update_progress renderer node dom_node =
+ let value = progress_float renderer node in
+ let clamped = Float.max 0.0 (Float.min value 1.0) in
+ let position = clamped *. 100.0 in
+ W.Element.setAttribute "aria-valuenow" (float_string clamped) dom_node;
+ set_style dom_node "--lui-progress-position"
+ (float_string position ^ "%")
+
+let update_progress_bang = update_progress
+
+let select_display_text renderer node =
+ match Store.property renderer.web_store node TextValue with
+ | Some (StringValue text) ->
+ if text <> "" then text
+ else
+ (match Store.property renderer.web_store node PlaceholderValue with
+ | Some (StringValue placeholder) -> placeholder
+ | _ -> "")
+ | _ ->
+ (match Store.property renderer.web_store node PlaceholderValue with
+ | Some (StringValue placeholder) -> placeholder
+ | _ -> "")
diff --git a/platform/web/package-lock.json b/platform/web/package-lock.json
index 21a66948..aedb1579 100644
--- a/platform/web/package-lock.json
+++ b/platform/web/package-lock.json
@@ -1380,7 +1380,6 @@
"dev": true,
"hasInstallScript": true,
"license": "MIT",
- "peer": true,
"bin": {
"esbuild": "bin/esbuild"
},
diff --git a/platform/web/src/lui.css b/platform/web/src/lui.css
index 6acba535..3b8f19ce 100644
--- a/platform/web/src/lui.css
+++ b/platform/web/src/lui.css
@@ -586,6 +586,10 @@ body {
transition: opacity 150ms ease-out;
}
+ .lui-modal-description {
+ @apply text-sm font-normal text-muted-foreground;
+ }
+
.lui-modal-layer[data-starting-style] .lui-modal-backdrop,
.lui-modal-layer[data-ending-style] .lui-modal-backdrop {
opacity: 0;
diff --git a/platform/web/test/firefox.e2e.mjs b/platform/web/test/firefox.e2e.mjs
index a51d1e32..d38fc797 100644
--- a/platform/web/test/firefox.e2e.mjs
+++ b/platform/web/test/firefox.e2e.mjs
@@ -66,7 +66,7 @@ test(`${browserLabel} preserves the Gallery's retained interaction contract`, as
failures,
}
})
- assert.equal(mobileAudit.count, 66)
+ assert.equal(mobileAudit.count, 69)
assert.ok(mobileAudit.minNavigationHeight >= 44, JSON.stringify(mobileAudit))
assert.equal(mobileAudit.mountedPages, 1)
assert.deepEqual(mobileAudit.failures, [])
diff --git a/platform/web/test/hot-reload.e2e.mjs b/platform/web/test/hot-reload.e2e.mjs
index 5d171d1f..00cf7844 100644
--- a/platform/web/test/hot-reload.e2e.mjs
+++ b/platform/web/test/hot-reload.e2e.mjs
@@ -10,7 +10,7 @@ import { fileURLToPath } from "node:url"
const projectRoot = path.resolve(path.dirname(fileURLToPath(import.meta.url)), "../../..")
const require = createRequire(path.join(projectRoot, "platform/web/package.json"))
const { chromium } = require("playwright")
-const gallerySource = path.join(projectRoot, "examples/components/lg/components/gallery.cljc")
+const gallerySource = path.join(projectRoot, "examples/gallery/view.ml")
const galleryCss = path.join(projectRoot, "examples/components/web/styles.css")
const jsFixture = path.join(
projectRoot,
@@ -70,7 +70,7 @@ function nextPageLoad(page) {
return new Promise((resolve) => page.once("load", () => resolve("reload")))
}
-test("LG, CSS, and JavaScript update through Vite without a manual refresh", async () => {
+test("OCaml, CSS, and JavaScript update through Vite without a manual refresh", async () => {
const originals = new Map(
await Promise.all(
[gallerySource, galleryCss, jsFixture].map(async (file) => [file, await readFile(file, "utf8")]),
@@ -126,82 +126,72 @@ test("LG, CSS, and JavaScript update through Vite without a manual refresh", asy
{ sameDocument: true, sameSwitch: true, checked: true },
)
- const lgUpdated = originals
+ const ocamlUpdated = originals
.get(gallerySource)
.replace(
"Switch shares the same model-owned Signal.",
- "LG hot reload applied.",
- )
- const firstLgUpdate = Promise.race([
+ "OCaml hot reload applied.",
+ )
+ const firstOcamlUpdate = Promise.race([
nextPageLoad(page),
- page.getByText("LG hot reload applied.", { exact: true })
+ page.getByText("OCaml hot reload applied.", { exact: true })
.waitFor()
.then(() => "hmr"),
])
- await writeFile(gallerySource, lgUpdated)
+ await writeFile(gallerySource, ocamlUpdated)
assert.equal(
- await firstLgUpdate,
- "hmr",
- "LG updates must not reload the document",
+ await firstOcamlUpdate,
+ "reload",
+ "OCaml updates must reload the document once Dune output settles",
)
+ await page.waitForLoadState("networkidle")
await openSwitch(page)
- await page.getByText("LG hot reload applied.", { exact: true }).waitFor()
+ await page.getByText("OCaml hot reload applied.", { exact: true }).waitFor()
assert.deepEqual(
await page.evaluate(() => ({
sameDocument: document === window.__luiHotDocument,
- sameSwitch: document.querySelector(".lui-switch-control") === window.__luiHotSwitch,
- checked: document.querySelector(".lui-switch-control").checked,
galleryShells: document.querySelectorAll(".lui-gallery-shell").length,
popupPortals: document.querySelectorAll(".lui-popup-portal").length,
})),
{
- sameDocument: true,
- sameSwitch: true,
- checked: true,
+ sameDocument: false,
galleryShells: 1,
popupPortals: 1,
},
)
- assert.doesNotMatch(output.join(""), /Browser error:|\[lui-hmr\] Failed/)
+ assert.doesNotMatch(output.join(""), /Browser error:/)
assert.doesNotMatch(
output.join(""),
- /Failed to reload .*lui_components_web/,
- "Dune output must settle before Vite imports the generated bundle",
+ /Failed to reload/,
+ "Dune output must settle before the page reloads",
)
- await writeFile(gallerySource, `${lgUpdated}\n(`)
+ await writeFile(gallerySource, `${ocamlUpdated}\n(*`)
await page.waitForTimeout(500)
- assert.equal(await page.getByText("LG hot reload applied.", { exact: true }).count(), 1)
- const recoveredLgUpdate = Promise.race([
+ assert.equal(await page.getByText("OCaml hot reload applied.", { exact: true }).count(), 1)
+ const recoveredOcamlUpdate = Promise.race([
nextPageLoad(page),
- page.getByText("LG hot reload recovered.", { exact: true })
+ page.getByText("OCaml hot reload recovered.", { exact: true })
.waitFor()
.then(() => "hmr"),
])
await writeFile(
gallerySource,
- lgUpdated.replace("LG hot reload applied.", "LG hot reload recovered."),
+ ocamlUpdated.replace("OCaml hot reload applied.", "OCaml hot reload recovered."),
)
assert.equal(
- await recoveredLgUpdate,
- "hmr",
- "LG recovery must not reload the document",
+ await recoveredOcamlUpdate,
+ "reload",
+ "OCaml recovery must reload the document",
)
+ await page.waitForLoadState("networkidle")
await openSwitch(page)
- await page.getByText("LG hot reload recovered.", { exact: true }).waitFor()
- assert.deepEqual(
- await page.evaluate(() => ({
- sameDocument: document === window.__luiHotDocument,
- sameSwitch: document.querySelector(".lui-switch-control") === window.__luiHotSwitch,
- checked: document.querySelector(".lui-switch-control").checked,
- })),
- { sameDocument: true, sameSwitch: true, checked: true },
+ await page.getByText("OCaml hot reload recovered.", { exact: true }).waitFor()
+ assert.equal(
+ await page.evaluate(() => document === window.__luiHotDocument),
+ false,
)
- await page.reload({ waitUntil: "networkidle" })
- await openSwitch(page)
- assert.equal(await switchControl.isChecked(), false)
-
await page.goto(
`${origin}/platform/web/test/fixtures/hot-reload/index.html`,
{ waitUntil: "networkidle" },
diff --git a/platform/web/test/overlay.e2e.mjs b/platform/web/test/overlay.e2e.mjs
index aa2f37dc..cb8ad72c 100644
--- a/platform/web/test/overlay.e2e.mjs
+++ b/platform/web/test/overlay.e2e.mjs
@@ -2511,7 +2511,7 @@ test("every Gallery page fits the compact one-page mobile shell", async () => {
}
})()`)
- assert.equal(audit.count, 66)
+ assert.equal(audit.count, 69)
assert.ok(audit.minNavigationHeight >= 44, JSON.stringify(audit))
assert.equal(audit.mountedPages, 1)
assert.deepEqual(audit.failures, [])
diff --git a/platform/web/test/simulator.e2e.mjs b/platform/web/test/simulator.e2e.mjs
index 855cd27a..d0bf0460 100644
--- a/platform/web/test/simulator.e2e.mjs
+++ b/platform/web/test/simulator.e2e.mjs
@@ -700,6 +700,7 @@ test("iOS and Android produce deterministic computed control metrics", async ()
})()`)
await selectPlatform("android")
+ await browser("wait", "300")
const android = await state(`(() => {
const button = document.querySelector('.lui-button[data-variant="primary"]')
diff --git a/platform/web/vite.config.mjs b/platform/web/vite.config.mjs
index 06a8385c..f922e16c 100644
--- a/platform/web/vite.config.mjs
+++ b/platform/web/vite.config.mjs
@@ -7,19 +7,16 @@ const projectRoot = path.resolve(
path.dirname(fileURLToPath(import.meta.url)),
"../..",
)
-const generatedBundle = path.join(
+const buildOutputRoot = path.join(
projectRoot,
- "_build/default/examples/components/web/lui-components-web/examples/components/web/lui_components_web.js",
+ "_build/default/examples/components/web/lui-components-web",
)
-const generatedBootstrap = path.join(
- projectRoot,
- "_build/default/examples/components/web/lui-components-web/examples/components/web/web_bootstrap.js",
-)
-const gallerySourceRoot = path.join(
- projectRoot,
- "examples/components/lg",
-)
-const LG_SOURCE_EXTENSIONS = new Set([".cljc", ".mli"])
+const generatedEntryModules = [
+ "examples/components/web/web_bootstrap.js",
+ "examples/components/web/web_main.js",
+].map((file) => path.join(buildOutputRoot, file))
+const examplesRoot = path.join(projectRoot, "examples")
+const OCAML_SOURCE_EXTENSIONS = new Set([".ml", ".mli"])
const wait = (milliseconds) =>
new Promise((resolve) => setTimeout(resolve, milliseconds))
@@ -39,123 +36,82 @@ async function settleGeneratedFile(file) {
return previous
}
+function generatedModuleFor(sourceFile) {
+ const relative = path.relative(examplesRoot, sourceFile)
+ return path.join(
+ buildOutputRoot,
+ "examples",
+ relative.replace(/\.(ml|mli)$/, ".js"),
+ )
+}
+
function melangeHotReload() {
- const generatedFiles = new Map()
let sourceGeneration = 0
- async function waitForMelangeOutput(generation, previousBundle, bootstrapTime) {
- for (let attempt = 0; attempt < 1200; attempt += 1) {
- if (generation !== sourceGeneration) return undefined
+ async function modulesPresent() {
+ for (const moduleFile of generatedEntryModules) {
try {
- const [bundle, bootstrapInfo] = await Promise.all([
- readFile(generatedBundle, "utf8"),
- stat(generatedBootstrap),
- ])
- if (bundle !== previousBundle && bootstrapInfo.mtimeMs > bootstrapTime) {
- return settleGeneratedFile(generatedBundle)
- }
+ await stat(moduleFile)
} catch {
- // Dune replaces the generated output tree atomically.
+ return false
}
- await wait(50)
}
- return undefined
+ return true
}
- return {
- name: "lui-melange-hot-reload",
- enforce: "post",
- async transform(code, id) {
- const normalizedId = id.split("?", 1)[0].split(path.sep).join("/")
- const generatedJavaScript =
- normalizedId.includes("/_build/default/") &&
- normalizedId.endsWith(".js")
- if (generatedJavaScript) {
+ async function waitForMelangeOutput(generation, generatedModule, since) {
+ let settled = false
+ for (let attempt = 0; attempt < 1200; attempt += 1) {
+ if (generation !== sourceGeneration) return false
+ if (settled) {
+ if (await modulesPresent()) return true
+ } else {
try {
- generatedFiles.set(normalizedId, await readFile(normalizedId, "utf8"))
+ const info = await stat(generatedModule)
+ if (info.mtimeMs > since) {
+ // Dune replaces the whole emit tree during a rebuild, so the
+ // changed module can settle while sibling entries are still
+ // missing. Wait for a quiet window with all entries present.
+ await settleGeneratedFile(generatedModule)
+ await wait(300)
+ settled = true
+ }
} catch {
- generatedFiles.set(normalizedId, code)
+ // Dune replaces the generated output tree atomically.
}
}
- if (
- !generatedJavaScript ||
- !code.includes("Lg_runtime__Runtime_reference") ||
- !code.includes("__root")
- ) {
- return null
- }
-
- const rootNames = [
- ...new Set(code.match(/\b[A-Za-z_$][\w$]*__root\b/g) ?? []),
- ]
- if (rootNames.length === 0) return null
-
- const hotReloadBoundary = `
-
-const __luiHmrRoots = import.meta.hot?.data.luiRoots ?? {
- ${rootNames.join(",\n ")}
-}
-
-if (import.meta.hot) {
- import.meta.hot.data.luiRoots = __luiHmrRoots
- import.meta.hot.accept((nextModule) => {
- if (!nextModule) return
-
- Object.entries(__luiHmrRoots)
- .filter(
- ([name, current]) =>
- nextModule[name] && current.replacement_observers !== 0,
- )
- .forEach(([name, current]) => {
- try {
- Lg_runtime__Runtime_reference.replace_for_redefinition(
- current,
- nextModule[name].value,
- )
- } catch (error) {
- console.error("[lui-hmr] Failed to replace " + name, error.cause ?? error)
- throw error
- }
- })
- })
-}
-`
+ await wait(50)
+ }
+ return false
+ }
- return { code: `${code}${hotReloadBoundary}`, map: null }
- },
+ return {
+ name: "lui-melange-hot-reload",
+ enforce: "post",
async handleHotUpdate({ file, modules, server }) {
const normalizedFile = file.split(path.sep).join("/")
if (normalizedFile.includes("/_build/default/")) {
return []
}
if (
- !file.startsWith(gallerySourceRoot) ||
- !LG_SOURCE_EXTENSIONS.has(path.extname(file))
+ !file.startsWith(examplesRoot) ||
+ !OCAML_SOURCE_EXTENSIONS.has(path.extname(file))
) {
return modules
}
sourceGeneration += 1
const generation = sourceGeneration
- const normalizedBundle = generatedBundle.split(path.sep).join("/")
- const previous = generatedFiles.get(normalizedBundle)
- let bootstrapTime = 0
- try {
- bootstrapTime = (await stat(generatedBootstrap)).mtimeMs
- } catch {
- // The initial build is guaranteed before Vite starts.
- }
- const current = await waitForMelangeOutput(
+ const { mtimeMs: since } = await stat(file)
+ const ready = await waitForMelangeOutput(
generation,
- previous,
- bootstrapTime,
- )
- if (current === undefined) return []
- generatedFiles.set(normalizedBundle, current)
- const generatedModule = server.moduleGraph.getModuleById(
- generatedBundle,
+ generatedModuleFor(file),
+ since,
)
- return generatedModule ? [generatedModule] : []
+ if (!ready) return []
+ server.moduleGraph.invalidateAll()
+ server.ws.send({ type: "full-reload" })
+ return []
},
}
}
diff --git a/src/lui_element_combine.ml b/src/lui_element_combine.ml
index e2a2c633..eea56a78 100644
--- a/src/lui_element_combine.ml
+++ b/src/lui_element_combine.ml
@@ -463,7 +463,7 @@ let empty_state
| None -> []
| Some name ->
[ Lui_elements.icon ~name ~size:`lg ~foreground:"muted-foreground" [] ])
- @ [ heading ~level:4 ~value:title [] ]
+ @ [ text ~style_class:"headline" ~value:title [] ]
@ (match description with
| None -> []
| Some value ->
diff --git a/src/lui_elements.ml b/src/lui_elements.ml
index 922521a2..b75ee827 100644
--- a/src/lui_elements.ml
+++ b/src/lui_elements.ml
@@ -1260,13 +1260,14 @@ let toolbar ?key ?gap ?main ?cross ?grow ?columns ?padding ?padding_horizontal ?
mount_children context node children;
node
-let accordion ?key ?gap ?main ?cross ?grow ?columns ?padding ?padding_horizontal ?padding_vertical ?background ?foreground ?border_color ?border_width ?corner_radius ?width ?height ?min_width ?max_width ?min_height ?max_height ?container_relative_frame ?container_relative_frame_inset ?accessibility_identifier ?accessibility_identifier_signal ?foreground_signal ?background_signal ?style_class ?on_appear ?text ?text_signal ?selected ?accordion_height ?on_toggle (children : t list) : t =
+let accordion ?key ?gap ?main ?cross ?grow ?columns ?padding ?padding_horizontal ?padding_vertical ?background ?foreground ?border_color ?border_width ?corner_radius ?width ?height ?min_width ?max_width ?min_height ?max_height ?container_relative_frame ?container_relative_frame_inset ?accessibility_identifier ?accessibility_identifier_signal ?foreground_signal ?background_signal ?style_class ?on_appear ?text ?text_signal ?selected ?selected_signal ?accordion_height ?on_toggle (children : t list) : t =
fun context parent ->
let node = Lui_ui.accordion context in
apply_universal context node ~key ~gap ~main ~cross ~grow ~columns ~padding ~padding_horizontal ~padding_vertical ~background ~foreground ~border_color ~border_width ~corner_radius ~width ~height ~min_width ~max_width ~min_height ~max_height ~container_relative_frame ~container_relative_frame_inset ~accessibility_identifier ~accessibility_identifier_signal ~foreground_signal ~background_signal ~style_class ~on_appear;
Option.iter (Lui_ui.string_property context node TextValue) text;
Option.iter (Lui_ui.string_property_signal context node TextValue) text_signal;
Option.iter (Lui_ui.bool_property context node Selected) selected;
+ Option.iter (Lui_ui.bool_property_signal context node Selected) selected_signal;
Option.iter (Lui_ui.int_property context node HeightValue) accordion_height;
(match on_toggle with
| Some handler ->
diff --git a/src/lui_elements.mli b/src/lui_elements.mli
index f7d5e450..7f63da1c 100644
--- a/src/lui_elements.mli
+++ b/src/lui_elements.mli
@@ -2280,6 +2280,7 @@ val accordion :
?text:string ->
?text_signal:string Signal.signal ->
?selected:bool ->
+ ?selected_signal:bool Signal.signal ->
?accordion_height:int ->
?on_toggle:(Lui_protocol.event -> unit) -> t list -> t
val menu_item :
diff --git a/src/lui_runtime.ml b/src/lui_runtime.ml
index 275d83db..84a1e827 100644
--- a/src/lui_runtime.ml
+++ b/src/lui_runtime.ml
@@ -1135,7 +1135,15 @@ let event_is_value_echo properties event =
(match Property_map.find_opt Checked properties with
| Some (BoolValue current) -> current = checked_value
| Some _ -> false
- | None -> not checked_value)
+ | None -> (
+ match Property_map.find_opt Expanded properties with
+ | Some (BoolValue current) -> current = checked_value
+ | Some _ -> false
+ | None -> (
+ match Property_map.find_opt Selected properties with
+ | Some (BoolValue current) -> current = checked_value
+ | Some _ -> false
+ | None -> not checked_value)))
| ValueChanged (_, value) ->
(match Property_map.find_opt ProgressValue properties with
| Some (FloatValue current) -> current = value
diff --git a/tooling/dev_web.mjs b/tooling/dev_web.mjs
index af88b9db..2d92b393 100644
--- a/tooling/dev_web.mjs
+++ b/tooling/dev_web.mjs
@@ -130,6 +130,7 @@ async function loadOpamEnvironment() {
"opam",
[
"exec",
+ "--switch=default",
"--",
process.execPath,
"-e",