jon.recoil.org
this repo has no description
1open Js_top_worker
2
3(* OCamlorg toplevel in a web worker
4
5 This communicates with the toplevel code via a simple message-based
6 protocol defined in {!Js_top_worker_message.Message}. This allows
7 the OCaml execution to not block the "main thread" keeping the page
8 responsive. *)
9
10module Msg = Js_top_worker_message.Message
11
12let loc = function
13 | Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
14 | Lexer.Error (_, loc)
15 | Typecore.Error (loc, _, _)
16 | Typetexp.Error (loc, _, _)
17 | Typeclass.Error (loc, _, _)
18 | Typemod.Error (loc, _, _)
19 | Typedecl.Error (loc, _)
20 | Translcore.Error (loc, _)
21 | Translclass.Error (loc, _)
22 | Translmod.Error (loc, _) ->
23 Some loc
24 | _ -> None
25
26module S : Impl.S = struct
27 type findlib_t = Findlibish.t
28
29 let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
30 fun f () ->
31 let stdout_buff = Buffer.create 1024 in
32 let stderr_buff = Buffer.create 1024 in
33 Js_of_ocaml.Sys_js.set_channel_flusher stdout
34 (Buffer.add_string stdout_buff);
35 Js_of_ocaml.Sys_js.set_channel_flusher stderr
36 (Buffer.add_string stderr_buff);
37 let x = f () in
38 let captured =
39 {
40 Impl.stdout = Buffer.contents stdout_buff;
41 stderr = Buffer.contents stderr_buff;
42 }
43 in
44 (captured, x)
45
46 let sync_get = Jslib.sync_get
47 let async_get = Jslib.async_get
48
49 (* Idempotent create_file that ignores "file already exists" errors.
50 This is needed because multiple .cma.js files compiled with --toplevel
51 may embed the same CMI files, and when loaded via import_scripts they
52 all try to register those CMIs. *)
53 let create_file ~name ~content =
54 try Js_of_ocaml.Sys_js.create_file ~name ~content
55 with Sys_error _ -> ()
56
57 let get_stdlib_dcs uri =
58 Findlibish.fetch_dynamic_cmis sync_get uri |> Result.to_list
59
60 let find_stdlib_dcs v =
61 (* Try "stdlib" first (standard META name), fall back to "ocaml" *)
62 let pkg = match Findlibish.find_dcs_url v "stdlib" with
63 | Some _ as r -> r
64 | None -> Findlibish.find_dcs_url v "ocaml"
65 in
66 match pkg with
67 | Some url ->
68 Jslib.log "Found stdlib dcs via findlib: %s" url;
69 (match Findlibish.fetch_dynamic_cmis sync_get url with
70 | Ok dcs ->
71 (* The dcs_url in the JSON is relative to the package dir.
72 Rewrite it to be absolute using the dynamic_cmis.json URL
73 parent directory. *)
74 let abs_dcs_url =
75 match String.rindex_opt url '/' with
76 | Some i -> String.sub url 0 (i + 1)
77 | None -> url
78 in
79 Jslib.log "Rewriting dcs_url from %s to %s" dcs.Impl.dcs_url abs_dcs_url;
80 [{ dcs with Impl.dcs_url = abs_dcs_url }]
81 | Error _ -> [])
82 | None ->
83 Jslib.log "stdlib not found in findlib (tried 'stdlib' and 'ocaml')";
84 []
85
86 let import_scripts urls =
87 (* Map relative URLs to absolute using the global base URL *)
88 let absolute_urls = List.map Jslib.map_url urls in
89 (* Chrome blocks cross-origin importScripts for .cma.js files (CORB).
90 Work around this by fetching with sync XHR and eval'ing the code. *)
91 let worker_origin =
92 Js_of_ocaml.Js.Optdef.case
93 (Js_of_ocaml.Js.Unsafe.js_expr "self.location.origin")
94 (fun () -> "")
95 Js_of_ocaml.Js.to_string
96 in
97 List.iter (fun url ->
98 let is_cross_origin =
99 worker_origin <> ""
100 && String.length url > 8
101 && (let prefix =
102 try String.sub url 0 (String.index_from url 8 '/' + 1)
103 with Not_found -> url
104 in
105 not (String.length prefix <= String.length worker_origin + 1
106 && String.sub url 0 (String.length worker_origin)
107 = worker_origin))
108 in
109 if is_cross_origin then begin
110 Jslib.log "Cross-origin import via fetch+eval: %s" url;
111 match Jslib.sync_get url with
112 | Some code ->
113 let (_ : 'a) =
114 Js_of_ocaml.Js.Unsafe.fun_call
115 (Js_of_ocaml.Js.Unsafe.js_expr "eval")
116 [| Js_of_ocaml.Js.Unsafe.inject
117 (Js_of_ocaml.Js.string code) |]
118 in
119 ()
120 | None ->
121 failwith (Printf.sprintf "Failed to fetch cross-origin script: %s" url)
122 end else
123 Js_of_ocaml.Worker.import_scripts [url]
124 ) absolute_urls
125 let findlib_init = Findlibish.init async_get
126
127 let require b v = function
128 | [] -> []
129 | packages -> Findlibish.require ~import_scripts sync_get b v packages
130
131 let init_function func_name =
132 let open Js_of_ocaml in
133 let func = Js.Unsafe.js_expr func_name in
134 fun () -> Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |]
135
136 let path = "/static/cmis"
137end
138
139module M = Impl.Make (S)
140
141(** Send a message back to the client *)
142let send_message msg =
143 let json = Msg.string_of_worker_msg msg in
144 Jslib.log "Worker sending: %s" json;
145 Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string json)
146
147(** Convert exec_result to Message.Output *)
148let output_of_exec_result cell_id (r : Impl.exec_result) =
149 let mime_vals = List.map (fun (mv : Impl.mime_val) ->
150 { Msg.mime_type = mv.mime_type; data = mv.data }
151 ) r.mime_vals in
152 Msg.Output {
153 cell_id;
154 stdout = Option.value ~default:"" r.stdout;
155 stderr = Option.value ~default:"" r.stderr;
156 caml_ppf = Option.value ~default:"" r.caml_ppf;
157 mime_vals;
158 }
159
160(** Convert phrase_output to Message.OutputAt *)
161let output_at_of_phrase cell_id (p : Impl.Make(S).phrase_output) =
162 let mime_vals = List.map (fun (mv : Impl.mime_val) ->
163 { Msg.mime_type = mv.mime_type; data = mv.data }
164 ) p.mime_vals in
165 Msg.OutputAt {
166 cell_id;
167 loc = p.loc;
168 caml_ppf = Option.value ~default:"" p.caml_ppf;
169 mime_vals;
170 }
171
172(** Convert completions to Message.Completions *)
173let completions_of_result cell_id (c : Impl.completions) =
174 let entries = List.map (fun (e : Impl.query_protocol_compl_entry) ->
175 let kind = match e.kind with
176 | Constructor -> "Constructor"
177 | Keyword -> "Keyword"
178 | Label -> "Label"
179 | MethodCall -> "MethodCall"
180 | Modtype -> "Modtype"
181 | Module -> "Module"
182 | Type -> "Type"
183 | Value -> "Value"
184 | Variant -> "Variant"
185 in
186 { Msg.name = e.name; kind; desc = e.desc; info = e.info; deprecated = e.deprecated }
187 ) c.entries in
188 Msg.Completions {
189 cell_id;
190 completions = { from = c.from; to_ = c.to_; entries };
191 }
192
193(** Convert location to Message.location *)
194let location_of_loc (loc : Impl.location) : Msg.location =
195 {
196 loc_start = {
197 pos_cnum = loc.loc_start.pos_cnum;
198 pos_lnum = loc.loc_start.pos_lnum;
199 pos_bol = loc.loc_start.pos_bol;
200 };
201 loc_end = {
202 pos_cnum = loc.loc_end.pos_cnum;
203 pos_lnum = loc.loc_end.pos_lnum;
204 pos_bol = loc.loc_end.pos_bol;
205 };
206 }
207
208(** Convert error_kind to string *)
209let string_of_error_kind = function
210 | Impl.Report_error -> "error"
211 | Report_warning s -> "warning:" ^ s
212 | Report_warning_as_error s -> "warning_as_error:" ^ s
213 | Report_alert s -> "alert:" ^ s
214 | Report_alert_as_error s -> "alert_as_error:" ^ s
215
216(** Convert error_source to string *)
217let string_of_error_source = function
218 | Impl.Lexer -> "lexer"
219 | Parser -> "parser"
220 | Typer -> "typer"
221 | Warning -> "warning"
222 | Unknown -> "unknown"
223 | Env -> "env"
224 | Config -> "config"
225
226(** Convert errors to Message.ErrorList *)
227let errors_of_result cell_id (errors : Impl.error list) =
228 let errors = List.map (fun (e : Impl.error) ->
229 {
230 Msg.kind = string_of_error_kind e.kind;
231 loc = location_of_loc e.loc;
232 main = e.main;
233 sub = e.sub;
234 source = string_of_error_source e.source;
235 }
236 ) errors in
237 Msg.ErrorList { cell_id; errors }
238
239(** Convert typed_enclosings to Message.Types *)
240let types_of_result cell_id (enclosings : Impl.typed_enclosings list) =
241 let types = List.map (fun ((loc, idx_or_str, tail) : Impl.typed_enclosings) ->
242 let type_str = match idx_or_str with
243 | Impl.String s -> s
244 | Index _ -> ""
245 in
246 let tail = match tail with
247 | Impl.No -> "no"
248 | Tail_position -> "tail_position"
249 | Tail_call -> "tail_call"
250 in
251 {
252 Msg.loc = location_of_loc loc;
253 type_str;
254 tail;
255 }
256 ) enclosings in
257 Msg.Types { cell_id; types }
258
259(** Convert position from int to Impl.msource_position *)
260let position_of_int pos =
261 Impl.Offset pos
262
263(** Handle a client message *)
264let handle_message msg =
265 let open Lwt.Infix in
266 match msg with
267 | Msg.Init config ->
268 let init_config : Impl.init_config = {
269 findlib_requires = config.findlib_requires;
270 stdlib_dcs = config.stdlib_dcs;
271 findlib_index = config.findlib_index;
272 execute = true;
273 } in
274 M.init init_config >>= fun result ->
275 (match result with
276 | Ok () ->
277 (* After init, automatically setup the default environment *)
278 M.setup "" >|= fun setup_result ->
279 (match setup_result with
280 | Ok _ -> send_message Msg.Ready
281 | Error (Impl.InternalError msg) ->
282 send_message (Msg.InitError { message = msg }))
283 | Error (Impl.InternalError msg) ->
284 send_message (Msg.InitError { message = msg });
285 Lwt.return_unit)
286
287 | Msg.Eval { cell_id; env_id; code } ->
288 Jslib.log "Eval cell_id=%d env_id=%s" cell_id env_id;
289 let on_phrase_output p = send_message (output_at_of_phrase cell_id p) in
290 M.execute_incremental env_id code ~on_phrase_output >|= fun result ->
291 (match result with
292 | Ok exec_result ->
293 send_message (output_of_exec_result cell_id exec_result)
294 | Error (Impl.InternalError msg) ->
295 send_message (Msg.EvalError { cell_id; message = msg }))
296
297 | Msg.Complete { cell_id; env_id; source; position; filename } ->
298 let pos = position_of_int position in
299 M.complete_prefix ?filename env_id None [] false source pos >|= fun result ->
300 (match result with
301 | Ok completions ->
302 send_message (completions_of_result cell_id completions)
303 | Error (Impl.InternalError msg) ->
304 send_message (Msg.EvalError { cell_id; message = msg }))
305
306 | Msg.TypeAt { cell_id; env_id; source; position; filename } ->
307 let pos = position_of_int position in
308 M.type_enclosing ?filename env_id None [] false source pos >|= fun result ->
309 (match result with
310 | Ok types ->
311 send_message (types_of_result cell_id types)
312 | Error (Impl.InternalError msg) ->
313 send_message (Msg.EvalError { cell_id; message = msg }))
314
315 | Msg.Errors { cell_id; env_id; source; filename } ->
316 M.query_errors ?filename env_id None [] false source >|= fun result ->
317 (match result with
318 | Ok errors ->
319 send_message (errors_of_result cell_id errors)
320 | Error (Impl.InternalError msg) ->
321 send_message (Msg.EvalError { cell_id; message = msg }))
322
323 | Msg.CreateEnv { env_id } ->
324 M.create_env env_id >|= fun result ->
325 (match result with
326 | Ok () -> send_message (Msg.EnvCreated { env_id })
327 | Error (Impl.InternalError msg) ->
328 send_message (Msg.InitError { message = msg }))
329
330 | Msg.DestroyEnv { env_id } ->
331 M.destroy_env env_id >|= fun result ->
332 (match result with
333 | Ok () -> send_message (Msg.EnvDestroyed { env_id })
334 | Error (Impl.InternalError msg) ->
335 send_message (Msg.InitError { message = msg }))
336
337 | Msg.WidgetEvent { widget_id; handler_id; value; _ } ->
338 Widget.handle_event ~widget_id ~handler_id ~value;
339 Lwt.return_unit
340
341let run () =
342 let open Js_of_ocaml in
343 try
344 Console.console##log (Js.string "Starting worker (message protocol)...");
345
346 Logs.set_reporter (Logs_browser.console_reporter ());
347 Logs.set_level (Some Logs.Debug);
348
349 (* Initialize Widget module sender *)
350 Widget.set_sender (fun json ->
351 Jslib.log "Widget sending: %s" json;
352 Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string json));
353
354 Js_of_ocaml.Worker.set_onmessage (fun x ->
355 let s = Js_of_ocaml.Js.to_string x in
356 Jslib.log "Worker received: %s" s;
357 try
358 let msg = Msg.client_msg_of_string s in
359 Lwt.async (fun () -> handle_message msg)
360 with e ->
361 Jslib.log "Error parsing message: %s" (Printexc.to_string e);
362 send_message (Msg.InitError { message = Printexc.to_string e }));
363
364 Console.console##log (Js.string "Worker ready")
365 with e ->
366 Console.console##log (Js.string ("Exception: " ^ Printexc.to_string e))