jon.recoil.org
this repo has no description
feat: managed widgets, leaflet library, x-ocaml rendering, complete preloaded list
- Add managed widget protocol (display_managed, command, register_adapter)
for external widget adapters like Leaflet maps
- Extract Leaflet map adapter into separate js_top_worker-widget-leaflet
library, loadable via #require
- Add widget rendering to x-ocaml web component (widget_render.ml) so
widgets work in .mld documentation pages
- Wire widget callbacks through OCaml client (js_top_worker_client_msg.ml)
- Complete the preloaded list in findlibish.ml to match all transitive
worker dependencies, preventing "file already exists" errors when
#require loads packages already compiled into the worker
- Add demo_widgets.mld and demo_map.mld documentation pages
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+26
-1
src/jtw_client.cppo.ml
+26
-1
src/jtw_client.cppo.ml
···
44
44
url
45
45
in
46
46
let client = Jtw.create effective_url in
47
-
{ client; on_message_cb = (fun _ -> ()) }
47
+
let t = { client; on_message_cb = (fun _ -> ()) } in
48
+
(* Wire widget rendering: forward widget messages from the worker to the
49
+
DOM renderer, and send widget events back to the worker. *)
50
+
let send_fn ~widget_id ~handler_id ~event_type ~value =
51
+
Jtw.send_widget_event client ~widget_id ~handler_id ~event_type ~value
52
+
in
53
+
Jtw.set_on_widget_update client (fun widget_id view_any ->
54
+
(* view_any is Js.Unsafe.any — coerce to Jv.t (they are the same repr) *)
55
+
let view_jv : Jv.t = Obj.magic view_any in
56
+
Widget_render.update_widget ~send:send_fn widget_id view_jv);
57
+
Jtw.set_on_widget_clear client (fun widget_id ->
58
+
Widget_render.clear_widget widget_id);
59
+
Jtw.set_on_widget_config client (fun widget_id config ->
60
+
Widget_render.config_widget widget_id config);
61
+
Jtw.set_on_widget_command client (fun widget_id cmd data ->
62
+
Widget_render.command_widget widget_id cmd data);
63
+
Jtw.set_on_widget_register_adapter client (fun kind js_code ->
64
+
Widget_render.register_js_adapter ~send:send_fn kind js_code);
65
+
t
48
66
49
67
let on_message t fn = t.on_message_cb <- fn
50
68
···
154
172
let post t (req : X_protocol.request) =
155
173
match req with
156
174
| X_protocol.Eval (id, _line_number, code) ->
175
+
(* Tell widget_render which cell is executing so widgets are placed
176
+
right after this cell's <x-ocaml> element in the DOM. *)
177
+
let doc = Brr.Document.to_jv Brr.G.document in
178
+
let cells = Jv.call doc "querySelectorAll" [| Jv.of_string "x-ocaml" |] in
179
+
let cell_el = Jv.call cells "item" [| Jv.of_int id |] in
180
+
if not (Jv.is_null cell_el) then
181
+
Widget_render.set_active_cell cell_el;
157
182
let stream = Jtw.eval_stream t.client code in
158
183
Lwt.async (fun () ->
159
184
Lwt.catch (fun () ->
+247
src/widget_render.ml
+247
src/widget_render.ml
···
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
+
11
+
open Brr
12
+
13
+
(** Type alias for the function that sends widget events back to the worker. *)
14
+
type 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). *)
20
+
type 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 *)
32
+
let adapters : (string, adapter) Hashtbl.t = Hashtbl.create 8
33
+
34
+
(** Register an adapter for the given [kind] string. *)
35
+
let 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)]. *)
41
+
let 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 *)
65
+
type 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 *)
73
+
let 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. *)
77
+
let 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. *)
81
+
let 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. *)
85
+
let 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 = 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. *)
150
+
let 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. *)
181
+
let 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. *)
218
+
let 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. *)
227
+
let 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. *)
236
+
let 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 -> ()