jon.recoil.org
this repo has no description
refactor(x-ocaml): rewrite jtw_client to use message protocol
Replace Js_top_worker_client_fut (old RPC/IDL layer) with
Js_top_worker_client_msg (JSON message protocol). This removes the
dependency on rpclib, ppx_deriving_rpc, and toplevel_api_gen types
from the x-ocaml frontend.
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+3
-1
src/dune
+3
-1
src/dune
+152
-218
src/jtw_client.ml
+152
-218
src/jtw_client.ml
···
1
-
(** Bridge between x-ocaml's X_protocol and js_top_worker's JSON-RPC protocol.
1
+
(** Bridge between x-ocaml's X_protocol and js_top_worker's message protocol.
2
2
3
-
This module translates X_protocol requests into js_top_worker RPC calls
4
-
and converts the results back into X_protocol responses. *)
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
5
6
-
open Brr
7
-
module Jtw = Js_top_worker_client_fut
8
-
module W = Jtw.W
9
-
module Api = Js_top_worker_rpc.Toplevel_api_gen
6
+
module Jtw = Js_top_worker_client_msg
7
+
module Msg = Js_top_worker_message.Message
10
8
11
9
type t = {
12
-
rpc : Jtw.rpc;
10
+
client : Jtw.t;
13
11
mutable on_message_cb : X_protocol.response -> unit;
14
12
}
15
13
16
14
let make url =
17
-
let timeout_fn () =
18
-
Brr.Console.(log [ str "js_top_worker: timeout" ])
19
-
in
20
-
let rpc = Jtw.start url 30_000 timeout_fn in
21
-
{ rpc; on_message_cb = (fun _ -> ()) }
15
+
let client = Jtw.create url in
16
+
{ client; on_message_cb = (fun _ -> ()) }
22
17
23
18
let on_message t fn = t.on_message_cb <- fn
24
19
25
20
(** Send a response back to x-ocaml via the stored callback. *)
26
21
let respond t resp = t.on_message_cb resp
27
22
28
-
(** Convert a merlin position (polymorphic variant) to js_top_worker's
29
-
msource_position (regular variant). *)
30
-
let convert_position
31
-
(pos : [ `Start | `Offset of int | `Logical of int * int | `End ]) :
32
-
Api.msource_position =
33
-
match pos with
34
-
| `Start -> Api.Start
35
-
| `Offset n -> Api.Offset n
36
-
| `Logical (line, col) -> Api.Logical (line, col)
37
-
| `End -> Api.End
38
-
39
-
(** Convert js_top_worker kind_ty to merlin's Query_protocol.Compl.entry kind *)
40
-
let convert_kind (k : Api.kind_ty) :
41
-
[ `Value
42
-
| `Constructor
43
-
| `Variant
44
-
| `Label
45
-
| `Module
46
-
| `Modtype
47
-
| `Type
48
-
| `MethodCall
49
-
| `Keyword ] =
50
-
match k with
51
-
| Api.Value -> `Value
52
-
| Api.Constructor -> `Constructor
53
-
| Api.Variant -> `Variant
54
-
| Api.Label -> `Label
55
-
| Api.Module -> `Module
56
-
| Api.Modtype -> `Modtype
57
-
| Api.Type -> `Type
58
-
| Api.MethodCall -> `MethodCall
59
-
| Api.Keyword -> `Keyword
60
-
61
-
(** Convert js_top_worker completion entry to merlin's Query_protocol.Compl.entry *)
62
-
let convert_compl_entry (e : Api.query_protocol_compl_entry) :
63
-
Query_protocol.Compl.entry =
23
+
(** Convert Msg.completions to Protocol.completions *)
24
+
let convert_completions (c : Msg.completions) : Protocol.completions =
25
+
let convert_kind s : [ `Value | `Constructor | `Variant | `Label
26
+
| `Module | `Modtype | `Type | `MethodCall | `Keyword ] =
27
+
match s with
28
+
| "Constructor" -> `Constructor
29
+
| "Keyword" -> `Keyword
30
+
| "Label" -> `Label
31
+
| "MethodCall" -> `MethodCall
32
+
| "Modtype" -> `Modtype
33
+
| "Module" -> `Module
34
+
| "Type" -> `Type
35
+
| "Variant" -> `Variant
36
+
| _ -> `Value
37
+
in
64
38
{
65
-
Query_protocol.Compl.name = e.Api.name;
66
-
kind = convert_kind e.Api.kind;
67
-
desc = e.Api.desc;
68
-
info = e.Api.info;
69
-
deprecated = e.Api.deprecated;
39
+
Protocol.from = c.from;
40
+
to_ = c.to_;
41
+
entries = List.map (fun (e : Msg.compl_entry) ->
42
+
{ Query_protocol.Compl.name = e.name;
43
+
kind = convert_kind e.kind;
44
+
desc = e.desc;
45
+
info = e.info;
46
+
deprecated = e.deprecated }
47
+
) c.entries;
70
48
}
71
49
72
-
(** Convert js_top_worker completions to Protocol.completions *)
73
-
let convert_completions (c : Api.completions) : Protocol.completions =
74
-
{
75
-
Protocol.from = c.Api.from;
76
-
to_ = c.Api.to_;
77
-
entries = List.map convert_compl_entry c.Api.entries;
78
-
}
79
-
80
-
(** Convert js_top_worker error to Protocol.error.
81
-
Both use Ocaml_parsing.Location types, so this is a direct mapping. *)
82
-
let convert_error (e : Api.error) : Protocol.error =
83
-
{
84
-
Protocol.kind = e.Api.kind;
85
-
loc = e.Api.loc;
86
-
main = e.Api.main;
87
-
sub = e.Api.sub;
88
-
source = e.Api.source;
89
-
}
90
-
91
-
(** Convert js_top_worker is_tail_position to Protocol.is_tail_position *)
92
-
let convert_tail_position (tp : Api.is_tail_position) :
93
-
Protocol.is_tail_position =
94
-
match tp with
95
-
| Api.No -> `No
96
-
| Api.Tail_position -> `Tail_position
97
-
| Api.Tail_call -> `Tail_call
98
-
99
-
(** Convert js_top_worker index_or_string to the polymorphic variant form *)
100
-
let convert_index_or_string (ios : Api.index_or_string) :
101
-
[ `Index of int | `String of string ] =
102
-
match ios with
103
-
| Api.Index i -> `Index i
104
-
| Api.String s -> `String s
105
-
106
-
(** Convert a js_top_worker typed_enclosings entry to Protocol format *)
107
-
let convert_typed_enclosing
108
-
((loc, ios, tp) : Api.typed_enclosings) :
109
-
Ocaml_parsing.Location.t
110
-
* [ `Index of int | `String of string ]
111
-
* Protocol.is_tail_position =
112
-
(loc, convert_index_or_string ios, convert_tail_position tp)
113
-
114
-
(** Convert exec_result to X_protocol output list *)
115
-
let convert_exec_result (r : Api.exec_result) : X_protocol.output list =
116
-
let outputs = ref [] in
117
-
(* Add sharp_ppf output (toplevel responses like "val x : int = 1") *)
118
-
(match r.Api.sharp_ppf with
119
-
| Some s when s <> "" -> outputs := X_protocol.Meta s :: !outputs
120
-
| _ -> ());
121
-
(* Add caml_ppf output (type/module signatures) *)
122
-
(match r.Api.caml_ppf with
123
-
| Some s when s <> "" -> outputs := X_protocol.Meta s :: !outputs
124
-
| _ -> ());
125
-
(* Add stdout *)
126
-
(match r.Api.stdout with
127
-
| Some s when s <> "" -> outputs := X_protocol.Stdout s :: !outputs
128
-
| _ -> ());
129
-
(* Add stderr *)
130
-
(match r.Api.stderr with
131
-
| Some s when s <> "" -> outputs := X_protocol.Stderr s :: !outputs
132
-
| _ -> ());
133
-
List.rev !outputs
134
-
135
-
(** Ignore errors from async operations, logging them to the console *)
136
-
let handle_error = function
137
-
| Ok v -> Some v
138
-
| Error (Api.InternalError _msg) ->
139
-
Console.(log [ str "jtw_client error:"; str _msg ]);
140
-
None
50
+
(** Convert Msg.error to Protocol.error *)
51
+
let convert_error (e : Msg.error) : Protocol.error =
52
+
let loc_of_msg_loc (l : Msg.location) : Ocaml_parsing.Location.t =
53
+
{ loc_start = { pos_fname = ""; pos_lnum = l.loc_start.pos_lnum;
54
+
pos_bol = l.loc_start.pos_bol; pos_cnum = l.loc_start.pos_cnum };
55
+
loc_end = { pos_fname = ""; pos_lnum = l.loc_end.pos_lnum;
56
+
pos_bol = l.loc_end.pos_bol; pos_cnum = l.loc_end.pos_cnum };
57
+
loc_ghost = false }
58
+
in
59
+
let kind = match e.kind with
60
+
| "error" -> Ocaml_parsing.Location.Report_error
61
+
| s when String.length s > 8 && String.sub s 0 8 = "warning:" ->
62
+
Report_warning (String.sub s 8 (String.length s - 8))
63
+
| s when String.length s > 17 && String.sub s 0 17 = "warning_as_error:" ->
64
+
Report_warning_as_error (String.sub s 17 (String.length s - 17))
65
+
| s when String.length s > 6 && String.sub s 0 6 = "alert:" ->
66
+
Report_alert (String.sub s 6 (String.length s - 6))
67
+
| s when String.length s > 15 && String.sub s 0 15 = "alert_as_error:" ->
68
+
Report_alert_as_error (String.sub s 15 (String.length s - 15))
69
+
| _ -> Report_error
70
+
in
71
+
let source = match e.source with
72
+
| "lexer" -> Ocaml_parsing.Location.Lexer
73
+
| "parser" -> Parser
74
+
| "typer" -> Typer
75
+
| "warning" -> Warning
76
+
| "env" -> Env
77
+
| "config" -> Config
78
+
| "unknown" -> Unknown
79
+
| _ -> Unknown
80
+
in
81
+
{ Protocol.kind; loc = loc_of_msg_loc e.loc; main = e.main; sub = e.sub; source }
141
82
142
-
let init t =
143
-
let open Fut.Syntax in
144
-
let config : Api.init_config =
145
-
{
146
-
findlib_requires = [];
147
-
stdlib_dcs = None;
148
-
findlib_index = None;
149
-
execute = true;
150
-
}
83
+
(** Convert Msg.type_info to typed_enclosings entry *)
84
+
let convert_type_info (t : Msg.type_info) =
85
+
let loc : Ocaml_parsing.Location.t =
86
+
{ loc_start = { pos_fname = ""; pos_lnum = t.loc.loc_start.pos_lnum;
87
+
pos_bol = t.loc.loc_start.pos_bol; pos_cnum = t.loc.loc_start.pos_cnum };
88
+
loc_end = { pos_fname = ""; pos_lnum = t.loc.loc_end.pos_lnum;
89
+
pos_bol = t.loc.loc_end.pos_bol; pos_cnum = t.loc.loc_end.pos_cnum };
90
+
loc_ghost = false }
151
91
in
152
-
let _fut : unit Fut.t =
153
-
let* result = W.init t.rpc config in
154
-
(match result with
155
-
| Ok () ->
156
-
(* Setup the default environment (loads stdlib, etc.) *)
157
-
let* _setup = W.setup t.rpc "" in
158
-
Fut.return ()
159
-
| Error (Api.InternalError _msg) ->
160
-
Console.(log [ str "jtw_client init error:"; str _msg ]);
161
-
Fut.return ())
92
+
let tail = match t.tail with
93
+
| "tail_position" -> `Tail_position
94
+
| "tail_call" -> `Tail_call
95
+
| _ -> `No
162
96
in
163
-
()
97
+
(loc, `String t.type_str, tail)
98
+
99
+
let init t =
100
+
let config : Msg.init_config = {
101
+
findlib_requires = [];
102
+
stdlib_dcs = None;
103
+
findlib_index = None;
104
+
} in
105
+
Lwt.async (fun () ->
106
+
let open Lwt.Infix in
107
+
Jtw.init t.client config >>= fun () ->
108
+
Lwt.return_unit)
164
109
165
110
let post t (req : X_protocol.request) =
166
-
let open Fut.Syntax in
167
111
match req with
168
112
| X_protocol.Eval (id, line_number, code) ->
169
-
let _fut : unit Fut.t =
170
-
let* result = W.exec t.rpc "" code in
171
-
(match handle_error result with
172
-
| Some exec_result ->
173
-
let outputs = convert_exec_result exec_result in
174
-
if line_number > 0 then
175
-
respond t (X_protocol.Top_response_at (id, line_number, outputs))
176
-
else
177
-
respond t (X_protocol.Top_response (id, outputs))
178
-
| None ->
179
-
respond t
180
-
(X_protocol.Top_response
181
-
(id, [ X_protocol.Stderr "Internal error during evaluation" ])));
182
-
Fut.return ()
183
-
in
184
-
()
113
+
Lwt.async (fun () ->
114
+
let open Lwt.Infix in
115
+
Lwt.catch (fun () ->
116
+
Jtw.eval t.client code >|= fun output ->
117
+
let outputs = ref [] in
118
+
if output.caml_ppf <> "" then
119
+
outputs := X_protocol.Meta output.caml_ppf :: !outputs;
120
+
if output.stdout <> "" then
121
+
outputs := X_protocol.Stdout output.stdout :: !outputs;
122
+
if output.stderr <> "" then
123
+
outputs := X_protocol.Stderr output.stderr :: !outputs;
124
+
let outputs = List.rev !outputs in
125
+
if line_number > 0 then
126
+
respond t (X_protocol.Top_response_at (id, line_number, outputs))
127
+
else
128
+
respond t (X_protocol.Top_response (id, outputs)))
129
+
(fun _exn ->
130
+
respond t (X_protocol.Top_response
131
+
(id, [X_protocol.Stderr "Internal error during evaluation"]));
132
+
Lwt.return_unit))
133
+
185
134
| X_protocol.Merlin (id, Protocol.Complete_prefix (src, pos)) ->
186
-
let jtw_pos = convert_position pos in
187
-
let _fut : unit Fut.t =
188
-
let* result =
189
-
W.complete_prefix t.rpc "" None [] false src jtw_pos
190
-
in
191
-
(match handle_error result with
192
-
| Some completions ->
193
-
let converted = convert_completions completions in
194
-
respond t
195
-
(X_protocol.Merlin_response (id, Protocol.Completions converted))
196
-
| None ->
197
-
respond t
198
-
(X_protocol.Merlin_response
199
-
(id,
200
-
Protocol.Completions
201
-
{ Protocol.from = 0; to_ = 0; entries = [] })));
202
-
Fut.return ()
135
+
let position = match pos with
136
+
| `Offset n -> n
137
+
| _ -> 0
203
138
in
204
-
()
139
+
Lwt.async (fun () ->
140
+
let open Lwt.Infix in
141
+
Lwt.catch (fun () ->
142
+
Jtw.complete t.client src position >|= fun completions ->
143
+
respond t (X_protocol.Merlin_response
144
+
(id, Protocol.Completions (convert_completions completions))))
145
+
(fun _exn ->
146
+
respond t (X_protocol.Merlin_response
147
+
(id, Protocol.Completions { Protocol.from = 0; to_ = 0; entries = [] }));
148
+
Lwt.return_unit))
149
+
205
150
| X_protocol.Merlin (id, Protocol.Type_enclosing (src, pos)) ->
206
-
let jtw_pos = convert_position pos in
207
-
let _fut : unit Fut.t =
208
-
let* result =
209
-
W.type_enclosing t.rpc "" None [] false src jtw_pos
210
-
in
211
-
(match handle_error result with
212
-
| Some enclosings ->
213
-
let converted = List.map convert_typed_enclosing enclosings in
214
-
respond t
215
-
(X_protocol.Merlin_response
216
-
(id, Protocol.Typed_enclosings converted))
217
-
| None ->
218
-
respond t
219
-
(X_protocol.Merlin_response
220
-
(id, Protocol.Typed_enclosings [])));
221
-
Fut.return ()
151
+
let position = match pos with
152
+
| `Offset n -> n
153
+
| _ -> 0
222
154
in
223
-
()
155
+
Lwt.async (fun () ->
156
+
let open Lwt.Infix in
157
+
Lwt.catch (fun () ->
158
+
Jtw.type_at t.client src position >|= fun types ->
159
+
respond t (X_protocol.Merlin_response
160
+
(id, Protocol.Typed_enclosings (List.map convert_type_info types))))
161
+
(fun _exn ->
162
+
respond t (X_protocol.Merlin_response
163
+
(id, Protocol.Typed_enclosings []));
164
+
Lwt.return_unit))
165
+
224
166
| X_protocol.Merlin (id, Protocol.All_errors src) ->
225
-
let _fut : unit Fut.t =
226
-
let* result =
227
-
W.query_errors t.rpc "" None [] false src
228
-
in
229
-
(match handle_error result with
230
-
| Some errors ->
231
-
let converted = List.map convert_error errors in
232
-
respond t
233
-
(X_protocol.Merlin_response (id, Protocol.Errors converted))
234
-
| None ->
235
-
respond t
236
-
(X_protocol.Merlin_response (id, Protocol.Errors [])));
237
-
Fut.return ()
238
-
in
239
-
()
167
+
Lwt.async (fun () ->
168
+
let open Lwt.Infix in
169
+
Lwt.catch (fun () ->
170
+
Jtw.errors t.client src >|= fun errors ->
171
+
respond t (X_protocol.Merlin_response
172
+
(id, Protocol.Errors (List.map convert_error errors))))
173
+
(fun _exn ->
174
+
respond t (X_protocol.Merlin_response (id, Protocol.Errors []));
175
+
Lwt.return_unit))
176
+
240
177
| X_protocol.Merlin (id, Protocol.Add_cmis _) ->
241
-
(* js_top_worker handles CMI loading internally via its init config *)
242
178
respond t (X_protocol.Merlin_response (id, Protocol.Added_cmis))
179
+
243
180
| X_protocol.Format (id, code) ->
244
-
(* js_top_worker doesn't support formatting; return the code as-is *)
245
181
respond t (X_protocol.Formatted_source (id, code))
246
-
| X_protocol.Format_config _ ->
247
-
(* No-op: js_top_worker doesn't support format configuration *)
248
-
()
249
-
| X_protocol.Setup ->
250
-
(* init already called by make_jtw; no-op here *)
251
-
()
182
+
183
+
| X_protocol.Format_config _ -> ()
184
+
185
+
| X_protocol.Setup -> ()
252
186
253
187
let eval ~id ~line_number t code =
254
188
post t (X_protocol.Eval (id, line_number, code))