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