jon.recoil.org
this repo has no description
1(** Widget renderer for x-ocaml.
2
3 Renders view node JSON (from js_top_worker widget protocol) into real DOM
4 elements using Brr, and wires event handlers back to the worker.
5
6 Supports two kinds of widgets:
7 - Element/Text views: declarative DOM trees, fully replaced on each update
8 - Managed widgets: delegate to registered adapters (e.g. Leaflet maps) that
9 manage their own DOM and respond to config updates and commands *)
10
11open Brr
12
13(** Type alias for the function that sends widget events back to the worker. *)
14type send_fn =
15 widget_id:string -> handler_id:string ->
16 event_type:string -> value:string option -> unit
17
18(** A managed widget adapter. Registered client-side per [kind].
19 All functions receive and return raw Jv.t values (JS objects). *)
20type adapter = {
21 create : Jv.t -> string -> send_fn -> Jv.t;
22 (** [create container config send] creates the widget and returns adapter state *)
23 update : Jv.t -> string -> unit;
24 (** [update state config] reconciles a config change *)
25 command : Jv.t -> string -> string -> unit;
26 (** [command state cmd data] handles an imperative command *)
27 destroy : Jv.t -> unit;
28 (** [destroy state] cleans up *)
29}
30
31(** Global adapter registry: kind -> adapter *)
32let adapters : (string, adapter) Hashtbl.t = Hashtbl.create 8
33
34(** Register an adapter for the given [kind] string. *)
35let register_adapter kind adapter =
36 Hashtbl.replace adapters kind adapter
37
38(** Register an adapter from JavaScript code.
39 The JS must be an IIFE returning [{create, update, command, destroy}].
40 [send] in JS is [send(handler_id, value_string)]. *)
41let register_js_adapter ~(send : send_fn) kind js_code =
42 let obj = Jv.call Jv.global "eval" [| Jv.of_string js_code |] in
43 let adapter = {
44 create = (fun container_jv config_str send_fn ->
45 let js_send = Jv.repr (fun handler_id value ->
46 let hid = Jv.to_string handler_id in
47 let v =
48 if Jv.is_null value || Jv.is_undefined value then None
49 else Some (Jv.to_string value)
50 in
51 send_fn ~widget_id:"" ~handler_id:hid ~event_type:hid ~value:v
52 ) in
53 Jv.call obj "create" [| container_jv; Jv.of_string config_str; js_send |]);
54 update = (fun state config_str ->
55 Jv.call obj "update" [| state; Jv.of_string config_str |] |> ignore);
56 command = (fun state cmd data ->
57 Jv.call obj "command" [| state; Jv.of_string cmd; Jv.of_string data |] |> ignore);
58 destroy = (fun state ->
59 Jv.call obj "destroy" [| state |] |> ignore);
60 } in
61 ignore send; (* send is captured by the adapter's create wrapper at call time *)
62 Hashtbl.replace adapters kind adapter
63
64(** Per-widget state *)
65type widget_entry = {
66 container : El.t;
67 widget_id : string;
68 managed : (string * Jv.t) option;
69 (** For managed widgets: (kind, adapter_state) *)
70}
71
72(** Global registry of active widgets *)
73let widgets : (string, widget_entry) Hashtbl.t = Hashtbl.create 16
74
75(** The current anchor element — new widget containers are inserted after this.
76 Set by [set_active_cell] before each cell eval begins. *)
77let active_cell : Jv.t option ref = ref None
78
79(** Set the currently active cell element. Call this before each eval so that
80 any widgets created during that eval are placed right after the cell. *)
81let set_active_cell (el : Jv.t) = active_cell := Some el
82
83(** Recursively render a view node JSON object to a DOM element.
84 [send] is called when an event handler fires. *)
85let rec render_node ~widget_id ~(send : send_fn) (node : Jv.t) : El.t =
86 let t = Jv.to_string (Jv.get node "t") in
87 match t with
88 | "txt" ->
89 let v = Jv.to_string (Jv.get node "v") in
90 El.span [ El.txt' v ]
91 | "el" ->
92 let tag = Jv.to_string (Jv.get node "tag") in
93 let attrs_arr =
94 let a = Jv.get node "a" in
95 if Jv.is_none a || Jv.is_undefined a then [||]
96 else Jv.to_jv_array a
97 in
98 let children_arr =
99 let c = Jv.get node "c" in
100 if Jv.is_none c || Jv.is_undefined c then [||]
101 else Jv.to_jv_array c
102 in
103 let el = El.v (Jstr.v tag) [] in
104 (* Apply attributes *)
105 Array.iter (fun attr ->
106 let at = Jv.to_string (Jv.get attr "t") in
107 match at with
108 | "prop" ->
109 let k = Jv.to_string (Jv.get attr "k") in
110 let v = Jv.to_string (Jv.get attr "v") in
111 El.set_at (Jstr.v k) (Some (Jstr.v v)) el
112 | "style" ->
113 let k = Jv.to_string (Jv.get attr "k") in
114 let v = Jv.to_string (Jv.get attr "v") in
115 El.set_inline_style (Jstr.v k) (Jstr.v v) el
116 | "cls" ->
117 let v = Jv.to_string (Jv.get attr "v") in
118 El.set_class (Jstr.v v) true el
119 | "handler" ->
120 let ev_name = Jv.to_string (Jv.get attr "ev") in
121 let handler_id = Jv.to_string (Jv.get attr "id") in
122 let ev_type = Ev.Type.create (Jstr.v ev_name) in
123 let _listener = Ev.listen ev_type (fun _ev ->
124 let is_input =
125 let tn = String.lowercase_ascii (Jstr.to_string (El.tag_name el)) in
126 tn = "input" || tn = "select" || tn = "textarea"
127 in
128 let value =
129 if is_input then
130 Some (Jv.to_string (Jv.get (El.to_jv el) "value"))
131 else None
132 in
133 send ~widget_id ~handler_id ~event_type:ev_name ~value
134 ) (El.as_target el) in
135 ()
136 | _ -> ()
137 ) attrs_arr;
138 (* Append children *)
139 Array.iter (fun child ->
140 let child_el = render_node ~widget_id ~send child in
141 El.append_children el [ child_el ]
142 ) children_arr;
143 el
144 | _ ->
145 El.span []
146
147(** Find or create a widget container. New containers are inserted right after
148 the currently active x-ocaml cell element, so widgets appear inline with
149 their code. On subsequent updates the existing container is reused in place. *)
150let find_or_create_container widget_id =
151 match Hashtbl.find_opt widgets widget_id with
152 | Some entry -> entry.container
153 | None ->
154 let container = El.div ~at:[ At.class' (Jstr.v "widget-container") ] [] in
155 El.set_at (Jstr.v "data-widget-id") (Some (Jstr.v widget_id)) container;
156 (* Insert after the active cell element, or fall back to document.body *)
157 (match !active_cell with
158 | Some cell_jv ->
159 (* Walk past any existing widget-containers that are already siblings
160 right after this cell, so multiple widgets from the same cell
161 stack in creation order. *)
162 let next_sibling = ref (Jv.get cell_jv "nextElementSibling") in
163 let insert_after = ref cell_jv in
164 while not (Jv.is_null !next_sibling || Jv.is_undefined !next_sibling) &&
165 (let cls = Jv.to_jstr (Jv.get !next_sibling "className") in
166 Jstr.equal cls (Jstr.v "widget-container")) do
167 insert_after := !next_sibling;
168 next_sibling := Jv.get !next_sibling "nextElementSibling"
169 done;
170 Jv.call !insert_after "insertAdjacentElement"
171 [| Jv.of_string "afterend"; El.to_jv container |] |> ignore
172 | None ->
173 (* No active cell — fall back to document.body *)
174 let body = El.to_jv (Document.body G.document) in
175 Jv.call body "appendChild" [| El.to_jv container |] |> ignore);
176 let entry = { container; widget_id; managed = None } in
177 Hashtbl.replace widgets widget_id entry;
178 container
179
180(** Update (or create) a widget with a new view. *)
181let update_widget ~(send : send_fn) widget_id (view_json : Jv.t) =
182 let t = Jv.to_string (Jv.get view_json "t") in
183 if t = "managed" then begin
184 let kind = Jv.to_string (Jv.get view_json "kind") in
185 let config = Jv.to_string (Jv.get view_json "config") in
186 match Hashtbl.find_opt widgets widget_id with
187 | Some entry when entry.managed <> None ->
188 (* Already created — just update config *)
189 let (_k, state) = Option.get entry.managed in
190 (match Hashtbl.find_opt adapters kind with
191 | Some adapter -> adapter.update state config
192 | None -> ())
193 | _ ->
194 (* First render — create via adapter *)
195 let container = find_or_create_container widget_id in
196 (match Hashtbl.find_opt adapters kind with
197 | None ->
198 (* No adapter registered — render an error message *)
199 El.set_children container
200 [El.span [El.txt' (Printf.sprintf "No adapter for '%s'" kind)]]
201 | Some adapter ->
202 (* Wrap send so the adapter doesn't need to know its widget_id *)
203 let wrapped_send ~widget_id:_ ~handler_id ~event_type ~value =
204 send ~widget_id ~handler_id ~event_type ~value
205 in
206 let state = adapter.create (El.to_jv container) config wrapped_send in
207 let entry = { container; widget_id; managed = Some (kind, state) } in
208 Hashtbl.replace widgets widget_id entry)
209 end else begin
210 (* Existing Element/Text path — full DOM replacement *)
211 let container = find_or_create_container widget_id in
212 El.set_children container [];
213 let dom = render_node ~widget_id ~send view_json in
214 El.append_children container [ dom ]
215 end
216
217(** Update config for a managed widget. *)
218let config_widget widget_id config =
219 match Hashtbl.find_opt widgets widget_id with
220 | Some { managed = Some (kind, state); _ } ->
221 (match Hashtbl.find_opt adapters kind with
222 | Some adapter -> adapter.update state config
223 | None -> ())
224 | _ -> ()
225
226(** Send a command to a managed widget. *)
227let command_widget widget_id cmd data =
228 match Hashtbl.find_opt widgets widget_id with
229 | Some { managed = Some (kind, state); _ } ->
230 (match Hashtbl.find_opt adapters kind with
231 | Some adapter -> adapter.command state cmd data
232 | None -> ())
233 | _ -> ()
234
235(** Remove a widget and its container. Calls adapter destroy for managed widgets. *)
236let clear_widget widget_id =
237 match Hashtbl.find_opt widgets widget_id with
238 | Some entry ->
239 (match entry.managed with
240 | Some (kind, state) ->
241 (match Hashtbl.find_opt adapters kind with
242 | Some adapter -> adapter.destroy state
243 | None -> ())
244 | None -> ());
245 El.remove entry.container;
246 Hashtbl.remove widgets widget_id
247 | None -> ()