From 6badecf74981c3b7bb6f0d1b367f85ce4769f5df Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 22:34:10 -0700 Subject: [PATCH 01/21] Add web DOM backend skeleton: types, DOM utils, retained store, module stubs Porting foundation for the LG web.cljc backend to OCaml/Melange: - core/lui_web_types.ml: renderer, retained mirror, simulator, extension types - core/lui_web_util.ml: shared DOM helpers and DOM-type coercions - core/lui_web_store.ml: retained mirror + batch validation port - Feature-module stubs (nodes/render/widgets/focus/popup/events/shell) so parallel porting compiles; PORTING.md documents ownership and conventions. - dune: include_subdirs unqualified + lui/melange.dom deps (needed for the feature-folder layout requested for this port) --- platform/web/melange/PORTING.md | 67 ++ platform/web/melange/core/lui_web_store.ml | 738 ++++++++++++++++++ platform/web/melange/core/lui_web_types.ml | 110 +++ platform/web/melange/core/lui_web_util.ml | 158 ++++ platform/web/melange/dune | 4 +- platform/web/melange/events/lui_web_events.ml | 20 + platform/web/melange/focus/lui_web_focus.ml | 59 ++ platform/web/melange/nodes/lui_web_nodes.ml | 32 + platform/web/melange/popup/lui_web_menu.ml | 37 + platform/web/melange/popup/lui_web_overlay.ml | 29 + .../web/melange/popup/lui_web_position.ml | 15 + platform/web/melange/render/lui_web_props.ml | 15 + platform/web/melange/shell/lui_web.ml | 200 +++++ platform/web/melange/shell/lui_web.mli | 45 ++ platform/web/melange/shell/lui_web_apply.ml | 13 + .../web/melange/shell/lui_web_simulator.ml | 26 + platform/web/melange/widgets/lui_web_split.ml | 18 + .../web/melange/widgets/lui_web_widgets.ml | 49 ++ 18 files changed, 1634 insertions(+), 1 deletion(-) create mode 100644 platform/web/melange/PORTING.md create mode 100644 platform/web/melange/core/lui_web_store.ml create mode 100644 platform/web/melange/core/lui_web_types.ml create mode 100644 platform/web/melange/core/lui_web_util.ml create mode 100644 platform/web/melange/events/lui_web_events.ml create mode 100644 platform/web/melange/focus/lui_web_focus.ml create mode 100644 platform/web/melange/nodes/lui_web_nodes.ml create mode 100644 platform/web/melange/popup/lui_web_menu.ml create mode 100644 platform/web/melange/popup/lui_web_overlay.ml create mode 100644 platform/web/melange/popup/lui_web_position.ml create mode 100644 platform/web/melange/render/lui_web_props.ml create mode 100644 platform/web/melange/shell/lui_web.ml create mode 100644 platform/web/melange/shell/lui_web.mli create mode 100644 platform/web/melange/shell/lui_web_apply.ml create mode 100644 platform/web/melange/shell/lui_web_simulator.ml create mode 100644 platform/web/melange/widgets/lui_web_split.ml create mode 100644 platform/web/melange/widgets/lui_web_widgets.ml 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..36fb08d7 --- /dev/null +++ b/platform/web/melange/core/lui_web_store.ml @@ -0,0 +1,738 @@ +(* 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 + +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 = true_property renderer node Enabled +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 | ListItem | Radio -> 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..ec712c01 --- /dev/null +++ b/platform/web/melange/core/lui_web_util.ml @@ -0,0 +1,158 @@ +(* 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" + +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..4903781d --- /dev/null +++ b/platform/web/melange/events/lui_web_events.ml @@ -0,0 +1,20 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let attach_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_events_bang" +let attach_events_bang = attach_events +let attach_text_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_text_events_bang" +let attach_text_events_bang = attach_text_events +let attach_toggle_event _a0 _a1 _a2 _a3 = failwith "unimplemented attach_toggle_event_bang" +let attach_toggle_event_bang = attach_toggle_event +let attach_radio_event _a0 _a1 _a2 = failwith "unimplemented attach_radio_event_bang" +let attach_radio_event_bang = attach_radio_event +let attach_slider_event _a0 _a1 _a2 = failwith "unimplemented attach_slider_event_bang" +let attach_slider_event_bang = attach_slider_event +let attach_list_item_events _a0 _a1 _a2 = failwith "unimplemented attach_list_item_events_bang" +let attach_list_item_events_bang = attach_list_item_events +let attach_pressable_text_events _a0 _a1 _a2 = failwith "unimplemented attach_pressable_text_events_bang" +let attach_pressable_text_events_bang = attach_pressable_text_events +let attach_accordion_event _a0 _a1 _a2 = failwith "unimplemented attach_accordion_event_bang" +let attach_accordion_event_bang = attach_accordion_event +(* TODO: attach_button_events_bang — internal helper, port without stub signature *) 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..8c306771 --- /dev/null +++ b/platform/web/melange/focus/lui_web_focus.ml @@ -0,0 +1,59 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let tree_ancestor _a0 _a1 = failwith "unimplemented tree_ancestor" +let tree_items_under _a0 _a1 = failwith "unimplemented tree_items_under" +let tree_focus_items_under _a0 _a1 = failwith "unimplemented tree_focus_items_under" +let derived_tree_item_level _a0 _a1 _a2 _a3 = failwith "unimplemented derived_tree_item_level" +let tree_item_level _a0 _a1 _a2 = failwith "unimplemented tree_item_level" +let update_tree_roving _a0 _a1 = failwith "unimplemented update_tree_roving_bang" +let update_tree_roving_bang = update_tree_roving +let refresh_tree_item_accessibility _a0 _a1 _a2 = failwith "unimplemented refresh_tree_item_accessibility_bang" +let refresh_tree_item_accessibility_bang = refresh_tree_item_accessibility +let update_all_tree_roving _a0 = failwith "unimplemented update_all_tree_roving_bang" +let update_all_tree_roving_bang = update_all_tree_roving +let dispatch_tree_selection _a0 _a1 = failwith "unimplemented dispatch_tree_selection_bang" +let dispatch_tree_selection_bang = dispatch_tree_selection +let attach_tree_item_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_tree_item_events_bang" +let attach_tree_item_events_bang = attach_tree_item_events +let horizontal_group_child _a0 _a1 = failwith "unimplemented horizontal_group_child_" +let horizontal_group_child_ = horizontal_group_child +let horizontal_focus_children _a0 _a1 _a2 = failwith "unimplemented horizontal_focus_children" +let focused_child_index _a0 _a1 _a2 _a3 = failwith "unimplemented focused_child_index" +let horizontal_focus_index _a0 _a1 _a2 = failwith "unimplemented horizontal_focus_index" +let attach_horizontal_focus _a0 _a1 _a2 _a3 = failwith "unimplemented attach_horizontal_focus_bang" +let attach_horizontal_focus_bang = attach_horizontal_focus +let toolbar_item_kind _a0 = failwith "unimplemented toolbar_item_kind_" +let toolbar_item_kind_ = toolbar_item_kind +let toolbar_all_items_under _a0 _a1 = failwith "unimplemented toolbar_all_items_under" +let toolbar_items_under _a0 _a1 = failwith "unimplemented toolbar_items_under" +let refresh_toolbar_roving _a0 _a1 = failwith "unimplemented refresh_toolbar_roving_bang" +let refresh_toolbar_roving_bang = refresh_toolbar_roving +let update_all_toolbar_roving _a0 = failwith "unimplemented update_all_toolbar_roving_bang" +let update_all_toolbar_roving_bang = update_all_toolbar_roving +let attach_toolbar_events _a0 _a1 _a2 = failwith "unimplemented attach_toolbar_events_bang" +let attach_toolbar_events_bang = attach_toolbar_events +let radio_group_ancestor _a0 _a1 = failwith "unimplemented radio_group_ancestor" +let update_radio_group _a0 _a1 = failwith "unimplemented update_radio_group_bang" +let update_radio_group_bang = update_radio_group +let refresh_horizontal_group_roving _a0 _a1 _a2 = failwith "unimplemented refresh_horizontal_group_roving_bang" +let refresh_horizontal_group_roving_bang = refresh_horizontal_group_roving +let update_all_horizontal_group_roving _a0 = failwith "unimplemented update_all_horizontal_group_roving_bang" +let update_all_horizontal_group_roving_bang = update_all_horizontal_group_roving +(* TODO: apply_toolbar_disabled_semantics_bang — internal helper, port without stub signature *) +(* TODO: refresh_tabs_roving_bang — internal helper, port without stub signature *) +(* TODO: refresh_button_context_bang — internal helper, port without stub signature *) +(* TODO: restore_focus_bang — internal helper, port without stub signature *) +(* TODO: focus_tree_item_bang — internal helper, port without stub signature *) +(* TODO: set_tree_tabstop_bang — internal helper, port without stub signature *) +(* TODO: attach_tree_events_bang — internal helper, port without stub signature *) +(* TODO: direct_tab_trigger_ — internal helper, port without stub signature *) + +(* cross-module stubs *) +let attach_tree_events _a0 _a1 _a2 = failwith "unimplemented attach_tree_events" +let apply_toolbar_disabled_semantics _a0 _a1 _a2 = failwith "unimplemented apply_toolbar_disabled_semantics" +let refresh_tabs_roving _a0 _a1 _a2 = failwith "unimplemented refresh_tabs_roving" +let refresh_button_context _a0 _a1 = failwith "unimplemented refresh_button_context" +let restore_focus _a0 = failwith "unimplemented restore_focus" +let focus_tree_item _a0 _a1 = failwith "unimplemented focus_tree_item" +let direct_tab_trigger _a0 _a1 = failwith "unimplemented direct_tab_trigger" 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..3463e744 --- /dev/null +++ b/platform/web/melange/nodes/lui_web_nodes.ml @@ -0,0 +1,32 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +(* TODO: base_class_name — internal helper, port without stub signature *) +let create_split_node _a0 = failwith "unimplemented create_split_node" +(* TODO: create_direct_toggle_node — internal helper, port without stub signature *) +(* TODO: create_button_node — internal helper, port without stub signature *) +(* TODO: create_combobox_node — internal helper, port without stub signature *) +(* TODO: create_select_node — internal helper, port without stub signature *) +(* TODO: create_menu_item_node — internal helper, port without stub signature *) +let create_dropdown_node _a0 = failwith "unimplemented create_dropdown_node" +(* TODO: create_avatar_node — internal helper, port without stub signature *) +(* TODO: create_media_node — internal helper, port without stub signature *) +let create_step_node _a0 = failwith "unimplemented create_step_node" +let create_timeline_item_node _a0 = failwith "unimplemented create_timeline_item_node" +(* TODO: create_accordion_node — internal helper, port without stub signature *) +(* TODO: create_simple_node — internal helper, port without stub signature *) +let create_bottom_tabs_node _a0 = failwith "unimplemented create_bottom_tabs_node" +(* TODO: create_modal_node — internal helper, port without stub signature *) +(* TODO: create_alert_node — internal helper, port without stub signature *) +(* TODO: create_bubble_node — internal helper, port without stub signature *) +let platform_node _a0 _a1 = failwith "unimplemented platform_node" +let dom_node _a0 _a1 = failwith "unimplemented dom_node" +let dom_node_before _a0 _a1 _a2 = failwith "unimplemented dom_node_before" +let dropdown_anchor_node _a0 _a1 = failwith "unimplemented dropdown_anchor_node" +let dropdown_side _a0 = failwith "unimplemented dropdown_side" +let dropdown_offset _a0 _a1 = failwith "unimplemented dropdown_offset" +let dropdown_listbox _a0 _a1 = failwith "unimplemented dropdown_listbox_" +let dropdown_listbox_ = dropdown_listbox + +(* cross-module stubs *) +let base_class_name _a0 = failwith "unimplemented base_class_name" 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..ad1ba6b3 --- /dev/null +++ b/platform/web/melange/popup/lui_web_menu.ml @@ -0,0 +1,37 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let attach_picker_press_event _a0 _a1 _a2 = failwith "unimplemented attach_picker_press_event_bang" +let attach_picker_press_event_bang = attach_picker_press_event +let attach_picker_trigger_events _a0 _a1 _a2 = failwith "unimplemented attach_picker_trigger_events_bang" +let attach_picker_trigger_events_bang = attach_picker_trigger_events +let attach_dropdown_events _a0 _a1 _a2 = failwith "unimplemented attach_dropdown_events_bang" +let attach_dropdown_events_bang = attach_dropdown_events +let direct_dropdown_menu _a0 _a1 = failwith "unimplemented direct_dropdown_menu" +let context_menu_focus_items _a0 _a1 = failwith "unimplemented context_menu_focus_items" +let focus_context_menu_item _a0 _a1 _a2 = failwith "unimplemented focus_context_menu_item_bang" +let focus_context_menu_item_bang = focus_context_menu_item +let set_dropdown_open _a0 _a1 _a2 = failwith "unimplemented set_dropdown_open_bang" +let set_dropdown_open_bang = set_dropdown_open +let mount_dropdown _a0 _a1 = failwith "unimplemented mount_dropdown_bang" +let mount_dropdown_bang = mount_dropdown +let dropdown_node _a0 _a1 = failwith "unimplemented dropdown_node_" +let dropdown_node_ = dropdown_node +(* TODO: picker_dropdown — internal helper, port without stub signature *) +(* TODO: attach_context_menu_events_bang — internal helper, port without stub signature *) +(* TODO: attach_context_host_events_bang — internal helper, port without stub signature *) +(* TODO: update_picker_expanded_bang — internal helper, port without stub signature *) +(* TODO: activate_menu_item_bang — internal helper, port without stub signature *) +(* TODO: set_combobox_active_bang — internal helper, port without stub signature *) + +(* cross-module stubs *) +let picker_dropdown _a0 _a1 = failwith "unimplemented picker_dropdown" +let attach_context_menu_events _a0 _a1 _a2 = failwith "unimplemented attach_context_menu_events" +let attach_context_host_events _a0 _a1 _a2 = failwith "unimplemented attach_context_host_events" +let update_picker_expanded _a0 _a1 = failwith "unimplemented update_picker_expanded" +let activate_menu_item _a0 _a1 = failwith "unimplemented activate_menu_item" +let set_combobox_active _a0 _a1 _a2 _a3 = failwith "unimplemented set_combobox_active" +let combobox_active_index _a0 _a1 _a2 = failwith "unimplemented combobox_active_index" +let picker_menu_items _a0 _a1 = failwith "unimplemented picker_menu_items" +let remove_dropdown_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_dropdown_after_exit" +let picker_selected_index _a0 _a1 = failwith "unimplemented picker_selected_index" 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..8085bd2e --- /dev/null +++ b/platform/web/melange/popup/lui_web_overlay.ml @@ -0,0 +1,29 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let modal_node _a0 _a1 = failwith "unimplemented modal_node_" +let modal_node_ = modal_node +let modal_layer_node _a0 = failwith "unimplemented modal_layer_node" +let anchored_tooltip _a0 = failwith "unimplemented anchored_tooltip_" +let anchored_tooltip_ = anchored_tooltip +let anchored_tooltip_node _a0 _a1 = failwith "unimplemented anchored_tooltip_node_" +let anchored_tooltip_node_ = anchored_tooltip_node +let refresh_modal_host_inert _a0 = failwith "unimplemented refresh_modal_host_inert_bang" +let refresh_modal_host_inert_bang = refresh_modal_host_inert +let tooltip_delay _a0 _a1 = failwith "unimplemented tooltip_delay" +let set_tooltip_open _a0 _a1 _a2 = failwith "unimplemented set_tooltip_open_bang" +let set_tooltip_open_bang = set_tooltip_open +let mount_tooltip _a0 _a1 _a2 = failwith "unimplemented mount_tooltip_bang" +let mount_tooltip_bang = mount_tooltip +let toast_duration _a0 _a1 = failwith "unimplemented toast_duration" +let first_toast_node _a0 _a1 = failwith "unimplemented first_toast_node_" +let first_toast_node_ = first_toast_node +let mount_toast _a0 _a1 _a2 = failwith "unimplemented mount_toast_bang" +let mount_toast_bang = mount_toast +let attach_modal_events _a0 _a1 _a2 = failwith "unimplemented attach_modal_events_bang" +let attach_modal_events_bang = attach_modal_events +(* TODO: open_modal_bang — internal helper, port without stub signature *) + +(* cross-module stubs *) +let open_modal _a0 _a1 = failwith "unimplemented open_modal" +let remove_modal_layer_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_modal_layer_after_exit" 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..7a942fd8 --- /dev/null +++ b/platform/web/melange/popup/lui_web_position.ml @@ -0,0 +1,15 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let clamp_popup_axis _a0 _a1 _a2 = failwith "unimplemented clamp_popup_axis" +let resolved_popup_side _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented resolved_popup_side" +let position_anchored _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented position_anchored_bang" +let position_anchored_bang = position_anchored +let position_tooltip _a0 _a1 = failwith "unimplemented position_tooltip_bang" +let position_tooltip_bang = position_tooltip +let position_dropdown _a0 _a1 = failwith "unimplemented position_dropdown_bang" +let position_dropdown_bang = position_dropdown +let point_in_triangle _a0 _a1 _a2 _a3 _a4 _a5 _a6 _a7 = failwith "unimplemented point_in_triangle_" +let point_in_triangle_ = point_in_triangle +let submenu_corridor _a0 _a1 _a2 _a3 _a4 _a5 = failwith "unimplemented submenu_corridor_" +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..22d6ed0c --- /dev/null +++ b/platform/web/melange/render/lui_web_props.ml @@ -0,0 +1,15 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let refresh_node_class _a0 _a1 _a2 _a3 = failwith "unimplemented refresh_node_class_bang" +let refresh_node_class_bang = refresh_node_class +let apply_property _a0 _a1 _a2 _a3 _a4 _a5 = failwith "unimplemented apply_property_bang" +let apply_property_bang = apply_property +(* TODO: remove_property_bang — internal helper, port without stub signature *) +(* TODO: set_accordion_open_bang — internal helper, port without stub signature *) +(* TODO: apply_text_value_bang — internal helper, port without stub signature *) + +(* cross-module stubs *) +let remove_property _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented remove_property" +let set_accordion_open _a0 _a1 _a2 _a3 = failwith "unimplemented set_accordion_open" +let apply_text_value _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented apply_text_value" diff --git a/platform/web/melange/shell/lui_web.ml b/platform/web/melange/shell/lui_web.ml new file mode 100644 index 00000000..ddbc8688 --- /dev/null +++ b/platform/web/melange/shell/lui_web.ml @@ -0,0 +1,200 @@ +(* 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 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 -> () + +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 + ignore + (Store.apply_batch_with_extensions renderer.web_store + (fun kind -> Lui_web_nodes.platform_node renderer kind) + (fun node identifier -> + extension_platform_node renderer node identifier) + renderer.web_extension_registry (fun _batch -> true) batch); + Lui_web_apply.apply_dom_batch renderer previous_nodes batch; + 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..45f563ac --- /dev/null +++ b/platform/web/melange/shell/lui_web_apply.ml @@ -0,0 +1,13 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let cleanup_node _a0 _a1 = failwith "unimplemented cleanup_node_bang" +let cleanup_node_bang = cleanup_node +let refresh_structured_children _a0 _a1 = failwith "unimplemented refresh_structured_children_bang" +let refresh_structured_children_bang = refresh_structured_children +let apply_dom_op _a0 _a1 _a2 = failwith "unimplemented apply_dom_op_bang" +let apply_dom_op_bang = apply_dom_op +let apply_dom_batch _a0 _a1 _a2 : unit = failwith "unimplemented apply_dom_batch_bang" +let apply_dom_batch_bang = apply_dom_batch +(* TODO: visible_child_index — internal helper, port without stub signature *) +(* TODO: focused_descendant — internal helper, port without stub signature *) 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..0e4bb04a --- /dev/null +++ b/platform/web/melange/shell/lui_web_simulator.ml @@ -0,0 +1,26 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let simulator_platform_name _a0 = failwith "unimplemented simulator_platform_name" +let simulator_form_factor_name _a0 = failwith "unimplemented simulator_form_factor_name" +let simulator_orientation_name _a0 = failwith "unimplemented simulator_orientation_name" +let simulator_pointer_name _a0 = failwith "unimplemented simulator_pointer_name" +let simulator_device _a0 _a1 _a2 = failwith "unimplemented simulator_device" +let set_simulator_device _a0 _a1 = failwith "unimplemented set_simulator_device_bang" +let set_simulator_device_bang = set_simulator_device +let set_simulator_form_factor _a0 _a1 = failwith "unimplemented set_simulator_form_factor_bang" +let set_simulator_form_factor_bang = set_simulator_form_factor +let rotate_simulator _a0 = failwith "unimplemented rotate_simulator_bang" +let rotate_simulator_bang = rotate_simulator +let set_simulator_keyboard_visible _a0 _a1 = failwith "unimplemented set_simulator_keyboard_visible_bang" +let set_simulator_keyboard_visible_bang = set_simulator_keyboard_visible +let set_simulator_platform _a0 _a1 = failwith "unimplemented set_simulator_platform_bang" +let set_simulator_platform_bang = set_simulator_platform +let apply_simulator_device_to_scope _a0 _a1 _a2 = failwith "unimplemented apply_simulator_device_to_scope_bang" +let apply_simulator_device_to_scope_bang = apply_simulator_device_to_scope +let simulator_text_entry _a0 = failwith "unimplemented simulator_text_entry_" +let simulator_text_entry_ = simulator_text_entry +let compact_sheet _a0 = failwith "unimplemented compact_sheet_" +let compact_sheet_ = compact_sheet +let attach_simulator_keyboard_events _a0 = failwith "unimplemented attach_simulator_keyboard_events_bang" +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..3ca385c3 --- /dev/null +++ b/platform/web/melange/widgets/lui_web_split.ml @@ -0,0 +1,18 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let split_base_fraction _a0 = failwith "unimplemented split_base_fraction" +let split_int_property _a0 _a1 _a2 _a3 = failwith "unimplemented split_int_property" +let split_child_minimum _a0 _a1 _a2 = failwith "unimplemented split_child_minimum" +let split_timing_function _a0 _a1 = failwith "unimplemented split_timing_function" +let effective_split_fraction _a0 _a1 _a2 = failwith "unimplemented effective_split_fraction" +let render_split _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented render_split_bang" +let render_split_bang = render_split +let reconcile_split _a0 _a1 _a2 _a3 = failwith "unimplemented reconcile_split_bang" +let reconcile_split_bang = reconcile_split +let update_split _a0 _a1 = failwith "unimplemented update_split_bang" +let update_split_bang = update_split +let update_splits_under _a0 _a1 = failwith "unimplemented update_splits_under_bang" +let update_splits_under_bang = update_splits_under +let attach_split_events _a0 _a1 _a2 = failwith "unimplemented attach_split_events_bang" +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..74e337ec --- /dev/null +++ b/platform/web/melange/widgets/lui_web_widgets.ml @@ -0,0 +1,49 @@ +(* STUB — replaced by the porting pass for this module. *) +(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) + +let register_image _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented register_image_bang" +let register_image_bang = register_image +let unregister_image _a0 _a1 = failwith "unimplemented unregister_image_bang" +let unregister_image_bang = unregister_image +let present_media_surface_frame _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented present_media_surface_frame_bang" +let present_media_surface_frame_bang = present_media_surface_frame +let unregister_media_surface _a0 _a1 = failwith "unimplemented unregister_media_surface_bang" +let unregister_media_surface_bang = unregister_media_surface +let avatar_float _a0 _a1 _a2 _a3 = failwith "unimplemented avatar_float" +let registered_avatar_image _a0 _a1 = failwith "unimplemented registered_avatar_image" +let media_size _a0 _a1 _a2 _a3 = failwith "unimplemented media_size" +let registered_image _a0 _a1 = failwith "unimplemented registered_image" +let update_avatar _a0 _a1 _a2 = failwith "unimplemented update_avatar_bang" +let update_avatar_bang = update_avatar +let refresh_image_id _a0 _a1 = failwith "unimplemented refresh_image_id_bang" +let refresh_image_id_bang = refresh_image_id +let update_image _a0 _a1 _a2 = failwith "unimplemented update_image_bang" +let update_image_bang = update_image +let update_media_surface _a0 _a1 _a2 = failwith "unimplemented update_media_surface_bang" +let update_media_surface_bang = update_media_surface +let refresh_media_surface_id _a0 _a1 = failwith "unimplemented refresh_media_surface_id_bang" +let refresh_media_surface_id_bang = refresh_media_surface_id +let update_icon_name _a0 _a1 _a2 = failwith "unimplemented update_icon_name_bang" +let update_icon_name_bang = update_icon_name +let bottom_tab_trigger _a0 _a1 = failwith "unimplemented bottom_tab_trigger" +let bottom_tab_string_property _a0 _a1 _a2 = failwith "unimplemented bottom_tab_string_property" +let refresh_bottom_tabs _a0 _a1 = failwith "unimplemented refresh_bottom_tabs_bang" +let refresh_bottom_tabs_bang = refresh_bottom_tabs +let create_bottom_tab_trigger _a0 _a1 _a2 _a3 = failwith "unimplemented create_bottom_tab_trigger_bang" +let create_bottom_tab_trigger_bang = create_bottom_tab_trigger +let string_property _a0 _a1 _a2 = failwith "unimplemented string_property" +let update_stepper _a0 _a1 = failwith "unimplemented update_stepper_bang" +let update_stepper_bang = update_stepper +let update_stepper_parent _a0 _a1 = failwith "unimplemented update_stepper_parent_bang" +let update_stepper_parent_bang = update_stepper_parent +let update_timeline _a0 _a1 = failwith "unimplemented update_timeline_bang" +let update_timeline_bang = update_timeline +let update_timeline_indicator _a0 _a1 _a2 = failwith "unimplemented update_timeline_indicator_bang" +let update_timeline_indicator_bang = update_timeline_indicator +let progress_float _a0 _a1 = failwith "unimplemented progress_float" +let update_progress _a0 _a1 _a2 = failwith "unimplemented update_progress_bang" +let update_progress_bang = update_progress +(* TODO: select_display_text — internal helper, port without stub signature *) + +(* cross-module stubs *) +let select_display_text _a0 _a1 = failwith "unimplemented select_display_text" From c6557f005947355f965516edbc3c41b0117f9415 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 22:53:38 -0700 Subject: [PATCH 02/21] =?UTF-8?q?web/melange:=20port=20nodes=20module=20?= =?UTF-8?q?=E2=80=94=20base-class=20table,=20element=20factories,=20dom=20?= =?UTF-8?q?lookups,=20dropdown=20anchors?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- platform/web/melange/nodes/lui_web_nodes.ml | 509 ++++++++++++++++++-- 1 file changed, 478 insertions(+), 31 deletions(-) diff --git a/platform/web/melange/nodes/lui_web_nodes.ml b/platform/web/melange/nodes/lui_web_nodes.ml index 3463e744..c8374651 100644 --- a/platform/web/melange/nodes/lui_web_nodes.ml +++ b/platform/web/melange/nodes/lui_web_nodes.ml @@ -1,32 +1,479 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) - -(* TODO: base_class_name — internal helper, port without stub signature *) -let create_split_node _a0 = failwith "unimplemented create_split_node" -(* TODO: create_direct_toggle_node — internal helper, port without stub signature *) -(* TODO: create_button_node — internal helper, port without stub signature *) -(* TODO: create_combobox_node — internal helper, port without stub signature *) -(* TODO: create_select_node — internal helper, port without stub signature *) -(* TODO: create_menu_item_node — internal helper, port without stub signature *) -let create_dropdown_node _a0 = failwith "unimplemented create_dropdown_node" -(* TODO: create_avatar_node — internal helper, port without stub signature *) -(* TODO: create_media_node — internal helper, port without stub signature *) -let create_step_node _a0 = failwith "unimplemented create_step_node" -let create_timeline_item_node _a0 = failwith "unimplemented create_timeline_item_node" -(* TODO: create_accordion_node — internal helper, port without stub signature *) -(* TODO: create_simple_node — internal helper, port without stub signature *) -let create_bottom_tabs_node _a0 = failwith "unimplemented create_bottom_tabs_node" -(* TODO: create_modal_node — internal helper, port without stub signature *) -(* TODO: create_alert_node — internal helper, port without stub signature *) -(* TODO: create_bubble_node — internal helper, port without stub signature *) -let platform_node _a0 _a1 = failwith "unimplemented platform_node" -let dom_node _a0 _a1 = failwith "unimplemented dom_node" -let dom_node_before _a0 _a1 _a2 = failwith "unimplemented dom_node_before" -let dropdown_anchor_node _a0 _a1 = failwith "unimplemented dropdown_anchor_node" -let dropdown_side _a0 = failwith "unimplemented dropdown_side" -let dropdown_offset _a0 _a1 = failwith "unimplemented dropdown_offset" -let dropdown_listbox _a0 _a1 = failwith "unimplemented dropdown_listbox_" -let dropdown_listbox_ = dropdown_listbox +(* 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") ] + | _ -> [] -(* cross-module stubs *) -let base_class_name _a0 = failwith "unimplemented base_class_name" +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 ^ "-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.standard_kind_is parent_node MenuItem 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 From 99069302d82fa711bd021448535d3f13f6a58c5a Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 22:56:51 -0700 Subject: [PATCH 03/21] web: port position module (popup geometry, transitions, corridor) Ports web.cljc 3137-3345 and 5439-5597 to OCaml/Melange: clamp-popup-axis, resolved-popup-side, position-anchored!, position-tooltip!, begin-popup-open!/close!, prefers-reduced-motion?, transition-event-from?, after-transition!, finish-popup-close-after-transition!, align-select-item-with-trigger!, position-dropdown!, point-in-triangle?, submenu-corridor?. Picker lookup helpers are replicated locally since position sits below menu in the module layering. --- .../web/melange/popup/lui_web_position.ml | 424 +++++++++++++++++- 1 file changed, 415 insertions(+), 9 deletions(-) diff --git a/platform/web/melange/popup/lui_web_position.ml b/platform/web/melange/popup/lui_web_position.ml index 7a942fd8..be99d8f8 100644 --- a/platform/web/melange/popup/lui_web_position.ml +++ b/platform/web/melange/popup/lui_web_position.ml @@ -1,15 +1,421 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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 clamp_popup_axis _a0 _a1 _a2 = failwith "unimplemented clamp_popup_axis" -let resolved_popup_side _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented resolved_popup_side" -let position_anchored _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented position_anchored_bang" let position_anchored_bang = position_anchored -let position_tooltip _a0 _a1 = failwith "unimplemented position_tooltip_bang" + +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 position_dropdown _a0 _a1 = failwith "unimplemented position_dropdown_bang" + +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.standard_kind_is child_node MenuItem + && 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 _a0 _a1 _a2 _a3 _a4 _a5 _a6 _a7 = failwith "unimplemented point_in_triangle_" + +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 _a0 _a1 _a2 _a3 _a4 _a5 = failwith "unimplemented submenu_corridor_" + +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 From cb7cb3cbccf852618ceabb748fbe149f635110b3 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:01:10 -0700 Subject: [PATCH 04/21] web/events: port event listeners + attach_events dispatcher from web.cljc --- platform/web/melange/events/lui_web_events.ml | 478 +++++++++++++++++- 1 file changed, 467 insertions(+), 11 deletions(-) diff --git a/platform/web/melange/events/lui_web_events.ml b/platform/web/melange/events/lui_web_events.ml index 4903781d..28a7099c 100644 --- a/platform/web/melange/events/lui_web_events.ml +++ b/platform/web/melange/events/lui_web_events.ml @@ -1,20 +1,476 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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 -> + 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 _a0 _a1 _a2 _a3 = failwith "unimplemented attach_events_bang" let attach_events_bang = attach_events -let attach_text_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_text_events_bang" let attach_text_events_bang = attach_text_events -let attach_toggle_event _a0 _a1 _a2 _a3 = failwith "unimplemented attach_toggle_event_bang" let attach_toggle_event_bang = attach_toggle_event -let attach_radio_event _a0 _a1 _a2 = failwith "unimplemented attach_radio_event_bang" let attach_radio_event_bang = attach_radio_event -let attach_slider_event _a0 _a1 _a2 = failwith "unimplemented attach_slider_event_bang" let attach_slider_event_bang = attach_slider_event -let attach_list_item_events _a0 _a1 _a2 = failwith "unimplemented attach_list_item_events_bang" let attach_list_item_events_bang = attach_list_item_events -let attach_pressable_text_events _a0 _a1 _a2 = failwith "unimplemented attach_pressable_text_events_bang" let attach_pressable_text_events_bang = attach_pressable_text_events -let attach_accordion_event _a0 _a1 _a2 = failwith "unimplemented attach_accordion_event_bang" let attach_accordion_event_bang = attach_accordion_event -(* TODO: attach_button_events_bang — internal helper, port without stub signature *) +let attach_button_events_bang = attach_button_events From 84e8a021622791212aa8b833474d62825b0435e9 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:04:10 -0700 Subject: [PATCH 05/21] web(melange): port simulator module (device emulation, keyboard visibility) --- .../web/melange/shell/lui_web_simulator.ml | 221 ++++++++++++++++-- 1 file changed, 202 insertions(+), 19 deletions(-) diff --git a/platform/web/melange/shell/lui_web_simulator.ml b/platform/web/melange/shell/lui_web_simulator.ml index 0e4bb04a..c7768309 100644 --- a/platform/web/melange/shell/lui_web_simulator.ml +++ b/platform/web/melange/shell/lui_web_simulator.ml @@ -1,26 +1,209 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) - -let simulator_platform_name _a0 = failwith "unimplemented simulator_platform_name" -let simulator_form_factor_name _a0 = failwith "unimplemented simulator_form_factor_name" -let simulator_orientation_name _a0 = failwith "unimplemented simulator_orientation_name" -let simulator_pointer_name _a0 = failwith "unimplemented simulator_pointer_name" -let simulator_device _a0 _a1 _a2 = failwith "unimplemented simulator_device" -let set_simulator_device _a0 _a1 = failwith "unimplemented set_simulator_device_bang" +(* 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" + (string_of_float 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_form_factor _a0 _a1 = failwith "unimplemented set_simulator_form_factor_bang" + +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 _a0 = failwith "unimplemented rotate_simulator_bang" + +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_keyboard_visible _a0 _a1 = failwith "unimplemented set_simulator_keyboard_visible_bang" -let set_simulator_keyboard_visible_bang = set_simulator_keyboard_visible -let set_simulator_platform _a0 _a1 = failwith "unimplemented set_simulator_platform_bang" + +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 apply_simulator_device_to_scope _a0 _a1 _a2 = failwith "unimplemented apply_simulator_device_to_scope_bang" -let apply_simulator_device_to_scope_bang = apply_simulator_device_to_scope -let simulator_text_entry _a0 = failwith "unimplemented simulator_text_entry_" + +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 _a0 = failwith "unimplemented compact_sheet_" + +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 _a0 = failwith "unimplemented attach_simulator_keyboard_events_bang" + +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 From 1490c5e7934c6973201fd00952862c45e323d7a7 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:09:21 -0700 Subject: [PATCH 06/21] Port apply-dom-batch DOM mutation layer + extension plumbing - shell/lui_web_apply.ml: apply_dom_op/apply_dom_batch covering CreateNode/CreateExtension/DropNode/SetProp/RemoveProp/ SetExtensionProp/RemoveExtensionProp/InsertChild/RemoveChild/MoveChild, portal routing (dropdown/modal/tooltip/context-menu/toast), bottom-tabs page+trigger handling, visible-child-index hiding popup kinds, focus save/restore across moves, post-batch roving refresh. - shell/lui_web_extensions.ml: extension adapter lookup, platform node creation, prop apply/remove, cleanup (split out so apply can use it without a lui_web cycle; lui_web re-exports for API parity). - Stub arity/return-type fixes so callers compile clean under warnings-as-errors. --- platform/web/melange/events/lui_web_events.ml | 2 +- platform/web/melange/focus/lui_web_focus.ml | 14 +- platform/web/melange/popup/lui_web_menu.ml | 10 +- platform/web/melange/popup/lui_web_overlay.ml | 14 +- .../web/melange/popup/lui_web_position.ml | 4 +- platform/web/melange/render/lui_web_props.ml | 8 +- platform/web/melange/shell/lui_web.ml | 55 +-- platform/web/melange/shell/lui_web_apply.ml | 412 +++++++++++++++++- .../web/melange/shell/lui_web_extensions.ml | 50 +++ platform/web/melange/widgets/lui_web_split.ml | 4 +- .../web/melange/widgets/lui_web_widgets.ml | 10 +- 11 files changed, 494 insertions(+), 89 deletions(-) create mode 100644 platform/web/melange/shell/lui_web_extensions.ml diff --git a/platform/web/melange/events/lui_web_events.ml b/platform/web/melange/events/lui_web_events.ml index 4903781d..eaa4de51 100644 --- a/platform/web/melange/events/lui_web_events.ml +++ b/platform/web/melange/events/lui_web_events.ml @@ -1,7 +1,7 @@ (* STUB — replaced by the porting pass for this module. *) (* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) -let attach_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_events_bang" +let attach_events _a0 _a1 _a2 _a3 : unit = failwith "unimplemented attach_events_bang" let attach_events_bang = attach_events let attach_text_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_text_events_bang" let attach_text_events_bang = attach_text_events diff --git a/platform/web/melange/focus/lui_web_focus.ml b/platform/web/melange/focus/lui_web_focus.ml index 8c306771..a14298a9 100644 --- a/platform/web/melange/focus/lui_web_focus.ml +++ b/platform/web/melange/focus/lui_web_focus.ml @@ -10,7 +10,7 @@ let update_tree_roving _a0 _a1 = failwith "unimplemented update_tree_roving_ban let update_tree_roving_bang = update_tree_roving let refresh_tree_item_accessibility _a0 _a1 _a2 = failwith "unimplemented refresh_tree_item_accessibility_bang" let refresh_tree_item_accessibility_bang = refresh_tree_item_accessibility -let update_all_tree_roving _a0 = failwith "unimplemented update_all_tree_roving_bang" +let update_all_tree_roving _a0 : unit = failwith "unimplemented update_all_tree_roving_bang" let update_all_tree_roving_bang = update_all_tree_roving let dispatch_tree_selection _a0 _a1 = failwith "unimplemented dispatch_tree_selection_bang" let dispatch_tree_selection_bang = dispatch_tree_selection @@ -29,16 +29,16 @@ let toolbar_all_items_under _a0 _a1 = failwith "unimplemented toolbar_all_items_ let toolbar_items_under _a0 _a1 = failwith "unimplemented toolbar_items_under" let refresh_toolbar_roving _a0 _a1 = failwith "unimplemented refresh_toolbar_roving_bang" let refresh_toolbar_roving_bang = refresh_toolbar_roving -let update_all_toolbar_roving _a0 = failwith "unimplemented update_all_toolbar_roving_bang" +let update_all_toolbar_roving _a0 : unit = failwith "unimplemented update_all_toolbar_roving_bang" let update_all_toolbar_roving_bang = update_all_toolbar_roving let attach_toolbar_events _a0 _a1 _a2 = failwith "unimplemented attach_toolbar_events_bang" let attach_toolbar_events_bang = attach_toolbar_events let radio_group_ancestor _a0 _a1 = failwith "unimplemented radio_group_ancestor" -let update_radio_group _a0 _a1 = failwith "unimplemented update_radio_group_bang" +let update_radio_group _a0 _a1 : unit = failwith "unimplemented update_radio_group_bang" let update_radio_group_bang = update_radio_group let refresh_horizontal_group_roving _a0 _a1 _a2 = failwith "unimplemented refresh_horizontal_group_roving_bang" let refresh_horizontal_group_roving_bang = refresh_horizontal_group_roving -let update_all_horizontal_group_roving _a0 = failwith "unimplemented update_all_horizontal_group_roving_bang" +let update_all_horizontal_group_roving _a0 : unit = failwith "unimplemented update_all_horizontal_group_roving_bang" let update_all_horizontal_group_roving_bang = update_all_horizontal_group_roving (* TODO: apply_toolbar_disabled_semantics_bang — internal helper, port without stub signature *) (* TODO: refresh_tabs_roving_bang — internal helper, port without stub signature *) @@ -52,8 +52,8 @@ let update_all_horizontal_group_roving_bang = update_all_horizontal_group_roving (* cross-module stubs *) let attach_tree_events _a0 _a1 _a2 = failwith "unimplemented attach_tree_events" let apply_toolbar_disabled_semantics _a0 _a1 _a2 = failwith "unimplemented apply_toolbar_disabled_semantics" -let refresh_tabs_roving _a0 _a1 _a2 = failwith "unimplemented refresh_tabs_roving" -let refresh_button_context _a0 _a1 = failwith "unimplemented refresh_button_context" -let restore_focus _a0 = failwith "unimplemented restore_focus" +let refresh_tabs_roving _a0 _a1 _a2 : unit = failwith "unimplemented refresh_tabs_roving" +let refresh_button_context _a0 _a1 : unit = failwith "unimplemented refresh_button_context" +let restore_focus _a0 _a1 : unit = failwith "unimplemented restore_focus" let focus_tree_item _a0 _a1 = failwith "unimplemented focus_tree_item" let direct_tab_trigger _a0 _a1 = failwith "unimplemented direct_tab_trigger" diff --git a/platform/web/melange/popup/lui_web_menu.ml b/platform/web/melange/popup/lui_web_menu.ml index ad1ba6b3..853e4887 100644 --- a/platform/web/melange/popup/lui_web_menu.ml +++ b/platform/web/melange/popup/lui_web_menu.ml @@ -13,7 +13,7 @@ let focus_context_menu_item _a0 _a1 _a2 = failwith "unimplemented focus_context let focus_context_menu_item_bang = focus_context_menu_item let set_dropdown_open _a0 _a1 _a2 = failwith "unimplemented set_dropdown_open_bang" let set_dropdown_open_bang = set_dropdown_open -let mount_dropdown _a0 _a1 = failwith "unimplemented mount_dropdown_bang" +let mount_dropdown _a0 _a1 : unit = failwith "unimplemented mount_dropdown_bang" let mount_dropdown_bang = mount_dropdown let dropdown_node _a0 _a1 = failwith "unimplemented dropdown_node_" let dropdown_node_ = dropdown_node @@ -28,10 +28,14 @@ let dropdown_node_ = dropdown_node let picker_dropdown _a0 _a1 = failwith "unimplemented picker_dropdown" let attach_context_menu_events _a0 _a1 _a2 = failwith "unimplemented attach_context_menu_events" let attach_context_host_events _a0 _a1 _a2 = failwith "unimplemented attach_context_host_events" -let update_picker_expanded _a0 _a1 = failwith "unimplemented update_picker_expanded" +let update_picker_expanded _a0 _a1 _a2 : unit = failwith "unimplemented update_picker_expanded" let activate_menu_item _a0 _a1 = failwith "unimplemented activate_menu_item" let set_combobox_active _a0 _a1 _a2 _a3 = failwith "unimplemented set_combobox_active" let combobox_active_index _a0 _a1 _a2 = failwith "unimplemented combobox_active_index" let picker_menu_items _a0 _a1 = failwith "unimplemented picker_menu_items" -let remove_dropdown_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_dropdown_after_exit" +let remove_dropdown_after_exit _a0 _a1 _a2 : unit = failwith "unimplemented remove_dropdown_after_exit" let picker_selected_index _a0 _a1 = failwith "unimplemented picker_selected_index" +let refresh_dropdown_item_roles _a0 _a1 : unit = failwith "unimplemented refresh_dropdown_item_roles" +let refresh_combobox_list_state _a0 _a1 : bool = failwith "unimplemented refresh_combobox_list_state" +let ensure_combobox_status _a0 _a1 = failwith "unimplemented ensure_combobox_status" +let clear_combobox_active _a0 _a1 = failwith "unimplemented clear_combobox_active" diff --git a/platform/web/melange/popup/lui_web_overlay.ml b/platform/web/melange/popup/lui_web_overlay.ml index 8085bd2e..dceb3042 100644 --- a/platform/web/melange/popup/lui_web_overlay.ml +++ b/platform/web/melange/popup/lui_web_overlay.ml @@ -8,22 +8,22 @@ let anchored_tooltip _a0 = failwith "unimplemented anchored_tooltip_" let anchored_tooltip_ = anchored_tooltip let anchored_tooltip_node _a0 _a1 = failwith "unimplemented anchored_tooltip_node_" let anchored_tooltip_node_ = anchored_tooltip_node -let refresh_modal_host_inert _a0 = failwith "unimplemented refresh_modal_host_inert_bang" +let refresh_modal_host_inert _a0 : unit = failwith "unimplemented refresh_modal_host_inert_bang" let refresh_modal_host_inert_bang = refresh_modal_host_inert let tooltip_delay _a0 _a1 = failwith "unimplemented tooltip_delay" -let set_tooltip_open _a0 _a1 _a2 = failwith "unimplemented set_tooltip_open_bang" +let set_tooltip_open _a0 _a1 _a2 : unit = failwith "unimplemented set_tooltip_open_bang" let set_tooltip_open_bang = set_tooltip_open -let mount_tooltip _a0 _a1 _a2 = failwith "unimplemented mount_tooltip_bang" +let mount_tooltip _a0 _a1 _a2 : unit = failwith "unimplemented mount_tooltip_bang" let mount_tooltip_bang = mount_tooltip let toast_duration _a0 _a1 = failwith "unimplemented toast_duration" let first_toast_node _a0 _a1 = failwith "unimplemented first_toast_node_" let first_toast_node_ = first_toast_node -let mount_toast _a0 _a1 _a2 = failwith "unimplemented mount_toast_bang" +let mount_toast _a0 _a1 _a2 : unit = failwith "unimplemented mount_toast_bang" let mount_toast_bang = mount_toast -let attach_modal_events _a0 _a1 _a2 = failwith "unimplemented attach_modal_events_bang" +let attach_modal_events _a0 _a1 _a2 : unit = failwith "unimplemented attach_modal_events_bang" let attach_modal_events_bang = attach_modal_events (* TODO: open_modal_bang — internal helper, port without stub signature *) (* cross-module stubs *) -let open_modal _a0 _a1 = failwith "unimplemented open_modal" -let remove_modal_layer_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_modal_layer_after_exit" +let open_modal _a0 _a1 _a2 : unit = failwith "unimplemented open_modal" +let remove_modal_layer_after_exit _a0 _a1 _a2 _a3 _a4 : unit = failwith "unimplemented remove_modal_layer_after_exit" diff --git a/platform/web/melange/popup/lui_web_position.ml b/platform/web/melange/popup/lui_web_position.ml index 7a942fd8..8f5f2b53 100644 --- a/platform/web/melange/popup/lui_web_position.ml +++ b/platform/web/melange/popup/lui_web_position.ml @@ -5,9 +5,9 @@ let clamp_popup_axis _a0 _a1 _a2 = failwith "unimplemented clamp_popup_axis" let resolved_popup_side _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented resolved_popup_side" let position_anchored _a0 _a1 _a2 _a3 _a4 _a5 _a6 = failwith "unimplemented position_anchored_bang" let position_anchored_bang = position_anchored -let position_tooltip _a0 _a1 = failwith "unimplemented position_tooltip_bang" +let position_tooltip _a0 _a1 : unit = failwith "unimplemented position_tooltip_bang" let position_tooltip_bang = position_tooltip -let position_dropdown _a0 _a1 = failwith "unimplemented position_dropdown_bang" +let position_dropdown _a0 _a1 : unit = failwith "unimplemented position_dropdown_bang" let position_dropdown_bang = position_dropdown let point_in_triangle _a0 _a1 _a2 _a3 _a4 _a5 _a6 _a7 = failwith "unimplemented point_in_triangle_" let point_in_triangle_ = point_in_triangle diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml index 22d6ed0c..3da04b59 100644 --- a/platform/web/melange/render/lui_web_props.ml +++ b/platform/web/melange/render/lui_web_props.ml @@ -3,13 +3,13 @@ let refresh_node_class _a0 _a1 _a2 _a3 = failwith "unimplemented refresh_node_class_bang" let refresh_node_class_bang = refresh_node_class -let apply_property _a0 _a1 _a2 _a3 _a4 _a5 = failwith "unimplemented apply_property_bang" +let apply_property _a0 _a1 _a2 _a3 _a4 _a5 : unit = failwith "unimplemented apply_property_bang" let apply_property_bang = apply_property (* TODO: remove_property_bang — internal helper, port without stub signature *) (* TODO: set_accordion_open_bang — internal helper, port without stub signature *) (* TODO: apply_text_value_bang — internal helper, port without stub signature *) (* cross-module stubs *) -let remove_property _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented remove_property" -let set_accordion_open _a0 _a1 _a2 _a3 = failwith "unimplemented set_accordion_open" -let apply_text_value _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented apply_text_value" +let remove_property _a0 _a1 _a2 : unit = failwith "unimplemented remove_property" +let set_accordion_open _a0 _a1 _a2 _a3 : unit = failwith "unimplemented set_accordion_open" +let apply_text_value _a0 _a1 _a2 _a3 _a4 : unit = failwith "unimplemented apply_text_value" diff --git a/platform/web/melange/shell/lui_web.ml b/platform/web/melange/shell/lui_web.ml index ddbc8688..4cd67a0b 100644 --- a/platform/web/melange/shell/lui_web.ml +++ b/platform/web/melange/shell/lui_web.ml @@ -69,51 +69,16 @@ let create ?(app_icons = String_map.empty) host = create_with_extensions host app_icons (Lui_extension.registry ()) String_map.empty -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 extension_adapter = Lui_web_extensions.extension_adapter +let extension_platform_node = Lui_web_extensions.extension_platform_node -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 -> () +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; @@ -128,7 +93,7 @@ let backend renderer = (Store.apply_batch_with_extensions renderer.web_store (fun kind -> Lui_web_nodes.platform_node renderer kind) (fun node identifier -> - extension_platform_node renderer node identifier) + Lui_web_extensions.extension_platform_node renderer node identifier) renderer.web_extension_registry (fun _batch -> true) batch); Lui_web_apply.apply_dom_batch renderer previous_nodes batch; true) } diff --git a/platform/web/melange/shell/lui_web_apply.ml b/platform/web/melange/shell/lui_web_apply.ml index 45f563ac..721bf996 100644 --- a/platform/web/melange/shell/lui_web_apply.ml +++ b/platform/web/melange/shell/lui_web_apply.ml @@ -1,13 +1,399 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) - -let cleanup_node _a0 _a1 = failwith "unimplemented cleanup_node_bang" -let cleanup_node_bang = cleanup_node -let refresh_structured_children _a0 _a1 = failwith "unimplemented refresh_structured_children_bang" -let refresh_structured_children_bang = refresh_structured_children -let apply_dom_op _a0 _a1 _a2 = failwith "unimplemented apply_dom_op_bang" -let apply_dom_op_bang = apply_dom_op -let apply_dom_batch _a0 _a1 _a2 : unit = failwith "unimplemented apply_dom_batch_bang" -let apply_dom_batch_bang = apply_dom_batch -(* TODO: visible_child_index — internal helper, port without stub signature *) -(* TODO: focused_descendant — internal helper, port without stub signature *) +(* 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.standard_kind_is current MenuItem 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.standard_kind_is parent_node MenuItem 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 -> + 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 -> + Lui_web_props.apply_property renderer node + (Store.standard_kind current) current.platform_node property value; + refresh_parent_for_prop renderer node property + | None -> invalid_arg "unknown DOM node" + +let apply_remove_prop renderer node property = + Lui_web_props.remove_property renderer node property; + refresh_parent_for_prop renderer node property + +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; + Lui_web_focus.update_all_horizontal_group_roving renderer; + Lui_web_focus.update_all_tree_roving renderer; + 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/widgets/lui_web_split.ml b/platform/web/melange/widgets/lui_web_split.ml index 3ca385c3..82e25685 100644 --- a/platform/web/melange/widgets/lui_web_split.ml +++ b/platform/web/melange/widgets/lui_web_split.ml @@ -10,9 +10,9 @@ let render_split _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented render_split_ban let render_split_bang = render_split let reconcile_split _a0 _a1 _a2 _a3 = failwith "unimplemented reconcile_split_bang" let reconcile_split_bang = reconcile_split -let update_split _a0 _a1 = failwith "unimplemented update_split_bang" +let update_split _a0 _a1 : unit = failwith "unimplemented update_split_bang" let update_split_bang = update_split -let update_splits_under _a0 _a1 = failwith "unimplemented update_splits_under_bang" +let update_splits_under _a0 _a1 : unit = failwith "unimplemented update_splits_under_bang" let update_splits_under_bang = update_splits_under let attach_split_events _a0 _a1 _a2 = failwith "unimplemented attach_split_events_bang" 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 index 74e337ec..a6f938b0 100644 --- a/platform/web/melange/widgets/lui_web_widgets.ml +++ b/platform/web/melange/widgets/lui_web_widgets.ml @@ -25,18 +25,18 @@ let refresh_media_surface_id _a0 _a1 = failwith "unimplemented refresh_media_su let refresh_media_surface_id_bang = refresh_media_surface_id let update_icon_name _a0 _a1 _a2 = failwith "unimplemented update_icon_name_bang" let update_icon_name_bang = update_icon_name -let bottom_tab_trigger _a0 _a1 = failwith "unimplemented bottom_tab_trigger" +let bottom_tab_trigger _a0 _a1 : Dom.element option = failwith "unimplemented bottom_tab_trigger" let bottom_tab_string_property _a0 _a1 _a2 = failwith "unimplemented bottom_tab_string_property" -let refresh_bottom_tabs _a0 _a1 = failwith "unimplemented refresh_bottom_tabs_bang" +let refresh_bottom_tabs _a0 _a1 : unit = failwith "unimplemented refresh_bottom_tabs_bang" let refresh_bottom_tabs_bang = refresh_bottom_tabs -let create_bottom_tab_trigger _a0 _a1 _a2 _a3 = failwith "unimplemented create_bottom_tab_trigger_bang" +let create_bottom_tab_trigger _a0 _a1 _a2 _a3 : Dom.element = failwith "unimplemented create_bottom_tab_trigger_bang" let create_bottom_tab_trigger_bang = create_bottom_tab_trigger let string_property _a0 _a1 _a2 = failwith "unimplemented string_property" -let update_stepper _a0 _a1 = failwith "unimplemented update_stepper_bang" +let update_stepper _a0 _a1 : unit = failwith "unimplemented update_stepper_bang" let update_stepper_bang = update_stepper let update_stepper_parent _a0 _a1 = failwith "unimplemented update_stepper_parent_bang" let update_stepper_parent_bang = update_stepper_parent -let update_timeline _a0 _a1 = failwith "unimplemented update_timeline_bang" +let update_timeline _a0 _a1 : unit = failwith "unimplemented update_timeline_bang" let update_timeline_bang = update_timeline let update_timeline_indicator _a0 _a1 _a2 = failwith "unimplemented update_timeline_indicator_bang" let update_timeline_indicator_bang = update_timeline_indicator From d836b269ca77626e4697e2f21e285d1057deba02 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:13:36 -0700 Subject: [PATCH 07/21] web/focus: port tree/horizontal/toolbar/tabs roving + radio + restore-focus from web.cljc --- platform/web/melange/focus/lui_web_focus.ml | 947 +++++++++++++++++++- 1 file changed, 898 insertions(+), 49 deletions(-) diff --git a/platform/web/melange/focus/lui_web_focus.ml b/platform/web/melange/focus/lui_web_focus.ml index 8c306771..69e47706 100644 --- a/platform/web/melange/focus/lui_web_focus.ml +++ b/platform/web/melange/focus/lui_web_focus.ml @@ -1,59 +1,908 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) - -let tree_ancestor _a0 _a1 = failwith "unimplemented tree_ancestor" -let tree_items_under _a0 _a1 = failwith "unimplemented tree_items_under" -let tree_focus_items_under _a0 _a1 = failwith "unimplemented tree_focus_items_under" -let derived_tree_item_level _a0 _a1 _a2 _a3 = failwith "unimplemented derived_tree_item_level" -let tree_item_level _a0 _a1 _a2 = failwith "unimplemented tree_item_level" -let update_tree_roving _a0 _a1 = failwith "unimplemented update_tree_roving_bang" -let update_tree_roving_bang = update_tree_roving -let refresh_tree_item_accessibility _a0 _a1 _a2 = failwith "unimplemented refresh_tree_item_accessibility_bang" +(* 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 update_all_tree_roving _a0 = failwith "unimplemented update_all_tree_roving_bang" + +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 dispatch_tree_selection _a0 _a1 = failwith "unimplemented dispatch_tree_selection_bang" -let dispatch_tree_selection_bang = dispatch_tree_selection -let attach_tree_item_events _a0 _a1 _a2 _a3 = failwith "unimplemented attach_tree_item_events_bang" + +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 horizontal_group_child _a0 _a1 = failwith "unimplemented horizontal_group_child_" + +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_focus_children _a0 _a1 _a2 = failwith "unimplemented horizontal_focus_children" -let focused_child_index _a0 _a1 _a2 _a3 = failwith "unimplemented focused_child_index" -let horizontal_focus_index _a0 _a1 _a2 = failwith "unimplemented horizontal_focus_index" -let attach_horizontal_focus _a0 _a1 _a2 _a3 = failwith "unimplemented attach_horizontal_focus_bang" + +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 _a0 = failwith "unimplemented toolbar_item_kind_" + +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 _a0 _a1 = failwith "unimplemented toolbar_all_items_under" -let toolbar_items_under _a0 _a1 = failwith "unimplemented toolbar_items_under" -let refresh_toolbar_roving _a0 _a1 = failwith "unimplemented refresh_toolbar_roving_bang" + +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 _a0 = failwith "unimplemented update_all_toolbar_roving_bang" + +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 _a0 _a1 _a2 = failwith "unimplemented attach_toolbar_events_bang" + +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 radio_group_ancestor _a0 _a1 = failwith "unimplemented radio_group_ancestor" -let update_radio_group _a0 _a1 = failwith "unimplemented update_radio_group_bang" + +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 -let refresh_horizontal_group_roving _a0 _a1 _a2 = failwith "unimplemented refresh_horizontal_group_roving_bang" -let refresh_horizontal_group_roving_bang = refresh_horizontal_group_roving -let update_all_horizontal_group_roving _a0 = failwith "unimplemented update_all_horizontal_group_roving_bang" -let update_all_horizontal_group_roving_bang = update_all_horizontal_group_roving -(* TODO: apply_toolbar_disabled_semantics_bang — internal helper, port without stub signature *) -(* TODO: refresh_tabs_roving_bang — internal helper, port without stub signature *) -(* TODO: refresh_button_context_bang — internal helper, port without stub signature *) -(* TODO: restore_focus_bang — internal helper, port without stub signature *) -(* TODO: focus_tree_item_bang — internal helper, port without stub signature *) -(* TODO: set_tree_tabstop_bang — internal helper, port without stub signature *) -(* TODO: attach_tree_events_bang — internal helper, port without stub signature *) -(* TODO: direct_tab_trigger_ — internal helper, port without stub signature *) - -(* cross-module stubs *) -let attach_tree_events _a0 _a1 _a2 = failwith "unimplemented attach_tree_events" -let apply_toolbar_disabled_semantics _a0 _a1 _a2 = failwith "unimplemented apply_toolbar_disabled_semantics" -let refresh_tabs_roving _a0 _a1 _a2 = failwith "unimplemented refresh_tabs_roving" -let refresh_button_context _a0 _a1 = failwith "unimplemented refresh_button_context" -let restore_focus _a0 = failwith "unimplemented restore_focus" -let focus_tree_item _a0 _a1 = failwith "unimplemented focus_tree_item" -let direct_tab_trigger _a0 _a1 = failwith "unimplemented direct_tab_trigger" From c635983b0327fe33f612359e634bd960c6ded009 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:17:12 -0700 Subject: [PATCH 08/21] Port menu module (picker/combobox, dropdown, context-menu) to OCaml/Melange Ported from web.cljc: - 866-1055 picker/combobox plumbing (picker-dropdown ... activate-menu-item!) - 1261-1322 attach-picker-press-event! / attach-picker-trigger-events! - 1694-1710 dropdown-group-contains-event? - 2047-2210 attach-dropdown-events! (pointer/click/resize/key handlers, typeahead) - 2806-3131 context-menu (direct-context-menu ... attach-context-menu-events!) - 5597-5794 set-dropdown-open! / mount-dropdown! (submenu hover wiring) - 5843-5860 update-picker-expanded! / 5894-5907 remove-dropdown-after-exit! Popup transition helpers (begin_popup_open/close, after_transition, finish_popup_close_after_transition) implemented locally since Lui_web_position does not expose them yet. --- platform/web/melange/popup/lui_web_menu.ml | 1058 +++++++++++++++++++- 1 file changed, 1026 insertions(+), 32 deletions(-) diff --git a/platform/web/melange/popup/lui_web_menu.ml b/platform/web/melange/popup/lui_web_menu.ml index ad1ba6b3..72132ec5 100644 --- a/platform/web/melange/popup/lui_web_menu.ml +++ b/platform/web/melange/popup/lui_web_menu.ml @@ -1,37 +1,1031 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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.standard_kind_is child_node MenuItem + && 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.standard_kind_is current MenuItem 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.standard_kind_is child_node MenuItem + && 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 _a0 _a1 _a2 = failwith "unimplemented attach_picker_press_event_bang" let attach_picker_press_event_bang = attach_picker_press_event -let attach_picker_trigger_events _a0 _a1 _a2 = failwith "unimplemented attach_picker_trigger_events_bang" + +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 -let attach_dropdown_events _a0 _a1 _a2 = failwith "unimplemented attach_dropdown_events_bang" + +(* --- 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.standard_kind_is candidate_node MenuItem 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 -let direct_dropdown_menu _a0 _a1 = failwith "unimplemented direct_dropdown_menu" -let context_menu_focus_items _a0 _a1 = failwith "unimplemented context_menu_focus_items" -let focus_context_menu_item _a0 _a1 _a2 = failwith "unimplemented focus_context_menu_item_bang" -let focus_context_menu_item_bang = focus_context_menu_item -let set_dropdown_open _a0 _a1 _a2 = failwith "unimplemented set_dropdown_open_bang" -let set_dropdown_open_bang = set_dropdown_open -let mount_dropdown _a0 _a1 = failwith "unimplemented mount_dropdown_bang" + +(* --- 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 --- *) + +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 + 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 + +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 + ignore + (Js.Global.setTimeout + ~f:(fun () -> + match Store.node renderer.web_store node with + | Some _menu -> + set_combobox_active renderer picker node 0 + | None -> ()) + 0) + else + ignore + (Js.Global.setTimeout + ~f:(fun () -> + match Store.node renderer.web_store node with + | Some _menu -> + focus_context_menu_item renderer node + (picker_selected_index renderer node) + | None -> ()) + 0) + | 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.standard_kind_is parent_node MenuItem 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 dropdown_node _a0 _a1 = failwith "unimplemented dropdown_node_" -let dropdown_node_ = dropdown_node -(* TODO: picker_dropdown — internal helper, port without stub signature *) -(* TODO: attach_context_menu_events_bang — internal helper, port without stub signature *) -(* TODO: attach_context_host_events_bang — internal helper, port without stub signature *) -(* TODO: update_picker_expanded_bang — internal helper, port without stub signature *) -(* TODO: activate_menu_item_bang — internal helper, port without stub signature *) -(* TODO: set_combobox_active_bang — internal helper, port without stub signature *) - -(* cross-module stubs *) -let picker_dropdown _a0 _a1 = failwith "unimplemented picker_dropdown" -let attach_context_menu_events _a0 _a1 _a2 = failwith "unimplemented attach_context_menu_events" -let attach_context_host_events _a0 _a1 _a2 = failwith "unimplemented attach_context_host_events" -let update_picker_expanded _a0 _a1 = failwith "unimplemented update_picker_expanded" -let activate_menu_item _a0 _a1 = failwith "unimplemented activate_menu_item" -let set_combobox_active _a0 _a1 _a2 _a3 = failwith "unimplemented set_combobox_active" -let combobox_active_index _a0 _a1 _a2 = failwith "unimplemented combobox_active_index" -let picker_menu_items _a0 _a1 = failwith "unimplemented picker_menu_items" -let remove_dropdown_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_dropdown_after_exit" -let picker_selected_index _a0 _a1 = failwith "unimplemented picker_selected_index" + +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)) From a425028655029c998ab0ca3e139ad449e2c11b0f Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:17:39 -0700 Subject: [PATCH 09/21] =?UTF-8?q?web/melange:=20port=20props=20module=20?= =?UTF-8?q?=E2=80=94=20apply=5Fproperty!/remove=5Fproperty!,=20class=20ref?= =?UTF-8?q?resh,=20accordion=20open/close,=20alignment=20and=20select-disp?= =?UTF-8?q?lay=20helpers?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- platform/web/melange/render/lui_web_props.ml | 657 ++++++++++++++++++- 1 file changed, 645 insertions(+), 12 deletions(-) diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml index 22d6ed0c..2755a8c4 100644 --- a/platform/web/melange/render/lui_web_props.ml +++ b/platform/web/melange/render/lui_web_props.ml @@ -1,15 +1,648 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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 _a0 _a1 _a2 _a3 = failwith "unimplemented refresh_node_class_bang" let refresh_node_class_bang = refresh_node_class -let apply_property _a0 _a1 _a2 _a3 _a4 _a5 = failwith "unimplemented apply_property_bang" + +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 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 dom_node 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 dom_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) + (string_of_float 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 + +let apply_anchor_offset kind dom_node offset = + set_style dom_node "--lui-anchor-offset" (string_of_float offset ^ "px"); + if kind = Tooltip then + W.Element.setAttribute "data-anchor-offset" + (string_of_float 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" (string_of_float 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 + (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 + | _ -> invalid_arg "invalid DOM property value" + let apply_property_bang = apply_property -(* TODO: remove_property_bang — internal helper, port without stub signature *) -(* TODO: set_accordion_open_bang — internal helper, port without stub signature *) -(* TODO: apply_text_value_bang — internal helper, port without stub signature *) - -(* cross-module stubs *) -let remove_property _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented remove_property" -let set_accordion_open _a0 _a1 _a2 _a3 = failwith "unimplemented set_accordion_open" -let apply_text_value _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented apply_text_value" + +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" "" + | 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 From a1afadc83904fbfd21746821d212083c9092c860 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:18:07 -0700 Subject: [PATCH 10/21] widgets: port split panes and widget updaters to Melange MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Port web.cljc split (split-base-fraction … attach-split-events) and widgets (update-icon-name … select-display-text) ranges to OCaml: fraction reconciliation with resize-origin animation, divider drag and keyboard adjust, image/media-surface registries, avatar/image crop math, stepper/timeline/bottom-tabs/progress updaters. --- platform/web/melange/widgets/lui_web_split.ml | 236 +++++++- .../web/melange/widgets/lui_web_widgets.ml | 530 ++++++++++++++++-- 2 files changed, 716 insertions(+), 50 deletions(-) diff --git a/platform/web/melange/widgets/lui_web_split.ml b/platform/web/melange/widgets/lui_web_split.ml index 3ca385c3..6bea6391 100644 --- a/platform/web/melange/widgets/lui_web_split.ml +++ b/platform/web/melange/widgets/lui_web_split.ml @@ -1,18 +1,228 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) - -let split_base_fraction _a0 = failwith "unimplemented split_base_fraction" -let split_int_property _a0 _a1 _a2 _a3 = failwith "unimplemented split_int_property" -let split_child_minimum _a0 _a1 _a2 = failwith "unimplemented split_child_minimum" -let split_timing_function _a0 _a1 = failwith "unimplemented split_timing_function" -let effective_split_fraction _a0 _a1 _a2 = failwith "unimplemented effective_split_fraction" -let render_split _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented render_split_bang" +(* 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 reconcile_split _a0 _a1 _a2 _a3 = failwith "unimplemented reconcile_split_bang" + +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 _a0 _a1 = failwith "unimplemented update_split_bang" + +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 update_splits_under _a0 _a1 = failwith "unimplemented update_splits_under_bang" + +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 _a0 _a1 _a2 = failwith "unimplemented attach_split_events_bang" + +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 index 74e337ec..653f8e69 100644 --- a/platform/web/melange/widgets/lui_web_widgets.ml +++ b/platform/web/melange/widgets/lui_web_widgets.ml @@ -1,49 +1,505 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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 register_image _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented register_image_bang" -let register_image_bang = register_image -let unregister_image _a0 _a1 = failwith "unimplemented unregister_image_bang" -let unregister_image_bang = unregister_image -let present_media_surface_frame _a0 _a1 _a2 _a3 _a4 = failwith "unimplemented present_media_surface_frame_bang" -let present_media_surface_frame_bang = present_media_surface_frame -let unregister_media_surface _a0 _a1 = failwith "unimplemented unregister_media_surface_bang" -let unregister_media_surface_bang = unregister_media_surface -let avatar_float _a0 _a1 _a2 _a3 = failwith "unimplemented avatar_float" -let registered_avatar_image _a0 _a1 = failwith "unimplemented registered_avatar_image" -let media_size _a0 _a1 _a2 _a3 = failwith "unimplemented media_size" -let registered_image _a0 _a1 = failwith "unimplemented registered_image" -let update_avatar _a0 _a1 _a2 = failwith "unimplemented update_avatar_bang" let update_avatar_bang = update_avatar -let refresh_image_id _a0 _a1 = failwith "unimplemented refresh_image_id_bang" -let refresh_image_id_bang = refresh_image_id -let update_image _a0 _a1 _a2 = failwith "unimplemented update_image_bang" + +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 update_media_surface _a0 _a1 _a2 = failwith "unimplemented update_media_surface_bang" + +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_media_surface_id _a0 _a1 = failwith "unimplemented refresh_media_surface_id_bang" + +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 update_icon_name _a0 _a1 _a2 = failwith "unimplemented update_icon_name_bang" -let update_icon_name_bang = update_icon_name -let bottom_tab_trigger _a0 _a1 = failwith "unimplemented bottom_tab_trigger" -let bottom_tab_string_property _a0 _a1 _a2 = failwith "unimplemented bottom_tab_string_property" -let refresh_bottom_tabs _a0 _a1 = failwith "unimplemented refresh_bottom_tabs_bang" + +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 _a0 _a1 _a2 _a3 = failwith "unimplemented create_bottom_tab_trigger_bang" + +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 string_property _a0 _a1 _a2 = failwith "unimplemented string_property" -let update_stepper _a0 _a1 = failwith "unimplemented update_stepper_bang" -let update_stepper_bang = update_stepper -let update_stepper_parent _a0 _a1 = failwith "unimplemented update_stepper_parent_bang" + +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 _a0 _a1 = failwith "unimplemented update_timeline_bang" + +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 _a0 _a1 _a2 = failwith "unimplemented update_timeline_indicator_bang" + +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 _a0 _a1 = failwith "unimplemented progress_float" -let update_progress _a0 _a1 _a2 = failwith "unimplemented update_progress_bang" + +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 -(* TODO: select_display_text — internal helper, port without stub signature *) -(* cross-module stubs *) -let select_display_text _a0 _a1 = failwith "unimplemented select_display_text" +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 + | _ -> "") From d7e7853cedb94d342f67ed6dd32c35f9aca0f4ff Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:26:04 -0700 Subject: [PATCH 11/21] Fix cross-module seams after module merges --- platform/web/melange/render/lui_web_props.ml | 2 +- platform/web/melange/shell/lui_web_apply.ml | 28 +++++++++++++------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml index 2755a8c4..39b1de22 100644 --- a/platform/web/melange/render/lui_web_props.ml +++ b/platform/web/melange/render/lui_web_props.ml @@ -252,7 +252,7 @@ let apply_enabled renderer node kind dom_node enabled = (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 dom_node) + (Focus.apply_toolbar_disabled_semantics renderer node) end let apply_grid_columns dom_node columns = diff --git a/platform/web/melange/shell/lui_web_apply.ml b/platform/web/melange/shell/lui_web_apply.ml index 721bf996..60178ba1 100644 --- a/platform/web/melange/shell/lui_web_apply.ml +++ b/platform/web/melange/shell/lui_web_apply.ml @@ -357,15 +357,25 @@ let apply_move_child renderer previous_nodes parent child index = let apply_set_prop renderer node property value = match Store.node renderer.web_store node with - | Some current -> - Lui_web_props.apply_property renderer node - (Store.standard_kind current) current.platform_node property value; - refresh_parent_for_prop renderer node property + | 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 = - Lui_web_props.remove_property renderer node property; - refresh_parent_for_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 @@ -394,6 +404,6 @@ let apply_dom_batch renderer previous_nodes batch = List.iter (fun operation -> apply_dom_op renderer previous_nodes operation) batch.ops; - Lui_web_focus.update_all_horizontal_group_roving renderer; - Lui_web_focus.update_all_tree_roving renderer; - Lui_web_focus.update_all_toolbar_roving renderer + 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) From 85d4482ae29604197762b20e0e62640973b002ba Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:29:30 -0700 Subject: [PATCH 12/21] Port overlay module (modals, tooltips, toasts) to OCaml/Melange --- platform/web/melange/popup/lui_web_overlay.ml | 1115 ++++++++++++++++- 1 file changed, 1095 insertions(+), 20 deletions(-) diff --git a/platform/web/melange/popup/lui_web_overlay.ml b/platform/web/melange/popup/lui_web_overlay.ml index 8085bd2e..bfa289c3 100644 --- a/platform/web/melange/popup/lui_web_overlay.ml +++ b/platform/web/melange/popup/lui_web_overlay.ml @@ -1,29 +1,1104 @@ -(* STUB — replaced by the porting pass for this module. *) -(* Source: /tmp/lui-web-ref/web.cljc — see PORTING.md. *) +(* 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 _a0 _a1 = failwith "unimplemented modal_node_" let modal_node_ = modal_node -let modal_layer_node _a0 = failwith "unimplemented modal_layer_node" -let anchored_tooltip _a0 = failwith "unimplemented anchored_tooltip_" + +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 _a0 _a1 = failwith "unimplemented anchored_tooltip_node_" + +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 -let refresh_modal_host_inert _a0 = failwith "unimplemented refresh_modal_host_inert_bang" + +(* 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 -let tooltip_delay _a0 _a1 = failwith "unimplemented tooltip_delay" -let set_tooltip_open _a0 _a1 _a2 = failwith "unimplemented set_tooltip_open_bang" + +(* 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 mount_tooltip _a0 _a1 _a2 = failwith "unimplemented mount_tooltip_bang" + +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 -let toast_duration _a0 _a1 = failwith "unimplemented toast_duration" -let first_toast_node _a0 _a1 = failwith "unimplemented first_toast_node_" + +(* 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 -let mount_toast _a0 _a1 _a2 = failwith "unimplemented mount_toast_bang" -let mount_toast_bang = mount_toast -let attach_modal_events _a0 _a1 _a2 = failwith "unimplemented attach_modal_events_bang" -let attach_modal_events_bang = attach_modal_events -(* TODO: open_modal_bang — internal helper, port without stub signature *) -(* cross-module stubs *) -let open_modal _a0 _a1 = failwith "unimplemented open_modal" -let remove_modal_layer_after_exit _a0 _a1 _a2 = failwith "unimplemented remove_modal_layer_after_exit" +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 From fc4e066bc979ee7dc1b207009b821f4060937da2 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sat, 26 Sep 2026 23:31:16 -0700 Subject: [PATCH 13/21] web/melange: adapt apply layer to ported overlay signature --- platform/web/melange/shell/lui_web_apply.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/platform/web/melange/shell/lui_web_apply.ml b/platform/web/melange/shell/lui_web_apply.ml index 60178ba1..9bdb0474 100644 --- a/platform/web/melange/shell/lui_web_apply.ml +++ b/platform/web/melange/shell/lui_web_apply.ml @@ -277,8 +277,10 @@ let apply_remove_child renderer previous_nodes parent child = else if modal then match prev_node previous_nodes child with | Some previous -> - Lui_web_overlay.remove_modal_layer_after_exit renderer.web_document - parent_node child_node surface (Store.standard_kind 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 From 563fa4c4142e8047bc29db4aa5c0fe1ceae1bc37 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 00:13:04 -0700 Subject: [PATCH 14/21] examples/components/web: pure-OCaml Melange web gallery entry Replaces the LG-compiled demo entry with OCaml: web_main.ml ports the web entry from web_main.cljc (simulator-map/camera/native-card/gallery-accent adapters, simulator toolbar outside #app, gallery shell nav by root section), and web_bootstrap.ml mounts it on #app. The gallery itself reuses examples/gallery's gallery_app library (model/view/extension_schemas) instead of re-porting gallery.cljc; gallery_app gains the melange mode so melange.emit can link it. index.html keeps the same shell and e2e hooks, with an import map over the lui-components-web emit node_modules (no lg.* entries). --- examples/components/web/dune | 11 + examples/components/web/index.html | 27 + examples/components/web/styles.css | 266 ++++++++++ examples/components/web/web_bootstrap.ml | 10 + examples/components/web/web_main.ml | 624 +++++++++++++++++++++++ examples/gallery/dune | 1 + 6 files changed, 939 insertions(+) create mode 100644 examples/components/web/dune create mode 100644 examples/components/web/index.html create mode 100644 examples/components/web/styles.css create mode 100644 examples/components/web/web_bootstrap.ml create mode 100644 examples/components/web/web_main.ml 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..f8719371 --- /dev/null +++ b/examples/components/web/web_bootstrap.ml @@ -0,0 +1,10 @@ +let show_error host message = + Webapi.Dom.Element.setTextContent host message; + Webapi.Dom.Element.setAttribute "data-error" "true" host + +let () = + 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)) 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)) From 4f6239d8f167e4dc10fdf5a60a4bd453aad8ac0f Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:04:05 -0700 Subject: [PATCH 15/21] web: fix enabled semantics, modal description slots, echo suppression on tree rows - store: absent Enabled means enabled (only Some(false) disables) - nodes/props: Dialog|Sheet get heading+description slots in title div - runtime: ToggleChanged echo check consults Expanded on tree rows, restoring ArrowLeft collapse in trees - web demo: backtrace on mount error; web gallery shows native extension + tweaks sections via simulator extensions - simulator: JS float formatting for --lui-device-scale; e2e waits 300ms for accent transition --- examples/components/web/web_bootstrap.ml | 5 +- examples/gallery/extension_schemas.json | 162 ++++++++++++ examples/gallery/extension_schemas.ml | 240 ++++++++++++++++++ examples/gallery/extension_schemas.mli | 17 ++ examples/gallery/view.ml | 38 ++- platform/web/melange/core/lui_web_store.ml | 7 +- platform/web/melange/core/lui_web_util.ml | 7 +- platform/web/melange/nodes/lui_web_nodes.ml | 5 +- platform/web/melange/render/lui_web_props.ml | 64 ++++- platform/web/melange/shell/lui_web.ml | 18 +- .../web/melange/shell/lui_web_simulator.ml | 2 +- platform/web/package-lock.json | 1 - platform/web/src/lui.css | 8 + platform/web/test/simulator.e2e.mjs | 1 + src/lui_runtime.ml | 6 +- 15 files changed, 550 insertions(+), 31 deletions(-) diff --git a/examples/components/web/web_bootstrap.ml b/examples/components/web/web_bootstrap.ml index f8719371..7e58b139 100644 --- a/examples/components/web/web_bootstrap.ml +++ b/examples/components/web/web_bootstrap.ml @@ -3,8 +3,11 @@ let show_error 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)) + with error -> + show_error host + (Printexc.to_string error ^ "\n" ^ Printexc.get_backtrace ())) 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..bcc41324 100644 --- a/examples/gallery/view.ml +++ b/examples/gallery/view.ml @@ -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 = @@ -1596,6 +1615,7 @@ let view context model_source send : t = tweak_paragraph; split_panes_section model_source send; ] + | WebOS -> sections @ [ native_extension_section; tweak_paragraph ] | _ -> sections in column sections diff --git a/platform/web/melange/core/lui_web_store.ml b/platform/web/melange/core/lui_web_store.ml index 36fb08d7..d202040a 100644 --- a/platform/web/melange/core/lui_web_store.ml +++ b/platform/web/melange/core/lui_web_store.ml @@ -682,7 +682,10 @@ let true_property renderer node prop = | Some (BoolValue true) -> true | _ -> false -let enabled_node renderer node = true_property renderer node Enabled +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 @@ -716,7 +719,7 @@ let direct_toggle kind = let button_like kind = match kind with - | Button | ToggleButton | Toggle | ListItem | Radio -> true + | Button | ToggleButton | Toggle -> true | _ -> false let treeitem renderer node = diff --git a/platform/web/melange/core/lui_web_util.ml b/platform/web/melange/core/lui_web_util.ml index ec712c01..4843c911 100644 --- a/platform/web/melange/core/lui_web_util.ml +++ b/platform/web/melange/core/lui_web_util.ml @@ -38,7 +38,12 @@ let element document tag class_name attributes children = 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" + | 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 diff --git a/platform/web/melange/nodes/lui_web_nodes.ml b/platform/web/melange/nodes/lui_web_nodes.ml index c8374651..4fd38d89 100644 --- a/platform/web/melange/nodes/lui_web_nodes.ml +++ b/platform/web/melange/nodes/lui_web_nodes.ml @@ -334,7 +334,10 @@ let create_modal_node renderer kind = 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 ^ "-title") [] + [ Util.element document "div" (class_name ^ "-heading") [] []; + Util.element document "div" (class_name ^ "-description") + [ ("hidden", "") ] [] ]; Util.element document "div" (class_name ^ "-body") [] []; (if kind = Sheet then Util.element document "div" "lui-sheet-handle" diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml index 39b1de22..8f8fb7fb 100644 --- a/platform/web/melange/render/lui_web_props.ml +++ b/platform/web/melange/render/lui_web_props.ml @@ -197,7 +197,8 @@ let apply_text_value renderer node kind dom_node text = W.Element.setTextContent (Util.child_element dom_node 1) text; Widgets.update_stepper_parent renderer node | Dialog | Sheet -> - W.Element.setTextContent (Util.child_element dom_node 0) text + 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 @@ -313,7 +314,7 @@ let apply_progress_value renderer node kind 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) - (string_of_float value) + (Js.Float.toString value) let apply_inline_icon_name renderer node kind dom_node name = if kind = BottomTab then @@ -428,11 +429,44 @@ 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" (string_of_float offset ^ "px"); + set_style dom_node "--lui-anchor-offset" (Js.Float.toString offset ^ "px"); if kind = Tooltip then W.Element.setAttribute "data-anchor-offset" - (string_of_float offset) dom_node + (Js.Float.toString offset) dom_node let rec apply_property renderer node kind dom_node property value = match (property, value) with @@ -446,7 +480,7 @@ let rec apply_property renderer node kind dom_node property value = | CrossAlignment, StringValue alignment -> set_style dom_node "align-items" (cross_alignment_value alignment) | GrowValue, FloatValue grow -> - set_style dom_node "flex-grow" (string_of_float 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"); @@ -557,7 +591,9 @@ and apply_secondary_property renderer node kind dom_node property value = apply_title renderer node kind dom_node title | DescriptionValue, StringValue description -> Util.set_optional_text - (Util.child_element (Util.child_element dom_node 1) 1) + (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 @@ -590,7 +626,13 @@ and apply_secondary_property renderer node kind dom_node property value = if kind = Bubble then W.Element.setAttribute "data-reactions-alignment" alignment dom_node else set_style dom_node "text-align" alignment - | _ -> invalid_arg "invalid DOM property value" + | 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 @@ -628,6 +670,14 @@ let remove_property renderer node kind dom_node property = | 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) "" diff --git a/platform/web/melange/shell/lui_web.ml b/platform/web/melange/shell/lui_web.ml index 4cd67a0b..fb9dac88 100644 --- a/platform/web/melange/shell/lui_web.ml +++ b/platform/web/melange/shell/lui_web.ml @@ -89,13 +89,17 @@ let backend renderer = apply_batch = (fun batch -> let previous_nodes = Hashtbl.copy renderer.web_store.retained_nodes in - 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); - Lui_web_apply.apply_dom_batch renderer previous_nodes batch; + (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 = diff --git a/platform/web/melange/shell/lui_web_simulator.ml b/platform/web/melange/shell/lui_web_simulator.ml index c7768309..4d6cec40 100644 --- a/platform/web/melange/shell/lui_web_simulator.ml +++ b/platform/web/melange/shell/lui_web_simulator.ml @@ -93,7 +93,7 @@ let apply_simulator_device_to_scope scope device keyboard_visible = set_style scope "--lui-viewport-height" (string_of_int device.simulator_device_height ^ "px"); set_style scope "--lui-device-scale" - (string_of_float device.simulator_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" 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..c974d0ae 100644 --- a/platform/web/src/lui.css +++ b/platform/web/src/lui.css @@ -608,6 +608,10 @@ body { @apply text-lg font-semibold; } + .lui-dialog-description { + @apply text-sm font-normal text-muted-foreground; + } + .lui-dialog-body { @apply grid; } @@ -671,6 +675,10 @@ body { @apply text-lg font-semibold; } + .lui-sheet-description { + @apply text-sm font-normal text-muted-foreground; + } + .lui-sheet-body { @apply grid; } 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/src/lui_runtime.ml b/src/lui_runtime.ml index 275d83db..a865abce 100644 --- a/src/lui_runtime.ml +++ b/src/lui_runtime.ml @@ -1135,7 +1135,11 @@ 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 -> not checked_value)) | ValueChanged (_, value) -> (match Property_map.find_opt ProgressValue properties with | Some (FloatValue current) -> current = value From 3fcb078cb2b2062b5020d11f6d8a0281f38fc260 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:17:22 -0700 Subject: [PATCH 16/21] web: hot reload via Melange full reload; drop banned modal description class MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - vite plugin: watch examples/**/*.ml(i), wait for dune emit to settle, invalidate module graph, send full-reload (replaces LG runtime root-swap which no longer exists in pure OCaml) - dev_web.mjs: opam exec --switch=default so melange-webapi resolves - hot-reload.e2e.mjs: rewritten for the Melange pipeline (source edit → reload instead of LG HMR; CSS/JS HMR semantics unchanged) - nodes/css: dialog|sheet description slot renamed to .lui-modal-description (tailwind contract bans .lui-{dialog,sheet}-{header,content,footer,description}) --- platform/web/melange/nodes/lui_web_nodes.ml | 2 +- platform/web/src/lui.css | 12 +- platform/web/test/hot-reload.e2e.mjs | 70 +++++------ platform/web/vite.config.mjs | 127 +++++--------------- tooling/dev_web.mjs | 1 + 5 files changed, 65 insertions(+), 147 deletions(-) diff --git a/platform/web/melange/nodes/lui_web_nodes.ml b/platform/web/melange/nodes/lui_web_nodes.ml index 4fd38d89..c0cd666d 100644 --- a/platform/web/melange/nodes/lui_web_nodes.ml +++ b/platform/web/melange/nodes/lui_web_nodes.ml @@ -336,7 +336,7 @@ let create_modal_node renderer kind = [ ("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" (class_name ^ "-description") + Util.element document "div" "lui-modal-description" [ ("hidden", "") ] [] ]; Util.element document "div" (class_name ^ "-body") [] []; (if kind = Sheet then diff --git a/platform/web/src/lui.css b/platform/web/src/lui.css index c974d0ae..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; @@ -608,10 +612,6 @@ body { @apply text-lg font-semibold; } - .lui-dialog-description { - @apply text-sm font-normal text-muted-foreground; - } - .lui-dialog-body { @apply grid; } @@ -675,10 +675,6 @@ body { @apply text-lg font-semibold; } - .lui-sheet-description { - @apply text-sm font-normal text-muted-foreground; - } - .lui-sheet-body { @apply grid; } 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/vite.config.mjs b/platform/web/vite.config.mjs index 06a8385c..09debcfe 100644 --- a/platform/web/vite.config.mjs +++ b/platform/web/vite.config.mjs @@ -7,19 +7,12 @@ 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 examplesRoot = path.join(projectRoot, "examples") +const OCAML_SOURCE_EXTENSIONS = new Set([".ml", ".mli"]) const wait = (milliseconds) => new Promise((resolve) => setTimeout(resolve, milliseconds)) @@ -39,123 +32,61 @@ 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) { + async function waitForMelangeOutput(generation, generatedModule, since) { for (let attempt = 0; attempt < 1200; attempt += 1) { - if (generation !== sourceGeneration) return undefined + if (generation !== sourceGeneration) return false try { - const [bundle, bootstrapInfo] = await Promise.all([ - readFile(generatedBundle, "utf8"), - stat(generatedBootstrap), - ]) - if (bundle !== previousBundle && bootstrapInfo.mtimeMs > bootstrapTime) { - return settleGeneratedFile(generatedBundle) + const info = await stat(generatedModule) + if (info.mtimeMs > since) { + return (await settleGeneratedFile(generatedModule)) !== undefined } } catch { // Dune replaces the generated output tree atomically. } await wait(50) } - return undefined + return false } 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) { - try { - generatedFiles.set(normalizedId, await readFile(normalizedId, "utf8")) - } catch { - generatedFiles.set(normalizedId, code) - } - } - 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 - } - }) - }) -} -` - - return { code: `${code}${hotReloadBoundary}`, map: null } - }, 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/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", From 94098f7f93db17e2ab6ef9d24e7a982c79386fa6 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:24:16 -0700 Subject: [PATCH 17/21] gallery: restore lui-combobox-query-value class on shared query text The e2e composition tests assert on .lui-combobox-query-value to read the model-owned query; the OCaml gallery port dropped the class the original cljc gallery set on that text element. --- examples/gallery/view.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/gallery/view.ml b/examples/gallery/view.ml index bcc41324..8e8dca7b 100644 --- a/examples/gallery/view.ml +++ b/examples/gallery/view.ml @@ -1018,7 +1018,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." From 30f88f5a4617f55b57d08fd013c9a88d5e9d155f Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:33:28 -0700 Subject: [PATCH 18/21] gallery: restore group aria-labels and constant-disabled toolbar controls Port fidelity fixes matching the original gallery.cljc: - button_group/toggle_group/breadcrumb/pagination used ~accessibility_identifier (renders id=) where the original used :accessibility-label (renders aria-label=). Switch to ~label so the roving-group containers expose their accessible names. - The vertical Insert toolbar's checkbox/select/input were wired to model.disabled (initially false); the original passed a constant-true toolbar-disabled-source, so the controls are always-disabled showcase cases. Use ~disabled:true. --- examples/gallery/view.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/examples/gallery/view.ml b/examples/gallery/view.ml index bcc41324..54978a12 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")) [] @@ -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." From 6bf413823da7de0fb917a0b09bb6929f5d6c73a8 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:40:52 -0700 Subject: [PATCH 19/21] web: treat MenuTrigger as a menu row and defer picker focus via microtask MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit MenuTrigger nodes render as .lui-menu-item but every menu-row check only matched MenuItem, so submenu triggers never got data-submenu-trigger/ aria-expanded, press/highlight events, menuitem roles, or inclusion in keyboard-nav item lists — submenu mouseenter left aria-expanded null. Add Store.menu_item_row covering MenuItem | MenuTrigger and use it in menu item collection, role refresh, context-menu focus items, submenu trigger detection, dropdown anchor resolution, and submenu cleanup. Route MenuTrigger visible text to its label span so the icon child is not wiped. Nested dropdowns hanging off a menu row inside another menu default to data-anchor=right when no explicit anchor is set, matching the original gallery's explicit right-anchored submenus. mount_picker_dropdown deferred its item-focus/active-descendant work with setTimeout(0) because item DOMs are inserted by later ops in the same batch; the timer task could lose to a subsequent scripted assertion. Use a microtask instead — still after the batch unwinds but before any later-queued task. --- platform/web/melange/core/lui_web_store.ml | 7 ++ platform/web/melange/events/lui_web_events.ml | 2 +- platform/web/melange/nodes/lui_web_nodes.ml | 2 +- platform/web/melange/popup/lui_web_menu.ml | 72 +++++++++++++------ .../web/melange/popup/lui_web_position.ml | 2 +- platform/web/melange/render/lui_web_props.ml | 5 +- platform/web/melange/shell/lui_web_apply.ml | 4 +- 7 files changed, 65 insertions(+), 29 deletions(-) diff --git a/platform/web/melange/core/lui_web_store.ml b/platform/web/melange/core/lui_web_store.ml index d202040a..0bcd4e43 100644 --- a/platform/web/melange/core/lui_web_store.ml +++ b/platform/web/melange/core/lui_web_store.ml @@ -52,6 +52,13 @@ let standard_kind_is current expected = | 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) diff --git a/platform/web/melange/events/lui_web_events.ml b/platform/web/melange/events/lui_web_events.ml index 28a7099c..eb1b2bac 100644 --- a/platform/web/melange/events/lui_web_events.ml +++ b/platform/web/melange/events/lui_web_events.ml @@ -443,7 +443,7 @@ let attach_events renderer node kind dom_node = 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 -> + | MenuItem | MenuTrigger -> ignore (Lui_web_menu.attach_picker_press_event renderer node dom_node); W.Element.addEventListener "focusin" (fun _event -> diff --git a/platform/web/melange/nodes/lui_web_nodes.ml b/platform/web/melange/nodes/lui_web_nodes.ml index 4fd38d89..0393eceb 100644 --- a/platform/web/melange/nodes/lui_web_nodes.ml +++ b/platform/web/melange/nodes/lui_web_nodes.ml @@ -448,7 +448,7 @@ let dropdown_anchor_node renderer node = | Some parent -> (match Store.node renderer.web_store parent with | Some parent_node -> - if Store.standard_kind_is parent_node MenuItem then + if Store.menu_item_row parent_node then parent_node.platform_node else let container = diff --git a/platform/web/melange/popup/lui_web_menu.ml b/platform/web/melange/popup/lui_web_menu.ml index 72132ec5..97c1319b 100644 --- a/platform/web/melange/popup/lui_web_menu.ml +++ b/platform/web/melange/popup/lui_web_menu.ml @@ -161,7 +161,7 @@ let picker_menu_items renderer dropdown = (fun child -> match Store.node renderer.web_store child with | Some child_node -> - Store.standard_kind_is child_node MenuItem + Store.menu_item_row child_node && Store.enabled_node renderer child | None -> false) current.retained_children @@ -240,7 +240,7 @@ let refresh_dropdown_item_roles renderer dropdown = (fun item -> match Store.node renderer.web_store item with | Some current -> - if Store.standard_kind_is current MenuItem then + if Store.menu_item_row current then if listbox then begin W.Element.setAttribute "role" "option" current.platform_node; W.Element.setAttribute "aria-selected" @@ -372,7 +372,7 @@ let context_menu_focus_items renderer menu = (fun child -> match Store.node renderer.web_store child with | Some child_node -> - Store.standard_kind_is child_node MenuItem + Store.menu_item_row child_node && Store.enabled_node renderer child | None -> false) current.retained_children @@ -493,7 +493,7 @@ let dropdown_submenu_trigger renderer node = | Some candidate -> (match Store.node renderer.web_store candidate with | Some candidate_node -> - if Store.standard_kind_is candidate_node MenuItem then + if Store.menu_item_row candidate_node then Some candidate else None | None -> None) @@ -849,9 +849,32 @@ 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 @@ -931,6 +954,18 @@ let attach_submenu_hover renderer node current trigger = 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 @@ -942,24 +977,17 @@ let mount_picker_dropdown renderer node = (match Store.node renderer.web_store picker with | Some picker_node -> if Store.standard_kind_is picker_node Combobox then - ignore - (Js.Global.setTimeout - ~f:(fun () -> - match Store.node renderer.web_store node with - | Some _menu -> - set_combobox_active renderer picker node 0 - | None -> ()) - 0) + after_batch_apply (fun () -> + match Store.node renderer.web_store node with + | Some _menu -> set_combobox_active renderer picker node 0 + | None -> ()) else - ignore - (Js.Global.setTimeout - ~f:(fun () -> - match Store.node renderer.web_store node with - | Some _menu -> - focus_context_menu_item renderer node - (picker_selected_index renderer node) - | None -> ()) - 0) + 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 @@ -987,7 +1015,7 @@ let mount_dropdown renderer node = | Some parent -> (match Store.node renderer.web_store parent with | Some parent_node -> - if Store.standard_kind_is parent_node MenuItem then + if Store.menu_item_row parent_node then ignore (attach_submenu_hover renderer node current parent_node.platform_node) diff --git a/platform/web/melange/popup/lui_web_position.ml b/platform/web/melange/popup/lui_web_position.ml index be99d8f8..5107e468 100644 --- a/platform/web/melange/popup/lui_web_position.ml +++ b/platform/web/melange/popup/lui_web_position.ml @@ -245,7 +245,7 @@ let picker_menu_items renderer dropdown = (fun child -> match Store.node renderer.web_store child with | Some child_node -> - Store.standard_kind_is child_node MenuItem + Store.menu_item_row child_node && Store.enabled_node renderer child | None -> false) current.retained_children diff --git a/platform/web/melange/render/lui_web_props.ml b/platform/web/melange/render/lui_web_props.ml index 8f8fb7fb..a7d514d3 100644 --- a/platform/web/melange/render/lui_web_props.ml +++ b/platform/web/melange/render/lui_web_props.ml @@ -180,8 +180,9 @@ let set_text_control_value dom_node 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 then - Util.button_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 diff --git a/platform/web/melange/shell/lui_web_apply.ml b/platform/web/melange/shell/lui_web_apply.ml index 9bdb0474..228780e7 100644 --- a/platform/web/melange/shell/lui_web_apply.ml +++ b/platform/web/melange/shell/lui_web_apply.ml @@ -153,7 +153,7 @@ let apply_create renderer node kind = Lui_web_events.attach_events renderer node kind created let insert_menu_item_role renderer _child current parent = - if Store.standard_kind_is current MenuItem then + if Store.menu_item_row current then match Store.node renderer.web_store parent with | Some parent_node -> if @@ -256,7 +256,7 @@ let remove_bottom_tab renderer parent child = let clear_submenu_trigger _renderer previous_nodes parent = match prev_node previous_nodes parent with | Some parent_node -> - if Store.standard_kind_is parent_node MenuItem then begin + 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; From 115c0028c6a32588730f087b25be843f93738053 Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:53:29 -0700 Subject: [PATCH 20/21] web: restore accordion Selected signal binding and fix gallery audit pages - accordion: add ?selected_signal so open state round-trips reactively; gallery binds ~selected:(reactive open_) instead of a one-shot sample - lui_runtime: event_is_value_echo falls back to Selected for ToggleChanged when Checked/Expanded are absent (accordion, drawer, toggle-button) - gallery: BottomTabs panel titles use styled text instead of role=heading - combine empty_state title uses styled text instead of role=heading - gallery: wrap platform tweak demo in a Tweaks section so its page has a title - e2e: nav count 66 -> 69 in overlay and firefox suites (kept in sync) --- examples/gallery/view.ml | 14 ++++++++------ platform/web/test/firefox.e2e.mjs | 2 +- platform/web/test/overlay.e2e.mjs | 2 +- src/lui_element_combine.ml | 2 +- src/lui_elements.ml | 3 ++- src/lui_elements.mli | 1 + src/lui_runtime.ml | 6 +++++- 7 files changed, 19 insertions(+), 11 deletions(-) diff --git a/examples/gallery/view.ml b/examples/gallery/view.ml index bcc41324..6423276b 100644 --- a/examples/gallery/view.ml +++ b/examples/gallery/view.ml @@ -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." [] ] @@ -936,7 +936,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." @@ -1390,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. *) @@ -1612,10 +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_paragraph ] + | WebOS -> sections @ [ native_extension_section; tweak_section ] | _ -> sections in column sections 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/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/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 a865abce..84a1e827 100644 --- a/src/lui_runtime.ml +++ b/src/lui_runtime.ml @@ -1139,7 +1139,11 @@ let event_is_value_echo properties event = match Property_map.find_opt Expanded properties with | Some (BoolValue current) -> current = checked_value | Some _ -> false - | None -> not checked_value)) + | 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 From 8866b8b45630fe0ea4491d6b970c7fdd5a7eb55b Mon Sep 17 00:00:00 2001 From: Tienson Qin Date: Sun, 27 Sep 2026 01:59:37 -0700 Subject: [PATCH 21/21] web: gate hot reload on all Melange entry modules being present Dune replaces the whole emit tree on rebuild; the changed module settles before sibling entries reappear, so the previous version could trigger a reload into a transiently-incomplete tree. --- platform/web/vite.config.mjs | 37 ++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/platform/web/vite.config.mjs b/platform/web/vite.config.mjs index 09debcfe..f922e16c 100644 --- a/platform/web/vite.config.mjs +++ b/platform/web/vite.config.mjs @@ -11,6 +11,10 @@ const buildOutputRoot = path.join( projectRoot, "_build/default/examples/components/web/lui-components-web", ) +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"]) @@ -44,16 +48,37 @@ function generatedModuleFor(sourceFile) { function melangeHotReload() { let sourceGeneration = 0 + async function modulesPresent() { + for (const moduleFile of generatedEntryModules) { + try { + await stat(moduleFile) + } catch { + return false + } + } + return true + } + async function waitForMelangeOutput(generation, generatedModule, since) { + let settled = false for (let attempt = 0; attempt < 1200; attempt += 1) { if (generation !== sourceGeneration) return false - try { - const info = await stat(generatedModule) - if (info.mtimeMs > since) { - return (await settleGeneratedFile(generatedModule)) !== undefined + if (settled) { + if (await modulesPresent()) return true + } else { + try { + 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 { + // Dune replaces the generated output tree atomically. } - } catch { - // Dune replaces the generated output tree atomically. } await wait(50) }