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>
+1
-1
bin/mk_backend.ml
+1
-1
bin/mk_backend.ml
···
24
24
(* No longer query library stubs - they are now linked directly into each library's JS file *)
25
25
let cmd =
26
26
Bos.Cmd.(
27
-
js_of_ocaml_cmd % "--toplevel" % "--no-cmis" % "--linkall" % "--pretty")
27
+
js_of_ocaml_cmd % "--toplevel" % "--linkall" % "--pretty")
28
28
in
29
29
let cmd =
30
30
List.fold_right
+105
-3
idl/js_top_worker_client_msg.ml
+105
-3
idl/js_top_worker_client_msg.ml
···
40
40
pending : (int, Msg.worker_msg Lwt.u) Hashtbl.t;
41
41
pending_env : (string, Msg.worker_msg Lwt.u) Hashtbl.t;
42
42
pending_stream : (int, eval_event option -> unit) Hashtbl.t;
43
+
mutable on_widget_update : (string -> Js_of_ocaml.Js.Unsafe.any -> unit) option;
44
+
mutable on_widget_clear : (string -> unit) option;
45
+
mutable on_widget_config : (string -> string -> unit) option;
46
+
mutable on_widget_command : (string -> string -> string -> unit) option;
47
+
mutable on_widget_register_adapter : (string -> string -> unit) option;
43
48
}
44
49
45
50
exception Timeout
···
139
144
caml_ppf = get_string "caml_ppf";
140
145
mime_vals;
141
146
}
147
+
| "widget_config" ->
148
+
Msg.WidgetConfig {
149
+
widget_id = get_string "widget_id";
150
+
config = get_string "config";
151
+
}
152
+
| "widget_command" ->
153
+
Msg.WidgetCommand {
154
+
widget_id = get_string "widget_id";
155
+
command = get_string "command";
156
+
data = get_string "data";
157
+
}
142
158
| _ -> failwith ("Unknown message type: " ^ typ)
143
159
144
160
(** Handle incoming message from worker *)
145
161
let handle_message t msg =
162
+
let open Js_of_ocaml in
146
163
let data = Brr_message.Ev.data (Brr.Ev.as_type msg) in
147
-
let parsed = parse_worker_msg (Js_of_ocaml.Js.to_string data) in
164
+
let json_str = Js.to_string data in
165
+
(* Check for widget messages before full parsing — these carry raw view JSON
166
+
that we forward directly without round-tripping through OCaml types. *)
167
+
let obj = plain_parse (Js.string json_str) in
168
+
let typ = Js.to_string (Js.Unsafe.get obj (Js.string "type")) in
169
+
if typ = "widget_update" then begin
170
+
match t.on_widget_update with
171
+
| Some cb ->
172
+
let widget_id = Js.to_string (Js.Unsafe.get obj (Js.string "widget_id")) in
173
+
let view = Js.Unsafe.get obj (Js.string "view") in
174
+
cb widget_id view
175
+
| None -> ()
176
+
end
177
+
else if typ = "widget_clear" then begin
178
+
match t.on_widget_clear with
179
+
| Some cb ->
180
+
let widget_id = Js.to_string (Js.Unsafe.get obj (Js.string "widget_id")) in
181
+
cb widget_id
182
+
| None -> ()
183
+
end
184
+
else if typ = "widget_config" then begin
185
+
match t.on_widget_config with
186
+
| Some cb ->
187
+
let widget_id = Js.to_string (Js.Unsafe.get obj (Js.string "widget_id")) in
188
+
let config = Js.to_string (Js.Unsafe.get obj (Js.string "config")) in
189
+
cb widget_id config
190
+
| None -> ()
191
+
end
192
+
else if typ = "widget_command" then begin
193
+
match t.on_widget_command with
194
+
| Some cb ->
195
+
let widget_id = Js.to_string (Js.Unsafe.get obj (Js.string "widget_id")) in
196
+
let command = Js.to_string (Js.Unsafe.get obj (Js.string "command")) in
197
+
let data = Js.to_string (Js.Unsafe.get obj (Js.string "data")) in
198
+
cb widget_id command data
199
+
| None -> ()
200
+
end
201
+
else if typ = "widget_register_adapter" then begin
202
+
match t.on_widget_register_adapter with
203
+
| Some cb ->
204
+
let kind = Js.to_string (Js.Unsafe.get obj (Js.string "kind")) in
205
+
let js_code = Js.to_string (Js.Unsafe.get obj (Js.string "js_code")) in
206
+
cb kind js_code
207
+
| None -> ()
208
+
end
209
+
else
210
+
let parsed = parse_worker_msg json_str in
148
211
match parsed with
149
212
| Msg.Ready ->
150
213
t.ready <- true;
···
199
262
Hashtbl.remove t.pending_env env_id;
200
263
Lwt.wakeup resolver parsed
201
264
| None -> ())
202
-
| Msg.WidgetUpdate _ | Msg.WidgetClear _ ->
203
-
(* Widget messages are handled by the JS client, not the OCaml client *)
265
+
| Msg.WidgetUpdate _ | Msg.WidgetClear _
266
+
| Msg.WidgetConfig _ | Msg.WidgetCommand _
267
+
| Msg.WidgetRegisterAdapter _ ->
268
+
(* Handled above via raw JSON interception before parsing *)
204
269
()
205
270
206
271
(** Create a new worker client.
···
216
281
pending = Hashtbl.create 16;
217
282
pending_env = Hashtbl.create 16;
218
283
pending_stream = Hashtbl.create 16;
284
+
on_widget_update = None;
285
+
on_widget_clear = None;
286
+
on_widget_config = None;
287
+
on_widget_command = None;
288
+
on_widget_register_adapter = None;
219
289
} in
220
290
let _listener =
221
291
Brr.Ev.listen Brr_message.Ev.message (handle_message t) (Brr_worker.as_target worker)
···
418
488
| Msg.EnvDestroyed _ -> Lwt.return_unit
419
489
| Msg.InitError { message } -> Lwt.fail (InitError message)
420
490
| _ -> Lwt.fail (Failure "Unexpected response")
491
+
492
+
(** Set callback for widget update messages.
493
+
The callback receives (widget_id, raw_view_json) where raw_view_json
494
+
is the unparsed JS object for the view node. *)
495
+
let set_on_widget_update t cb = t.on_widget_update <- Some cb
496
+
497
+
(** Set callback for widget clear messages. *)
498
+
let set_on_widget_clear t cb = t.on_widget_clear <- Some cb
499
+
500
+
(** Set callback for widget config messages. *)
501
+
let set_on_widget_config t cb = t.on_widget_config <- Some cb
502
+
503
+
(** Set callback for widget command messages. *)
504
+
let set_on_widget_command t cb = t.on_widget_command <- Some cb
505
+
506
+
(** Set callback for widget adapter registration messages. *)
507
+
let set_on_widget_register_adapter t cb = t.on_widget_register_adapter <- Some cb
508
+
509
+
(** Send a widget event back to the worker. *)
510
+
let send_widget_event t ~widget_id ~handler_id ~event_type ~value =
511
+
let open Js_of_ocaml in
512
+
let pairs = [|
513
+
("type", Js.Unsafe.inject (Js.string "widget_event"));
514
+
("widget_id", Js.Unsafe.inject (Js.string widget_id));
515
+
("handler_id", Js.Unsafe.inject (Js.string handler_id));
516
+
("event_type", Js.Unsafe.inject (Js.string event_type));
517
+
("value", match value with
518
+
| Some v -> Js.Unsafe.inject (Js.string v)
519
+
| None -> Js.Unsafe.inject Js.null);
520
+
|] in
521
+
let json = Js.to_string (plain_stringify (Js.Unsafe.obj pairs)) in
522
+
Brr_worker.post t.worker (Js.string json)
421
523
422
524
(** Terminate the worker *)
423
525
let terminate t =
+30
idl/message.ml
+30
idl/message.ml
···
95
95
| EnvDestroyed of { env_id : string }
96
96
| WidgetUpdate of { widget_id : string; view : Widget_view.node }
97
97
| WidgetClear of { widget_id : string }
98
+
| WidgetConfig of { widget_id : string; config : string }
99
+
| WidgetCommand of { widget_id : string; command : string; data : string }
100
+
| WidgetRegisterAdapter of { kind : string; js_code : string }
98
101
99
102
(** {1 JSON helpers} *)
100
103
···
166
169
("a", json_array (List.map (fun a -> Js.Unsafe.inject (json_of_view_attr a)) attrs));
167
170
("c", json_array (List.map (fun c -> Js.Unsafe.inject (json_of_view_node c)) children));
168
171
]
172
+
| Managed { kind; config } ->
173
+
json_of_obj [
174
+
("t", json_string "managed");
175
+
("kind", json_string kind);
176
+
("config", json_string config);
177
+
]
169
178
170
179
let view_attr_of_json obj : Widget_view.attr =
171
180
let t = get_string obj "t" in
···
184
193
let attrs = Array.to_list (Array.map view_attr_of_json (get_array obj "a")) in
185
194
let children = Array.to_list (Array.map view_node_of_json (get_array obj "c")) in
186
195
Element { tag = get_string obj "tag"; attrs; children }
196
+
| "managed" ->
197
+
Managed { kind = get_string obj "kind"; config = get_string obj "config" }
187
198
| _ -> failwith ("Unknown node type: " ^ t)
188
199
189
200
(** {1 Worker message serialization} *)
···
309
320
json_of_obj [
310
321
("type", json_string "widget_clear");
311
322
("widget_id", json_string widget_id);
323
+
]
324
+
| WidgetConfig { widget_id; config } ->
325
+
json_of_obj [
326
+
("type", json_string "widget_config");
327
+
("widget_id", json_string widget_id);
328
+
("config", json_string config);
329
+
]
330
+
| WidgetCommand { widget_id; command; data } ->
331
+
json_of_obj [
332
+
("type", json_string "widget_command");
333
+
("widget_id", json_string widget_id);
334
+
("command", json_string command);
335
+
("data", json_string data);
336
+
]
337
+
| WidgetRegisterAdapter { kind; js_code } ->
338
+
json_of_obj [
339
+
("type", json_string "widget_register_adapter");
340
+
("kind", json_string kind);
341
+
("js_code", json_string js_code);
312
342
]
313
343
in
314
344
Js.to_string (plain_stringify obj)
+1
idl/widget_view.ml
+1
idl/widget_view.ml
+20
js_top_worker-widget-leaflet.opam
+20
js_top_worker-widget-leaflet.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_top_worker-widget"
12
+
]
13
+
build : [
14
+
["dune" "subst"] {pinned}
15
+
["dune" "build" "-p" name "-j" jobs]
16
+
]
17
+
synopsis: "Leaflet.js map widget adapter for js_top_worker"
18
+
description: """
19
+
Provides a Leaflet map adapter that can be #require'd from the toplevel.
20
+
"""
+60
lib/findlibish.ml
+60
lib/findlibish.ml
···
17
17
in
18
18
List.map handle_lib libs |> List.flatten
19
19
20
+
(* Packages compiled into the worker binary. When #require loads a package
21
+
that is already linked into the worker, we must NOT call import_scripts on
22
+
its .cma.js — doing so would re-register CMI files that are already in the
23
+
virtual filesystem, causing a Sys_error "file already exists".
24
+
25
+
This list must match the transitive closure of the worker's library deps
26
+
(see example/dune). To regenerate:
27
+
ocamlfind query -recursive -format '%p' \
28
+
js_top_worker-web logs.browser mime_printer tyxml \
29
+
js_top_worker-widget note | sort -u *)
20
30
let preloaded =
21
31
[
22
32
"angstrom";
23
33
"astring";
34
+
"bigstringaf";
35
+
"compiler-libs";
36
+
"compiler-libs.bytecomp";
24
37
"compiler-libs.common";
25
38
"compiler-libs.toplevel";
39
+
"csexp";
26
40
"findlib";
41
+
"findlib.internal";
27
42
"findlib.top";
28
43
"fpath";
44
+
"gen";
45
+
"js_of_ocaml";
29
46
"js_of_ocaml-compiler";
47
+
"js_of_ocaml-compiler.dynlink";
48
+
"js_of_ocaml-compiler.runtime";
49
+
"js_of_ocaml-lwt";
30
50
"js_of_ocaml-ppx";
31
51
"js_of_ocaml-toplevel";
32
52
"js_top_worker";
53
+
"js_top_worker-rpc.message";
54
+
"js_top_worker-web";
55
+
"js_top_worker-widget";
33
56
"logs";
34
57
"logs.browser";
58
+
"lwt";
59
+
"menhirLib";
60
+
"merlin-lib.analysis";
61
+
"merlin-lib.config";
62
+
"merlin-lib.dot_protocol";
63
+
"merlin-lib.extend";
64
+
"merlin-lib.index_format";
35
65
"merlin-lib.kernel";
66
+
"merlin-lib.ocaml_compression";
67
+
"merlin-lib.ocaml_merlin_specific";
36
68
"merlin-lib.ocaml_parsing";
69
+
"merlin-lib.ocaml_preprocess";
70
+
"merlin-lib.ocaml_typing";
71
+
"merlin-lib.ocaml_utils";
72
+
"merlin-lib.os_ipc";
37
73
"merlin-lib.query_commands";
38
74
"merlin-lib.query_protocol";
75
+
"merlin-lib.sherlodoc";
39
76
"merlin-lib.utils";
40
77
"mime_printer";
78
+
"note";
79
+
"ocaml-compiler-libs.common";
80
+
"ocaml-compiler-libs.shadow";
81
+
"ppx_derivers";
82
+
"ppx_deriving.api";
83
+
"ppxlib";
84
+
"ppxlib.ast";
85
+
"ppxlib.astlib";
86
+
"ppxlib.print_diff";
87
+
"ppxlib.stdppx";
88
+
"ppxlib.traverse_builtins";
89
+
"re";
90
+
"sedlex";
91
+
"seq";
92
+
"sexplib0";
93
+
"stdlib-shims";
94
+
"str";
95
+
"stringext";
96
+
"tyxml";
97
+
"tyxml.functor";
98
+
"unix";
41
99
"uri";
100
+
"uutf";
101
+
"yojson";
42
102
]
43
103
44
104
let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
+4
widget-leaflet/dune
+4
widget-leaflet/dune
+69
widget-leaflet/widget_leaflet.ml
+69
widget-leaflet/widget_leaflet.ml
···
1
+
let leaflet_adapter_js = {js|
2
+
(function() {
3
+
var CSS_URL = "https://unpkg.com/leaflet@1.9.4/dist/leaflet.css";
4
+
var JS_URL = "https://unpkg.com/leaflet@1.9.4/dist/leaflet.js";
5
+
function ensureCSS(url) {
6
+
if (!document.querySelector("link[href='" + url + "']")) {
7
+
var l = document.createElement("link");
8
+
l.rel = "stylesheet"; l.href = url;
9
+
document.head.appendChild(l);
10
+
}
11
+
}
12
+
function ensureScript(url, cb) {
13
+
if (window.L) return cb();
14
+
var s = document.createElement("script");
15
+
s.src = url; s.onload = cb;
16
+
document.body.appendChild(s);
17
+
}
18
+
return {
19
+
create: function(container, config, send) {
20
+
var state = { map: null, geojsonLayer: null };
21
+
ensureCSS(CSS_URL);
22
+
ensureScript(JS_URL, function() {
23
+
var cfg = JSON.parse(config);
24
+
container.style.height = cfg.height || "400px";
25
+
var div = document.createElement("div");
26
+
div.style.cssText = "width:100%;height:100%";
27
+
container.appendChild(div);
28
+
var map = L.map(div).setView(cfg.center, cfg.zoom);
29
+
L.tileLayer(cfg.tileUrl || "https://tile.openstreetmap.org/{z}/{x}/{y}.png", {
30
+
maxZoom: 19, attribution: "© OpenStreetMap"
31
+
}).addTo(map);
32
+
map.on("click", function(e) {
33
+
send("click", JSON.stringify({lat: e.latlng.lat, lng: e.latlng.lng}));
34
+
});
35
+
map.on("moveend", function() {
36
+
var c = map.getCenter(), z = map.getZoom(), b = map.getBounds();
37
+
send("moveend", JSON.stringify({
38
+
center: [c.lat, c.lng], zoom: z,
39
+
bounds: {south: b.getSouthWest().lat, west: b.getSouthWest().lng,
40
+
north: b.getNorthEast().lat, east: b.getNorthEast().lng}
41
+
}));
42
+
});
43
+
state.map = map;
44
+
});
45
+
return state;
46
+
},
47
+
update: function(state, config) {
48
+
if (!state.map) return;
49
+
var cfg = JSON.parse(config);
50
+
if (cfg.center) state.map.setView(cfg.center, cfg.zoom || state.map.getZoom());
51
+
},
52
+
command: function(state, cmd, data) {
53
+
if (!state.map) return;
54
+
var d = JSON.parse(data);
55
+
if (cmd === "flyTo") state.map.flyTo(L.latLng(d.lat, d.lng), d.zoom || state.map.getZoom());
56
+
else if (cmd === "fitBounds") state.map.fitBounds(d);
57
+
else if (cmd === "setData") {
58
+
if (state.geojsonLayer) state.map.removeLayer(state.geojsonLayer);
59
+
state.geojsonLayer = L.geoJSON(d).addTo(state.map);
60
+
}
61
+
else if (cmd === "invalidateSize") state.map.invalidateSize();
62
+
},
63
+
destroy: function(state) { if (state.map) state.map.remove(); }
64
+
};
65
+
})()
66
+
|js}
67
+
68
+
let register () =
69
+
Widget.register_adapter ~kind:"leaflet-map" ~js:leaflet_adapter_js
+3
widget-leaflet/widget_leaflet.mli
+3
widget-leaflet/widget_leaflet.mli
+14
widget/widget.ml
+14
widget/widget.ml
···
34
34
Hashtbl.remove widgets id;
35
35
send_msg (WidgetClear { widget_id = id })
36
36
37
+
let display_managed ~id ~kind ~config ~handlers =
38
+
Hashtbl.replace widgets id { handlers };
39
+
send_msg (WidgetUpdate { widget_id = id;
40
+
view = View.Managed { kind; config } })
41
+
42
+
let update_config ~id config =
43
+
send_msg (WidgetConfig { widget_id = id; config })
44
+
45
+
let command ~id cmd data =
46
+
send_msg (WidgetCommand { widget_id = id; command = cmd; data })
47
+
48
+
let register_adapter ~kind ~js =
49
+
send_msg (WidgetRegisterAdapter { kind; js_code = js })
50
+
37
51
let handle_event ~widget_id ~handler_id ~value =
38
52
match Hashtbl.find_opt widgets widget_id with
39
53
| None -> ()
+29
widget/widget.mli
+29
widget/widget.mli
···
49
49
(** [clear ~id] removes the widget and its handlers. Sends a
50
50
WidgetClear message to the client. *)
51
51
52
+
val display_managed :
53
+
id:string ->
54
+
kind:string ->
55
+
config:string ->
56
+
handlers:(string * (string option -> unit)) list ->
57
+
unit
58
+
(** [display_managed ~id ~kind ~config ~handlers] registers a managed widget.
59
+
The client delegates rendering to the adapter registered for [kind].
60
+
[config] is a JSON string interpreted by the adapter.
61
+
[handlers] route incoming events, same as {!display}. *)
62
+
63
+
val update_config : id:string -> string -> unit
64
+
(** [update_config ~id config] sends an updated config to a managed widget.
65
+
The adapter decides how to reconcile the change (e.g. flyTo, setData). *)
66
+
67
+
val command : id:string -> string -> string -> unit
68
+
(** [command ~id cmd data] sends an imperative command to a managed widget.
69
+
[cmd] is the command name, [data] is a JSON string payload.
70
+
Use for one-shot actions like animations that don't represent state. *)
71
+
72
+
val register_adapter : kind:string -> js:string -> unit
73
+
(** [register_adapter ~kind ~js] sends a JavaScript adapter to the client.
74
+
The JS code must be an IIFE that returns an object with methods:
75
+
- [create(container, config, send)] — creates the widget, returns state
76
+
- [update(state, config)] — reconciles a config change
77
+
- [command(state, cmd, data)] — handles an imperative command
78
+
- [destroy(state)] — cleans up
79
+
where [send(handler_id, value)] sends an event back to the worker. *)
80
+
52
81
val handle_event :
53
82
widget_id:string -> handler_id:string -> value:string option -> unit
54
83
(** [handle_event ~widget_id ~handler_id ~value] routes an incoming