Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
112 changes: 77 additions & 35 deletions platform/web/melange/shell/lui_web_apply.ml
Original file line number Diff line number Diff line change
Expand Up @@ -66,16 +66,16 @@ let cleanup_node renderer node =
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
(* a retained child only advances the DOM insertion index when its
platform node is a DOM child of the container right now — portal
children (menus, modals, toasts), never-mounted segments and nodes
dropped inside the same batch all sit outside it and must be skipped *)
let child_counted_in_container child container =
match child.platform_node |> W.Element.parentElement with
| Some actual -> actual == container
| None -> false

let visible_child_index renderer parent index =
let visible_child_index renderer ~container parent index =
match Store.node renderer.web_store parent with
| None -> index
| Some current ->
Expand All @@ -85,9 +85,14 @@ let visible_child_index renderer parent index =
match children with
| [] -> result
| child :: rest ->
let counted =
match Store.node renderer.web_store child with
| Some child_node ->
child_counted_in_container child_node container
| None -> false
in
loop rest (source_index + 1)
(if child_hidden_in_parent renderer child then result
else result + 1)
(if counted then result + 1 else result)
in
loop current.retained_children 0 0

Expand Down Expand Up @@ -184,11 +189,14 @@ let mount_inserted_child renderer child current =
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
let insert_child_dom renderer previous_nodes parent child index =
let parent_dom = Nodes.dom_node_before renderer previous_nodes parent in
let child_dom = Nodes.dom_node_before renderer previous_nodes child in
match Store.node renderer.web_store child with
| None -> invalid_arg "unknown DOM child"
| None ->
(* dropped again inside this batch — insert anyway so the later
remove op finds the element where the op stream put it *)
Util.insert_dom_child parent_dom child_dom index
| Some current -> (
match Store.standard_kind current with
| Some BottomTab -> (
Expand All @@ -202,9 +210,11 @@ let insert_child_dom renderer parent child index =
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))
let container =
dom_child_container renderer parent parent_dom
in
Util.insert_dom_child container child_dom
(visible_child_index renderer ~container parent index))
| Some Toast ->
W.Element.appendChild (W.Element.asNode child_dom)
renderer.web_toast_viewport
Expand All @@ -222,12 +232,14 @@ let insert_child_dom renderer parent child index =
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 container =
dom_child_container renderer parent parent_dom
in
Util.insert_dom_child container child_dom
(visible_child_index renderer ~container parent index))

let apply_insert_child renderer parent child index =
insert_child_dom renderer parent child index;
let apply_insert_child renderer previous_nodes parent child index =
insert_child_dom renderer previous_nodes 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;
Expand Down Expand Up @@ -362,7 +374,7 @@ let apply_move_child renderer previous_nodes parent child index =
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)
(visible_child_index renderer ~container:parent_node parent index)
end;
Lui_web_split.update_split renderer parent;
refresh_structured_children renderer parent;
Expand Down Expand Up @@ -396,12 +408,25 @@ let apply_remove_prop renderer node property =
| None -> invalid_arg "standard property targets extension node")
| None -> ())

(* A node created and dropped inside the same batch never reaches the DOM:
the store already reflects the batch's final state, so ops that mention it
have no element to act on and are skipped. *)
let known_node renderer previous_nodes node =
match Store.node renderer.web_store node with
| Some _ -> true
| None -> prev_node previous_nodes node <> None

let apply_dom_op renderer previous_nodes operation =
match operation with
| CreateNode (node, kind) -> apply_create renderer node kind
| CreateExtension (node, _identifier, _fingerprint) ->
W.Element.setAttribute "id" (Util.node_dom_id node)
(Nodes.dom_node renderer node)
| CreateNode (node, kind) ->
if Store.node renderer.web_store node <> None then
apply_create renderer node kind
| CreateExtension (node, _identifier, _fingerprint) -> (
match Store.node renderer.web_store node with
| Some current ->
W.Element.setAttribute "id" (Util.node_dom_id node)
current.platform_node
| None -> ())
| DropNode node ->
Ext.cleanup_extension_node renderer previous_nodes node;
cleanup_node renderer node
Expand All @@ -413,16 +438,33 @@ let apply_dom_op renderer previous_nodes operation =
| RemoveExtensionProp (node, property) ->
Ext.remove_extension_property renderer node property
| InsertChild (parent, child, index) ->
apply_insert_child renderer parent child index
if
known_node renderer previous_nodes parent
&& known_node renderer previous_nodes child
then apply_insert_child renderer previous_nodes parent child index
| RemoveChild (parent, child) ->
apply_remove_child renderer previous_nodes parent child
if
known_node renderer previous_nodes parent
&& known_node renderer previous_nodes child
then apply_remove_child renderer previous_nodes parent child
| MoveChild (parent, child, index) ->
apply_move_child renderer previous_nodes parent child index
if
known_node renderer previous_nodes parent
&& known_node renderer previous_nodes child
then 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)
(fun operation ->
try apply_dom_op renderer previous_nodes operation
with Invalid_argument msg ->
invalid_arg
(Printf.sprintf "op %s: %s" (Lui_wire.encode_op operation) msg))
batch.ops;
ignore (Lui_web_focus.update_all_horizontal_group_roving renderer);
ignore (Lui_web_focus.update_all_tree_roving renderer);
ignore (Lui_web_focus.update_all_toolbar_roving renderer)
let label_roving label f =
try ignore (f renderer)
with Invalid_argument msg -> invalid_arg (label ^ ": " ^ msg)
in
label_roving "hgroup-roving" Lui_web_focus.update_all_horizontal_group_roving;
label_roving "tree-roving" Lui_web_focus.update_all_tree_roving;
label_roving "toolbar-roving" Lui_web_focus.update_all_toolbar_roving
58 changes: 52 additions & 6 deletions src/lui_runtime.ml
Original file line number Diff line number Diff line change
Expand Up @@ -456,6 +456,55 @@ let emit_extension_property_diff application node old_values desired_values =
enqueue application (set_extension_prop_op node property value))
desired_values

(* Ops are replayed post-commit: by then a node dropped in the same
batch no longer resolves through the store or the pre-batch mirror,
so any queued op mentioning it can never apply. A node created and
dropped within one batch therefore cancels out entirely — its whole
op group (including structural detach ops) is pruned and no drop op
is emitted. Nodes dropped across batches keep their ops: pre-existing
records resolve through the pre-batch mirror, and the store still
needs the remove-child op that precedes a drop. *)
let operation_mentions_node node operation =
let subject =
match operation with
| CreateNode (subject, _)
| CreateExtension (subject, _, _)
| DropNode subject
| SetProp (subject, _, _)
| RemoveProp (subject, _)
| SetExtensionProp (subject, _, _)
| RemoveExtensionProp (subject, _)
| InsertChild (subject, _, _)
| RemoveChild (subject, _)
| MoveChild (subject, _, _) ->
Some subject
in
let child =
match operation with
| InsertChild (_, child, _)
| RemoveChild (_, child)
| MoveChild (_, child, _) ->
Some child
| _ -> None
in
subject = Some node || child = Some node

let pending_create_exists application node =
List.exists
(function
| CreateNode (candidate, _) | CreateExtension (candidate, _, _) ->
candidate = node
| _ -> false)
!(application.pending_ops)

let enqueue_drop application node =
if pending_create_exists application node then
application.pending_ops :=
List.filter
(fun operation -> not (operation_mentions_node node operation))
!(application.pending_ops)
else enqueue application (drop_node_op node)

let rec emit_dropped_subtree application saved removed_set node =
let children =
match Hashtbl.find_opt saved.checkpoint_children node with
Expand All @@ -469,7 +518,7 @@ let rec emit_dropped_subtree application saved removed_set node =
emit_dropped_subtree application saved removed_set child
end)
children;
enqueue application (drop_node_op node)
enqueue_drop application node

let reconcile_subtree application saved parent old_root candidate_root =
let parent = canonical_node application parent in
Expand Down Expand Up @@ -851,7 +900,7 @@ and drop_node application node =
Hashtbl.remove application.runtime_parents node;
Hashtbl.remove application.runtime_reload_keys node;
application.runtime_extension_dirty := true;
enqueue application (drop_node_op node)
enqueue_drop application node

and remove_child application parent child =
let parent = canonical_node application parent in
Expand Down Expand Up @@ -1153,10 +1202,7 @@ let event_is_value_echo properties event =

let dispatch application event =
let node = canonical_node application (event_node event) in
if
(not (Hashtbl.mem application.mounted_nodes node))
&& not (Hashtbl.mem application.runtime_extension_nodes node)
then
if not (node_live application node) then
(* a DOM element can receive an in-flight event after being unmounted
mid-dispatch (e.g. a capture-phase handler re-renders); ignore it *)
false
Expand Down
Loading