1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
open! Core
open Virtual_dom
open Floating_positioning_new
module Show_on_mount = Vdom.Attr.Hooks.Make (struct
module State = Unit
module Input = struct
type t = unit [@@deriving sexp, equal]
let combine () () = ()
end
let init () _elem = ()
let on_mount () () elem = Popover_dom.show_popover elem
let on_mount = `Schedule_animation_frame on_mount
let update ~old_input:() ~new_input:() () _elem = ()
let destroy () () _ = ()
end)
let show_on_mount =
Show_on_mount.create () |> Vdom.Attr.create_hook "vdom_toplayer_show_on_mount"
;;
module Popover_attr = struct
module Impl = struct
module Input = struct
module For_one = struct
type t =
{ content : Vdom_with_phys_equal.t
; arrow : Vdom_with_phys_equal.t option
; position : Position.t
; alignment : Alignment.t
; offset : Offset.t
}
[@@deriving sexp_of, equal]
let equal a b = phys_equal a b || equal a b
end
type t = For_one.t list [@@deriving sexp_of, equal]
let combine a b = a @ b
end
module State = struct
module For_one = struct
type t =
{ portal : Portal.t
; input : Input.For_one.t
}
end
type t = For_one.t list ref
end
let wrap_content { Input.For_one.position; alignment; offset; content; arrow } ~anchor
=
let position_attr =
Floating_positioning_new.position_me
~arrow_selector:Popover_dom.arrow_selector
~position
~alignment
~offset
(Floating_positioning_new.Anchor.of_element anchor)
in
Popover_dom.node
?arrow
~extra_attrs:[ position_attr; show_on_mount ]
~kind:`Manual
content
;;
let create_one (input : Input.For_one.t) ~anchor =
let portal_root = Portal.For_popovers.find_popover_portal_root anchor in
let portal = Portal.create portal_root (wrap_content input ~anchor) in
{ State.For_one.portal; input }
;;
let update_one input (state : State.For_one.t) ~anchor =
match Input.For_one.equal input state.input with
| true -> state
| false ->
Portal.apply_patch state.portal (wrap_content input ~anchor);
{ state with input }
;;
let destroy_one { State.For_one.portal; input = _ } = Portal.destroy portal
let init _ _ = ref []
let on_mount all_inputs state_ref anchor =
let state = List.map all_inputs ~f:(create_one ~anchor) in
state_ref := state
;;
let on_mount = `Schedule_animation_frame on_mount
let update ~old_input ~(new_input : Input.t) (state_ref : State.t) anchor =
match phys_equal old_input new_input with
| true -> ()
| false ->
let zipped, remainder = List.zip_with_remainder new_input !state_ref in
let updated_state =
List.map zipped ~f:(fun (input, state) -> update_one input state ~anchor)
in
let state_from_remainder =
match remainder with
| None -> []
| Some (Second old_states) ->
List.iter old_states ~f:destroy_one;
[]
| Some (First new_inputs) -> List.map new_inputs ~f:(create_one ~anchor)
in
state_ref := updated_state @ state_from_remainder
;;
let destroy _ (state : State.t) _ = List.iter !state ~f:destroy_one
end
include Impl
include Vdom.Attr.Hooks.Make (Impl)
end
let attr
?(position = Position.Auto)
?(alignment = Alignment.Center)
?(offset = Offset.zero)
?arrow
content
=
Popover_attr.create [ { position; alignment; offset; content; arrow } ]
|> Vdom.Attr.create_hook [%string "vdom_toplayer"]
;;
let node
?(position = Position.Auto)
?(alignment = Alignment.Center)
?(offset = Offset.zero)
?arrow
~popover_content
anchor
=
Popover_dom.node
?arrow
~kind:`Manual
~extra_attrs:
[ show_on_mount
; position_me
~arrow_selector:Popover_dom.arrow_selector
~position
~alignment
~offset
anchor
]
popover_content
;;