jon.recoil.org
this repo has no description
1(** Bridge between x-ocaml's X_protocol and js_top_worker's message protocol.
2
3 This module translates X_protocol requests into js_top_worker message
4 protocol calls and converts the results back into X_protocol responses. *)
5
6module Jtw = Js_top_worker_client_msg
7module Msg = Js_top_worker_message.Message
8
9type t = {
10 mutable client : Jtw.t;
11 url : string;
12 mutable init_config : Msg.init_config option;
13 mutable on_message_cb : X_protocol.response -> unit;
14}
15
16let is_cross_origin url =
17 try
18 let page_origin = Jv.to_string (Jv.get (Brr.Window.to_jv Brr.G.window) "origin") in
19 let url_obj = Jv.new' (Jv.get Jv.global "URL") [| Jv.of_string url |] in
20 let url_origin = Jv.to_string (Jv.get url_obj "origin") in
21 page_origin <> url_origin
22 with _ -> false
23
24let make_effective_url url =
25 if is_cross_origin url then begin
26 let base_dir =
27 match String.rindex_opt url '/' with
28 | Some i -> String.sub url 0 i
29 | None -> url
30 in
31 let js_code = Printf.sprintf
32 {|globalThis.__global_rel_url="%s";importScripts("%s");|}
33 base_dir url in
34 let blob = Jv.new' (Jv.get Jv.global "Blob")
35 [| Jv.of_jv_array [| Jv.of_string js_code |];
36 Jv.obj [| "type", Jv.of_string "application/javascript" |] |] in
37 Jv.to_string
38 (Jv.call (Jv.get Jv.global "URL") "createObjectURL" [| blob |])
39 end else
40 url
41
42let make url =
43 let effective_url = make_effective_url url in
44 let client = Jtw.create effective_url in
45 let t = { client; url; init_config = None; on_message_cb = (fun _ -> ()) } in
46 (* Wire widget rendering: forward widget messages from the worker to the
47 DOM renderer, and send widget events back to the worker. *)
48 let send_fn ~widget_id ~handler_id ~event_type ~value =
49 Jtw.send_widget_event client ~widget_id ~handler_id ~event_type ~value
50 in
51 Jtw.set_on_widget_update client (fun widget_id view_any ->
52 (* view_any is Js.Unsafe.any — coerce to Jv.t (they are the same repr) *)
53 let view_jv : Jv.t = Obj.magic view_any in
54 Widget_render.update_widget ~send:send_fn widget_id view_jv);
55 Jtw.set_on_widget_clear client (fun widget_id ->
56 Widget_render.clear_widget widget_id);
57 Jtw.set_on_widget_config client (fun widget_id config ->
58 Widget_render.config_widget widget_id config);
59 Jtw.set_on_widget_command client (fun widget_id cmd data ->
60 Widget_render.command_widget widget_id cmd data);
61 Jtw.set_on_widget_register_adapter client (fun kind js_code ->
62 Widget_render.register_js_adapter ~send:send_fn kind js_code);
63 t
64
65let on_message t fn = t.on_message_cb <- fn
66
67(** Send a response back to x-ocaml via the stored callback. *)
68let respond t resp = t.on_message_cb resp
69
70(** Convert Msg.completions to Protocol.completions *)
71let convert_completions (c : Msg.completions) : Protocol.completions =
72 let convert_kind s : [ `Value | `Constructor | `Variant | `Label
73 | `Module | `Modtype | `Type | `MethodCall | `Keyword ] =
74 match s with
75 | "Constructor" -> `Constructor
76 | "Keyword" -> `Keyword
77 | "Label" -> `Label
78 | "MethodCall" -> `MethodCall
79 | "Modtype" -> `Modtype
80 | "Module" -> `Module
81 | "Type" -> `Type
82 | "Variant" -> `Variant
83 | _ -> `Value
84 in
85 {
86 Protocol.from = c.from;
87 to_ = c.to_;
88 entries = List.map (fun (e : Msg.compl_entry) ->
89 { Query_protocol.Compl.name = e.name;
90 kind = convert_kind e.kind;
91 desc = e.desc;
92 info = e.info;
93 deprecated = e.deprecated;
94#if defined OXCAML
95 ppx_template_generated = false;
96#endif
97 }
98 ) c.entries;
99 }
100
101(** Convert Msg.error to Protocol.error *)
102let convert_error (e : Msg.error) : Protocol.error =
103 let loc_of_msg_loc (l : Msg.location) : Ocaml_parsing.Location.t =
104 { loc_start = { pos_fname = ""; pos_lnum = l.loc_start.pos_lnum;
105 pos_bol = l.loc_start.pos_bol; pos_cnum = l.loc_start.pos_cnum };
106 loc_end = { pos_fname = ""; pos_lnum = l.loc_end.pos_lnum;
107 pos_bol = l.loc_end.pos_bol; pos_cnum = l.loc_end.pos_cnum };
108 loc_ghost = false }
109 in
110 let kind = match e.kind with
111 | "error" -> Ocaml_parsing.Location.Report_error
112 | s when String.length s > 8 && String.sub s 0 8 = "warning:" ->
113 Report_warning (String.sub s 8 (String.length s - 8))
114 | s when String.length s > 17 && String.sub s 0 17 = "warning_as_error:" ->
115 Report_warning_as_error (String.sub s 17 (String.length s - 17))
116 | s when String.length s > 6 && String.sub s 0 6 = "alert:" ->
117 Report_alert (String.sub s 6 (String.length s - 6))
118 | s when String.length s > 15 && String.sub s 0 15 = "alert_as_error:" ->
119 Report_alert_as_error (String.sub s 15 (String.length s - 15))
120 | _ -> Report_error
121 in
122 let source = match e.source with
123 | "lexer" -> Ocaml_parsing.Location.Lexer
124 | "parser" -> Parser
125 | "typer" -> Typer
126 | "warning" -> Warning
127 | "env" -> Env
128 | "config" -> Config
129 | "unknown" -> Unknown
130 | _ -> Unknown
131 in
132 { Protocol.kind; loc = loc_of_msg_loc e.loc; main = e.main; sub = e.sub; source }
133
134(** Convert Msg.type_info to typed_enclosings entry *)
135let convert_type_info (t : Msg.type_info) =
136 let loc : Ocaml_parsing.Location.t =
137 { loc_start = { pos_fname = ""; pos_lnum = t.loc.loc_start.pos_lnum;
138 pos_bol = t.loc.loc_start.pos_bol; pos_cnum = t.loc.loc_start.pos_cnum };
139 loc_end = { pos_fname = ""; pos_lnum = t.loc.loc_end.pos_lnum;
140 pos_bol = t.loc.loc_end.pos_bol; pos_cnum = t.loc.loc_end.pos_cnum };
141 loc_ghost = false }
142 in
143 let tail = match t.tail with
144 | "tail_position" -> `Tail_position
145 | "tail_call" -> `Tail_call
146 | _ -> `No
147 in
148 (loc, `String t.type_str, tail)
149
150let init ?(findlib_requires = []) ?findlib_index t =
151 (* Derive stdlib_dcs from findlib_index base URL so cross-origin universes
152 can find their dynamic_cmis.json at the correct absolute URL. *)
153 let stdlib_dcs = match findlib_index with
154 | Some fi ->
155 (match String.rindex_opt fi '/' with
156 | Some i -> Some (String.sub fi 0 (i + 1) ^ "lib/ocaml/dynamic_cmis.json")
157 | None -> None)
158 | None -> None
159 in
160 let config : Msg.init_config = {
161 findlib_requires;
162 stdlib_dcs;
163 findlib_index;
164 } in
165 t.init_config <- Some config;
166 Lwt.async (fun () ->
167 let open Lwt.Infix in
168 Jtw.init t.client config >>= fun () ->
169 Lwt.return_unit)
170
171let reset t =
172 Jtw.terminate t.client;
173 let effective_url = make_effective_url t.url in
174 t.client <- Jtw.create effective_url;
175 match t.init_config with
176 | Some config ->
177 Lwt.async (fun () ->
178 let open Lwt.Infix in
179 Jtw.init t.client config >>= fun () ->
180 Lwt.return_unit)
181 | None -> ()
182
183let post t (req : X_protocol.request) =
184 match req with
185 | X_protocol.Eval (id, _line_number, code) ->
186 (* Tell widget_render which cell is executing so widgets are placed
187 right after this cell's <x-ocaml> element in the DOM. *)
188 let doc = Brr.Document.to_jv Brr.G.document in
189 let cells = Jv.call doc "querySelectorAll" [| Jv.of_string "x-ocaml" |] in
190 let cell_el = Jv.call cells "item" [| Jv.of_int id |] in
191 if not (Jv.is_null cell_el) then
192 Widget_render.set_active_cell cell_el;
193 let stream = Jtw.eval_stream t.client code in
194 Lwt.async (fun () ->
195 Lwt.catch (fun () ->
196 Lwt_stream.iter (function
197 | Jtw.Phrase { loc; caml_ppf; _ } ->
198 let outputs =
199 if caml_ppf <> "" then [X_protocol.Meta caml_ppf] else []
200 in
201 if outputs <> [] then
202 respond t (X_protocol.Top_response_at (id, loc, outputs))
203 | Jtw.Done { stdout; stderr; caml_ppf; _ } ->
204 let outputs = ref [] in
205 if caml_ppf <> "" then
206 outputs := X_protocol.Meta caml_ppf :: !outputs;
207 if stdout <> "" then
208 outputs := X_protocol.Stdout stdout :: !outputs;
209 if stderr <> "" then
210 outputs := X_protocol.Stderr stderr :: !outputs;
211 respond t (X_protocol.Top_response (id, List.rev !outputs))
212 | Jtw.Error msg ->
213 respond t (X_protocol.Top_response
214 (id, [X_protocol.Stderr msg]))
215 ) stream)
216 (fun _exn ->
217 respond t (X_protocol.Top_response
218 (id, [X_protocol.Stderr "Internal error during evaluation"]));
219 Lwt.return_unit))
220
221 | X_protocol.Merlin (id, Protocol.Complete_prefix (src, pos, filename)) ->
222 let position = match pos with
223 | `Offset n -> n
224 | _ -> 0
225 in
226 Lwt.async (fun () ->
227 let open Lwt.Infix in
228 Lwt.catch (fun () ->
229 Jtw.complete ?filename t.client src position >|= fun completions ->
230 respond t (X_protocol.Merlin_response
231 (id, Protocol.Completions (convert_completions completions))))
232 (fun _exn ->
233 respond t (X_protocol.Merlin_response
234 (id, Protocol.Completions { Protocol.from = 0; to_ = 0; entries = [] }));
235 Lwt.return_unit))
236
237 | X_protocol.Merlin (id, Protocol.Type_enclosing (src, pos, filename)) ->
238 let position = match pos with
239 | `Offset n -> n
240 | _ -> 0
241 in
242 Lwt.async (fun () ->
243 let open Lwt.Infix in
244 Lwt.catch (fun () ->
245 Jtw.type_at ?filename t.client src position >|= fun types ->
246 respond t (X_protocol.Merlin_response
247 (id, Protocol.Typed_enclosings (List.map convert_type_info types))))
248 (fun _exn ->
249 respond t (X_protocol.Merlin_response
250 (id, Protocol.Typed_enclosings []));
251 Lwt.return_unit))
252
253 | X_protocol.Merlin (id, Protocol.All_errors (src, filename)) ->
254 Lwt.async (fun () ->
255 let open Lwt.Infix in
256 Lwt.catch (fun () ->
257 Jtw.errors ?filename t.client src >|= fun errors ->
258 respond t (X_protocol.Merlin_response
259 (id, Protocol.Errors (List.map convert_error errors))))
260 (fun _exn ->
261 respond t (X_protocol.Merlin_response (id, Protocol.Errors []));
262 Lwt.return_unit))
263
264 | X_protocol.Merlin (id, Protocol.Add_cmis _) ->
265 respond t (X_protocol.Merlin_response (id, Protocol.Added_cmis))
266
267 | X_protocol.Format (id, code) ->
268 respond t (X_protocol.Formatted_source (id, code))
269
270 | X_protocol.Format_config _ -> ()
271
272 | X_protocol.Setup -> ()
273
274 | X_protocol.Add_cmis _ -> () (* js_top_worker manages its own CMIs *)
275
276let eval ~id ~line_number t code =
277 post t (X_protocol.Eval (id, line_number, code))
278
279let fmt ~id t code =
280 post t (X_protocol.Format (id, code))