jon.recoil.org
this repo has no description
Add incremental output support and simplify RPC layer
Replace CBOR/channel-based transport with direct message passing.
Add OutputAt message type for incremental cell output streaming.
Remove unused channel.ml/mli and rpc_cbor.ml/mli modules.
Update client libraries with worker blob URL creation helper.
Add node-based incremental output test.
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+680
-540
+13
client/ocaml-worker.d.ts
+13
client/ocaml-worker.d.ts
···
115
115
env_id: string;
116
116
}
117
117
118
+
export interface OutputAt {
119
+
/** Cell identifier */
120
+
cell_id: number;
121
+
/** Character position after phrase (pos_cnum) */
122
+
loc: number;
123
+
/** OCaml pretty-printed output for this phrase */
124
+
caml_ppf: string;
125
+
/** MIME values for this phrase */
126
+
mime_vals: MimeVal[];
127
+
}
128
+
118
129
export interface OcamlWorkerOptions {
119
130
/** Timeout in milliseconds (default: 30000) */
120
131
timeout?: number;
132
+
/** Callback for incremental output after each phrase */
133
+
onOutputAt?: (output: OutputAt) => void;
121
134
}
122
135
123
136
export class OcamlWorker {
+34
-2
client/ocaml-worker.js
+34
-2
client/ocaml-worker.js
···
88
88
* @property {string} tail - Tail position info
89
89
*/
90
90
91
+
/**
92
+
* @typedef {Object} OutputAt
93
+
* @property {number} cell_id - Cell identifier
94
+
* @property {number} loc - Character position after phrase (pos_cnum)
95
+
* @property {string} caml_ppf - OCaml pretty-printed output for this phrase
96
+
* @property {MimeVal[]} mime_vals - MIME values for this phrase
97
+
*/
98
+
91
99
export class OcamlWorker {
92
100
/**
101
+
* Create the worker blob URL with proper base URL setup.
102
+
* The worker needs __global_rel_url to find its resources.
103
+
* @private
104
+
*/
105
+
static _createWorkerUrl(baseUrl) {
106
+
// Convert relative URL to absolute - importScripts in blob workers needs absolute URLs
107
+
const absoluteBase = new URL(baseUrl, window.location.href).href;
108
+
// Remove the trailing /worker.js to get the base directory
109
+
const baseDir = absoluteBase.replace(/\/worker\.js$/, '');
110
+
const content = `globalThis.__global_rel_url="${baseDir}"\nimportScripts("${absoluteBase}");`;
111
+
return URL.createObjectURL(new Blob([content], { type: "text/javascript" }));
112
+
}
113
+
114
+
/**
93
115
* Create a new OCaml worker client.
94
-
* @param {string} workerUrl - URL to the worker script
116
+
* @param {string} workerUrl - URL to the worker script (e.g., '_opam/worker.js')
95
117
* @param {Object} [options] - Options
96
118
* @param {number} [options.timeout=30000] - Timeout in milliseconds
119
+
* @param {function(OutputAt): void} [options.onOutputAt] - Callback for incremental output
97
120
*/
98
121
constructor(workerUrl, options = {}) {
99
-
this.worker = new Worker(workerUrl);
122
+
const blobUrl = OcamlWorker._createWorkerUrl(workerUrl);
123
+
this.worker = new Worker(blobUrl);
100
124
this.timeout = options.timeout || 30000;
125
+
this.onOutputAt = options.onOutputAt || null;
101
126
this.cellIdCounter = 0;
102
127
this.pendingRequests = new Map();
103
128
this.readyPromise = null;
···
132
157
reject(new Error(msg.message));
133
158
this.pendingRequests.delete('init');
134
159
}
160
+
}
161
+
break;
162
+
163
+
case 'output_at':
164
+
// Incremental output - call callback but don't resolve (wait for final 'output')
165
+
if (this.onOutputAt) {
166
+
this.onOutputAt(msg);
135
167
}
136
168
break;
137
169
-166
idl/channel.ml
-166
idl/channel.ml
···
1
-
(** Bidirectional message channel for worker communication. *)
2
-
3
-
type push_kind =
4
-
| Output of { stream : [ `Stdout | `Stderr ]; data : string }
5
-
| Widget_update of { widget_id : string; state : Rpc.t }
6
-
| Progress of { task_id : string; percent : int; message : string option }
7
-
| Custom_push of { kind : string; data : Rpc.t }
8
-
9
-
type event_kind =
10
-
| Widget_event of { widget_id : string; event_type : string; data : Rpc.t }
11
-
| Custom_event of { kind : string; data : Rpc.t }
12
-
13
-
type message =
14
-
| Request of { id : int64; call : Rpc.call }
15
-
| Response of { id : int64; response : Rpc.response }
16
-
| Push of push_kind
17
-
| Event of event_kind
18
-
19
-
(* CBOR tags for message discrimination *)
20
-
let tag_request = 0
21
-
let tag_response = 1
22
-
let tag_push = 2
23
-
let tag_event = 3
24
-
25
-
(* CBOR tags for push kinds *)
26
-
let push_tag_output = 0
27
-
let push_tag_widget_update = 1
28
-
let push_tag_progress = 2
29
-
let push_tag_custom = 3
30
-
31
-
(* CBOR tags for event kinds *)
32
-
let event_tag_widget_event = 0
33
-
let event_tag_custom = 1
34
-
35
-
(* Stream tags *)
36
-
let stream_stdout = 0
37
-
let stream_stderr = 1
38
-
39
-
(* Codecs for push_kind *)
40
-
let push_kind_codec : push_kind Cbort.t =
41
-
let open Cbort in
42
-
let case_output =
43
-
Variant.case push_tag_output
44
-
(tuple2 int string)
45
-
(fun (stream_int, data) ->
46
-
let stream = if stream_int = stream_stdout then `Stdout else `Stderr in
47
-
Output { stream; data })
48
-
(function
49
-
| Output { stream; data } ->
50
-
let stream_int = match stream with `Stdout -> stream_stdout | `Stderr -> stream_stderr in
51
-
Some (stream_int, data)
52
-
| _ -> None)
53
-
in
54
-
let case_widget_update =
55
-
Variant.case push_tag_widget_update
56
-
(tuple2 string Rpc_cbor.codec)
57
-
(fun (widget_id, state) -> Widget_update { widget_id; state })
58
-
(function
59
-
| Widget_update { widget_id; state } -> Some (widget_id, state)
60
-
| _ -> None)
61
-
in
62
-
let case_progress =
63
-
Variant.case push_tag_progress
64
-
(tuple3 string int (nullable string))
65
-
(fun (task_id, percent, message) -> Progress { task_id; percent; message })
66
-
(function
67
-
| Progress { task_id; percent; message } -> Some (task_id, percent, message)
68
-
| _ -> None)
69
-
in
70
-
let case_custom =
71
-
Variant.case push_tag_custom
72
-
(tuple2 string Rpc_cbor.codec)
73
-
(fun (kind, data) -> Custom_push { kind; data })
74
-
(function
75
-
| Custom_push { kind; data } -> Some (kind, data)
76
-
| _ -> None)
77
-
in
78
-
Variant.variant [ case_output; case_widget_update; case_progress; case_custom ]
79
-
80
-
(* Codecs for event_kind *)
81
-
let event_kind_codec : event_kind Cbort.t =
82
-
let open Cbort in
83
-
let case_widget_event =
84
-
Variant.case event_tag_widget_event
85
-
(tuple3 string string Rpc_cbor.codec)
86
-
(fun (widget_id, event_type, data) -> Widget_event { widget_id; event_type; data })
87
-
(function
88
-
| Widget_event { widget_id; event_type; data } -> Some (widget_id, event_type, data)
89
-
| _ -> None)
90
-
in
91
-
let case_custom =
92
-
Variant.case event_tag_custom
93
-
(tuple2 string Rpc_cbor.codec)
94
-
(fun (kind, data) -> Custom_event { kind; data })
95
-
(function
96
-
| Custom_event { kind; data } -> Some (kind, data)
97
-
| _ -> None)
98
-
in
99
-
Variant.variant [ case_widget_event; case_custom ]
100
-
101
-
(* Main message codec *)
102
-
let message_codec : message Cbort.t =
103
-
let open Cbort in
104
-
let case_request =
105
-
Variant.case tag_request
106
-
(tuple2 int64 Rpc_cbor.call_codec)
107
-
(fun (id, call) -> Request { id; call })
108
-
(function
109
-
| Request { id; call } -> Some (id, call)
110
-
| _ -> None)
111
-
in
112
-
let case_response =
113
-
Variant.case tag_response
114
-
(tuple2 int64 Rpc_cbor.response_codec)
115
-
(fun (id, response) -> Response { id; response })
116
-
(function
117
-
| Response { id; response } -> Some (id, response)
118
-
| _ -> None)
119
-
in
120
-
let case_push =
121
-
Variant.case tag_push
122
-
push_kind_codec
123
-
(fun kind -> Push kind)
124
-
(function
125
-
| Push kind -> Some kind
126
-
| _ -> None)
127
-
in
128
-
let case_event =
129
-
Variant.case tag_event
130
-
event_kind_codec
131
-
(fun kind -> Event kind)
132
-
(function
133
-
| Event kind -> Some kind
134
-
| _ -> None)
135
-
in
136
-
Variant.variant [ case_request; case_response; case_push; case_event ]
137
-
138
-
let encode msg = Cbort.encode_string message_codec msg
139
-
140
-
let decode s =
141
-
match Cbort.decode_string message_codec s with
142
-
| Ok msg -> Ok msg
143
-
| Error e -> Error (Cbort.Error.to_string e)
144
-
145
-
let decode_exn s =
146
-
match decode s with
147
-
| Ok msg -> msg
148
-
| Error e -> failwith e
149
-
150
-
let encode_request id call = encode (Request { id; call })
151
-
152
-
let encode_response id response = encode (Response { id; response })
153
-
154
-
let encode_push kind = encode (Push kind)
155
-
156
-
let encode_event kind = encode (Event kind)
157
-
158
-
let push_stdout data = encode_push (Output { stream = `Stdout; data })
159
-
160
-
let push_stderr data = encode_push (Output { stream = `Stderr; data })
161
-
162
-
let push_widget_update ~widget_id state =
163
-
encode_push (Widget_update { widget_id; state })
164
-
165
-
let push_progress ~task_id ~percent ?message () =
166
-
encode_push (Progress { task_id; percent; message })
-74
idl/channel.mli
-74
idl/channel.mli
···
1
-
(** Bidirectional message channel for worker communication.
2
-
3
-
This module extends the RPC model to support push messages from
4
-
server to client, enabling:
5
-
- Streaming output (stdout/stderr)
6
-
- Widget state updates
7
-
- Progress notifications
8
-
9
-
Message types:
10
-
- Request: client → server (expects response)
11
-
- Response: server → client (matches request ID)
12
-
- Push: server → client (one-way notification)
13
-
- Event: client → server (widget interactions, no response)
14
-
*)
15
-
16
-
(** {1 Message Types} *)
17
-
18
-
type push_kind =
19
-
| Output of { stream : [ `Stdout | `Stderr ]; data : string }
20
-
| Widget_update of { widget_id : string; state : Rpc.t }
21
-
| Progress of { task_id : string; percent : int; message : string option }
22
-
| Custom_push of { kind : string; data : Rpc.t }
23
-
(** Types of push messages from server to client. *)
24
-
25
-
type event_kind =
26
-
| Widget_event of { widget_id : string; event_type : string; data : Rpc.t }
27
-
| Custom_event of { kind : string; data : Rpc.t }
28
-
(** Types of event messages from client to server. *)
29
-
30
-
type message =
31
-
| Request of { id : int64; call : Rpc.call }
32
-
| Response of { id : int64; response : Rpc.response }
33
-
| Push of push_kind
34
-
| Event of event_kind
35
-
(** A message in the channel protocol. *)
36
-
37
-
(** {1 Encoding/Decoding} *)
38
-
39
-
val encode : message -> string
40
-
(** [encode msg] encodes a message to CBOR. *)
41
-
42
-
val decode : string -> (message, string) result
43
-
(** [decode s] decodes a CBOR message. *)
44
-
45
-
val decode_exn : string -> message
46
-
(** [decode_exn s] decodes a CBOR message, raising on error. *)
47
-
48
-
(** {1 Convenience Functions} *)
49
-
50
-
val encode_request : int64 -> Rpc.call -> string
51
-
(** [encode_request id call] encodes an RPC request. *)
52
-
53
-
val encode_response : int64 -> Rpc.response -> string
54
-
(** [encode_response id response] encodes an RPC response. *)
55
-
56
-
val encode_push : push_kind -> string
57
-
(** [encode_push kind] encodes a push notification. *)
58
-
59
-
val encode_event : event_kind -> string
60
-
(** [encode_event kind] encodes a client event. *)
61
-
62
-
(** {1 Push Message Helpers} *)
63
-
64
-
val push_stdout : string -> string
65
-
(** [push_stdout data] creates an encoded stdout push message. *)
66
-
67
-
val push_stderr : string -> string
68
-
(** [push_stderr data] creates an encoded stderr push message. *)
69
-
70
-
val push_widget_update : widget_id:string -> Rpc.t -> string
71
-
(** [push_widget_update ~widget_id state] creates a widget update message. *)
72
-
73
-
val push_progress : task_id:string -> percent:int -> ?message:string -> unit -> string
74
-
(** [push_progress ~task_id ~percent ?message ()] creates a progress message. *)
+3
-3
idl/dune
+3
-3
idl/dune
···
6
6
7
7
(library
8
8
(name js_top_worker_message)
9
-
(package js_top_worker-rpc)
9
+
(public_name js_top_worker-rpc.message)
10
10
(modules message)
11
11
(libraries js_of_ocaml)
12
12
(preprocess
···
30
30
31
31
(library
32
32
(name js_top_worker_client_msg)
33
-
(package js_top_worker-client)
33
+
(public_name js_top_worker-client.msg)
34
34
(modules js_top_worker_client_msg)
35
-
(libraries js_top_worker_message lwt brr js_of_ocaml)
35
+
(libraries js_top_worker-rpc.message lwt brr js_of_ocaml)
36
36
(preprocess
37
37
(pps js_of_ocaml-ppx)))
38
38
+87
-13
idl/js_top_worker_client_msg.ml
+87
-13
idl/js_top_worker_client_msg.ml
···
7
7
module Brr_message = Brr_io.Message
8
8
module Msg = Js_top_worker_message.Message
9
9
10
+
(** Incremental output from a single phrase *)
11
+
type output_at = {
12
+
cell_id : int;
13
+
loc : int; (** Character position after phrase (pos_cnum) *)
14
+
caml_ppf : string;
15
+
mime_vals : Msg.mime_val list;
16
+
}
17
+
18
+
(** Output result type *)
19
+
type output = {
20
+
cell_id : int;
21
+
stdout : string;
22
+
stderr : string;
23
+
caml_ppf : string;
24
+
mime_vals : Msg.mime_val list;
25
+
}
26
+
27
+
(** Eval stream event *)
28
+
type eval_event =
29
+
| Phrase of output_at (** Incremental output after each phrase *)
30
+
| Done of output (** Final result *)
31
+
| Error of string (** Error occurred *)
32
+
10
33
(** Client state *)
11
34
type t = {
12
35
worker : Brr_worker.t;
···
16
39
ready_waiters : (unit -> unit) Queue.t;
17
40
pending : (int, Msg.worker_msg Lwt.u) Hashtbl.t;
18
41
pending_env : (string, Msg.worker_msg Lwt.u) Hashtbl.t;
42
+
pending_stream : (int, eval_event option -> unit) Hashtbl.t;
19
43
}
20
44
21
45
exception Timeout
···
98
122
Msg.EnvCreated { env_id = get_string "env_id" }
99
123
| "env_destroyed" ->
100
124
Msg.EnvDestroyed { env_id = get_string "env_id" }
125
+
| "output_at" ->
126
+
let mime_vals_arr = Js.to_array (Js.Unsafe.get obj (Js.string "mime_vals")) in
127
+
let mime_vals = Array.to_list (Array.map (fun mv ->
128
+
{ Msg.mime_type = Js.to_string (Js.Unsafe.get mv (Js.string "mime_type"));
129
+
data = Js.to_string (Js.Unsafe.get mv (Js.string "data")) }
130
+
) mime_vals_arr) in
131
+
Msg.OutputAt {
132
+
cell_id = get_int "cell_id";
133
+
loc = get_int "loc";
134
+
caml_ppf = get_string "caml_ppf";
135
+
mime_vals;
136
+
}
101
137
| _ -> failwith ("Unknown message type: " ^ typ)
102
138
103
139
(** Handle incoming message from worker *)
···
113
149
t.ready <- true;
114
150
Queue.iter (fun f -> f ()) t.ready_waiters;
115
151
Queue.clear t.ready_waiters
116
-
| Msg.Output { cell_id; _ } | Msg.Completions { cell_id; _ }
117
-
| Msg.Types { cell_id; _ } | Msg.ErrorList { cell_id; _ }
118
-
| Msg.EvalError { cell_id; _ } ->
152
+
| Msg.OutputAt { cell_id; loc; caml_ppf; mime_vals } ->
153
+
(match Hashtbl.find_opt t.pending_stream cell_id with
154
+
| Some push -> push (Some (Phrase { cell_id; loc; caml_ppf; mime_vals }))
155
+
| None -> ())
156
+
| Msg.Output { cell_id; stdout; stderr; caml_ppf; mime_vals } ->
157
+
(* Handle streaming eval *)
158
+
(match Hashtbl.find_opt t.pending_stream cell_id with
159
+
| Some push ->
160
+
Hashtbl.remove t.pending_stream cell_id;
161
+
push (Some (Done { cell_id; stdout; stderr; caml_ppf; mime_vals }));
162
+
push None (* Close the stream *)
163
+
| None -> ());
164
+
(* Handle regular eval *)
165
+
(match Hashtbl.find_opt t.pending cell_id with
166
+
| Some resolver ->
167
+
Hashtbl.remove t.pending cell_id;
168
+
Lwt.wakeup resolver parsed
169
+
| None -> ())
170
+
| Msg.EvalError { cell_id; message } ->
171
+
(* Handle streaming eval *)
172
+
(match Hashtbl.find_opt t.pending_stream cell_id with
173
+
| Some push ->
174
+
Hashtbl.remove t.pending_stream cell_id;
175
+
push (Some (Error message));
176
+
push None (* Close the stream *)
177
+
| None -> ());
178
+
(* Handle regular eval *)
179
+
(match Hashtbl.find_opt t.pending cell_id with
180
+
| Some resolver ->
181
+
Hashtbl.remove t.pending cell_id;
182
+
Lwt.wakeup resolver parsed
183
+
| None -> ())
184
+
| Msg.Completions { cell_id; _ }
185
+
| Msg.Types { cell_id; _ } | Msg.ErrorList { cell_id; _ } ->
119
186
(match Hashtbl.find_opt t.pending cell_id with
120
187
| Some resolver ->
121
188
Hashtbl.remove t.pending cell_id;
···
128
195
Lwt.wakeup resolver parsed
129
196
| None -> ())
130
197
131
-
(** Create a new worker client *)
198
+
(** Create a new worker client.
199
+
@param timeout Timeout in milliseconds (default: 30000) *)
132
200
let create ?(timeout = 30000) url =
133
201
let worker = Brr_worker.create (Jstr.v url) in
134
202
let t = {
···
139
207
ready_waiters = Queue.create ();
140
208
pending = Hashtbl.create 16;
141
209
pending_env = Hashtbl.create 16;
210
+
pending_stream = Hashtbl.create 16;
142
211
} in
143
212
let _listener =
144
213
Brr.Ev.listen Brr_message.Ev.message (handle_message t) (Brr_worker.as_target worker)
···
226
295
wait_ready t >>= fun () ->
227
296
Lwt.return_unit
228
297
229
-
(** Output result type *)
230
-
type output = {
231
-
cell_id : int;
232
-
stdout : string;
233
-
stderr : string;
234
-
caml_ppf : string;
235
-
mime_vals : Msg.mime_val list;
236
-
}
237
-
238
298
(** Evaluate OCaml code *)
239
299
let eval t ?(env_id = "default") code =
240
300
let open Lwt.Infix in
···
250
310
| Msg.EvalError { message; _ } ->
251
311
Lwt.fail (EvalError message)
252
312
| _ -> Lwt.fail (Failure "Unexpected response")
313
+
314
+
(** Evaluate OCaml code with streaming output.
315
+
Returns a stream of events: [Phrase] for each phrase as it executes,
316
+
then [Done] with the final result, or [Error] if evaluation fails. *)
317
+
let eval_stream t ?(env_id = "default") code =
318
+
let stream, push = Lwt_stream.create () in
319
+
(* Wait for ready before sending, but return stream immediately *)
320
+
Lwt.async (fun () ->
321
+
let open Lwt.Infix in
322
+
wait_ready t >|= fun () ->
323
+
let cell_id = next_cell_id t in
324
+
Hashtbl.add t.pending_stream cell_id push;
325
+
send t (`Eval (cell_id, env_id, code)));
326
+
stream
253
327
254
328
(** Get completions *)
255
329
let complete t ?(env_id = "default") source position =
+26
-3
idl/message.ml
+26
-3
idl/message.ml
···
80
80
caml_ppf : string;
81
81
mime_vals : mime_val list;
82
82
}
83
+
| OutputAt of {
84
+
cell_id : int;
85
+
loc : int; (* pos_cnum - character position after phrase *)
86
+
caml_ppf : string;
87
+
mime_vals : mime_val list;
88
+
}
83
89
| Completions of { cell_id : int; completions : completions }
84
90
| Types of { cell_id : int; types : type_info list }
85
91
| ErrorList of { cell_id : int; errors : error list }
···
106
112
Js.Unsafe.get obj (Js.string key)
107
113
108
114
let get_string_opt obj key =
109
-
let v : Js.js_string Js.t Js.Optdef.t = Js.Unsafe.get obj (Js.string key) in
110
-
Js.Optdef.to_option v |> Option.map Js.to_string
115
+
let v = Js.Unsafe.get obj (Js.string key) in
116
+
(* Handle both null and undefined *)
117
+
if Js.Opt.test v then
118
+
Some (Js.to_string v)
119
+
else
120
+
None
111
121
112
122
let get_array obj key =
113
-
Js.to_array (Js.Unsafe.get obj (Js.string key))
123
+
let v = Js.Unsafe.get obj (Js.string key) in
124
+
(* Use Js.Opt.test to check if the value is not null *)
125
+
if Js.Opt.test v then
126
+
Js.to_array v
127
+
else
128
+
[||]
114
129
115
130
let get_string_array obj key =
116
131
Array.to_list (Array.map Js.to_string (get_array obj key))
···
183
198
("cell_id", json_int cell_id);
184
199
("stdout", json_string stdout);
185
200
("stderr", json_string stderr);
201
+
("caml_ppf", json_string caml_ppf);
202
+
("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
203
+
]
204
+
| OutputAt { cell_id; loc; caml_ppf; mime_vals } ->
205
+
json_of_obj [
206
+
("type", json_string "output_at");
207
+
("cell_id", json_int cell_id);
208
+
("loc", json_int loc);
186
209
("caml_ppf", json_string caml_ppf);
187
210
("mime_vals", json_array (List.map (fun mv -> Js.Unsafe.inject (json_of_mime_val mv)) mime_vals));
188
211
]
-185
idl/rpc_cbor.ml
-185
idl/rpc_cbor.ml
···
1
-
(** CBOR encoding for Rpc.t values. *)
2
-
3
-
(** We use tagged encoding to distinguish Rpc.t variants in CBOR:
4
-
- Tag 0: Int (int64)
5
-
- Tag 1: Int32
6
-
- Tag 2: Bool
7
-
- Tag 3: Float
8
-
- Tag 4: String
9
-
- Tag 5: DateTime
10
-
- Tag 6: Enum (array)
11
-
- Tag 7: Dict (map)
12
-
- Tag 8: Base64 (bytes)
13
-
- Null: CBOR null (no tag needed)
14
-
*)
15
-
16
-
let codec : Rpc.t Cbort.t =
17
-
let open Cbort in
18
-
fix @@ fun self ->
19
-
let case_int =
20
-
Variant.case 0 int64
21
-
(fun i -> Rpc.Int i)
22
-
(function Rpc.Int i -> Some i | _ -> None)
23
-
in
24
-
let case_int32 =
25
-
Variant.case 1 int32
26
-
(fun i -> Rpc.Int32 i)
27
-
(function Rpc.Int32 i -> Some i | _ -> None)
28
-
in
29
-
let case_bool =
30
-
Variant.case 2 bool
31
-
(fun b -> Rpc.Bool b)
32
-
(function Rpc.Bool b -> Some b | _ -> None)
33
-
in
34
-
let case_float =
35
-
Variant.case 3 float
36
-
(fun f -> Rpc.Float f)
37
-
(function Rpc.Float f -> Some f | _ -> None)
38
-
in
39
-
let case_string =
40
-
Variant.case 4 string
41
-
(fun s -> Rpc.String s)
42
-
(function Rpc.String s -> Some s | _ -> None)
43
-
in
44
-
let case_datetime =
45
-
Variant.case 5 string
46
-
(fun s -> Rpc.DateTime s)
47
-
(function Rpc.DateTime s -> Some s | _ -> None)
48
-
in
49
-
let case_enum =
50
-
Variant.case 6 (array self)
51
-
(fun l -> Rpc.Enum l)
52
-
(function Rpc.Enum l -> Some l | _ -> None)
53
-
in
54
-
let case_dict =
55
-
Variant.case 7 (string_map self)
56
-
(fun l -> Rpc.Dict l)
57
-
(function Rpc.Dict l -> Some l | _ -> None)
58
-
in
59
-
let case_base64 =
60
-
Variant.case 8 bytes
61
-
(fun s -> Rpc.Base64 s)
62
-
(function Rpc.Base64 s -> Some s | _ -> None)
63
-
in
64
-
let case_null =
65
-
Variant.case0 9 Rpc.Null
66
-
(function Rpc.Null -> true | _ -> false)
67
-
in
68
-
Variant.variant [
69
-
case_int;
70
-
case_int32;
71
-
case_bool;
72
-
case_float;
73
-
case_string;
74
-
case_datetime;
75
-
case_enum;
76
-
case_dict;
77
-
case_base64;
78
-
case_null;
79
-
]
80
-
81
-
let encode v = Cbort.encode_string codec v
82
-
83
-
let decode s = Cbort.decode_string codec s
84
-
85
-
let decode_exn s = Cbort.decode_string_exn codec s
86
-
87
-
(* RPC call codec *)
88
-
let call_codec : Rpc.call Cbort.t =
89
-
let ( let* ) = Cbort.Obj.( let* ) in
90
-
Cbort.Obj.finish
91
-
(let* name =
92
-
Cbort.Obj.mem "name" (fun (c : Rpc.call) -> c.name) Cbort.string
93
-
in
94
-
let* params =
95
-
Cbort.Obj.mem "params" (fun (c : Rpc.call) -> c.params) (Cbort.array codec)
96
-
in
97
-
let* is_notification =
98
-
Cbort.Obj.mem "is_notification" (fun (c : Rpc.call) -> c.is_notification) Cbort.bool
99
-
in
100
-
Cbort.Obj.return { Rpc.name; params; is_notification })
101
-
102
-
let encode_call c = Cbort.encode_string call_codec c
103
-
104
-
let decode_call s = Cbort.decode_string call_codec s
105
-
106
-
(* RPC response codec *)
107
-
let response_codec : Rpc.response Cbort.t =
108
-
let ( let* ) = Cbort.Obj.( let* ) in
109
-
Cbort.Obj.finish
110
-
(let* success =
111
-
Cbort.Obj.mem "success" (fun (r : Rpc.response) -> r.success) Cbort.bool
112
-
in
113
-
let* contents =
114
-
Cbort.Obj.mem "contents" (fun (r : Rpc.response) -> r.contents) codec
115
-
in
116
-
let* is_notification =
117
-
Cbort.Obj.mem "is_notification" (fun (r : Rpc.response) -> r.is_notification) Cbort.bool
118
-
in
119
-
Cbort.Obj.return { Rpc.success; contents; is_notification })
120
-
121
-
let encode_response r = Cbort.encode_string response_codec r
122
-
123
-
let decode_response s = Cbort.decode_string response_codec s
124
-
125
-
(* Message envelope types for protocol-level encoding (includes request ID) *)
126
-
127
-
type request = {
128
-
id : Rpc.t;
129
-
call : Rpc.call;
130
-
}
131
-
132
-
type response_msg = {
133
-
id : Rpc.t;
134
-
response : Rpc.response;
135
-
}
136
-
137
-
(* Request envelope codec *)
138
-
let request_codec : request Cbort.t =
139
-
let ( let* ) = Cbort.Obj.( let* ) in
140
-
Cbort.Obj.finish
141
-
(let* id =
142
-
Cbort.Obj.mem "id" (fun (r : request) -> r.id) codec
143
-
in
144
-
let* call =
145
-
Cbort.Obj.mem "call" (fun (r : request) -> r.call) call_codec
146
-
in
147
-
Cbort.Obj.return { id; call })
148
-
149
-
(* Response envelope codec *)
150
-
let response_msg_codec : response_msg Cbort.t =
151
-
let ( let* ) = Cbort.Obj.( let* ) in
152
-
Cbort.Obj.finish
153
-
(let* id =
154
-
Cbort.Obj.mem "id" (fun (r : response_msg) -> r.id) codec
155
-
in
156
-
let* response =
157
-
Cbort.Obj.mem "response" (fun (r : response_msg) -> r.response) response_codec
158
-
in
159
-
Cbort.Obj.return { id; response })
160
-
161
-
let encode_request r = Cbort.encode_string request_codec r
162
-
163
-
let decode_request s = Cbort.decode_string request_codec s
164
-
165
-
let encode_response_msg r = Cbort.encode_string response_msg_codec r
166
-
167
-
let decode_response_msg s = Cbort.decode_string response_msg_codec s
168
-
169
-
(* Convenience functions matching Jsonrpc API *)
170
-
171
-
let string_of_call ?(id = Rpc.Int 0L) call =
172
-
encode_request { id; call }
173
-
174
-
let id_and_call_of_string s =
175
-
match decode_request s with
176
-
| Ok req -> (req.id, req.call)
177
-
| Error e -> failwith (Cbort.Error.to_string e)
178
-
179
-
let string_of_response ~id response =
180
-
encode_response_msg { id; response }
181
-
182
-
let response_of_string s =
183
-
match decode_response_msg s with
184
-
| Ok msg -> msg.response
185
-
| Error e -> failwith (Cbort.Error.to_string e)
-88
idl/rpc_cbor.mli
-88
idl/rpc_cbor.mli
···
1
-
(** CBOR encoding for Rpc.t values.
2
-
3
-
This module provides encoding and decoding of [Rpc.t] values to/from
4
-
CBOR format, allowing ocaml-rpc to use CBOR as a wire format instead
5
-
of JSON or XML. *)
6
-
7
-
val codec : Rpc.t Cbort.t
8
-
(** Codec for [Rpc.t] values. Can be used with [Cbort.encode_string]
9
-
and [Cbort.decode_string]. *)
10
-
11
-
val encode : Rpc.t -> string
12
-
(** [encode v] encodes an [Rpc.t] value to a CBOR byte string. *)
13
-
14
-
val decode : string -> (Rpc.t, Cbort.Error.t) result
15
-
(** [decode s] decodes a CBOR byte string to an [Rpc.t] value. *)
16
-
17
-
val decode_exn : string -> Rpc.t
18
-
(** [decode_exn s] is like [decode] but raises on error. *)
19
-
20
-
(** {1 RPC Call Encoding}
21
-
22
-
Convenience functions for encoding/decoding RPC calls and responses. *)
23
-
24
-
val call_codec : Rpc.call Cbort.t
25
-
(** Codec for RPC calls. *)
26
-
27
-
val response_codec : Rpc.response Cbort.t
28
-
(** Codec for RPC responses. *)
29
-
30
-
val encode_call : Rpc.call -> string
31
-
(** [encode_call c] encodes an RPC call to CBOR. *)
32
-
33
-
val decode_call : string -> (Rpc.call, Cbort.Error.t) result
34
-
(** [decode_call s] decodes a CBOR byte string to an RPC call. *)
35
-
36
-
val encode_response : Rpc.response -> string
37
-
(** [encode_response r] encodes an RPC response to CBOR. *)
38
-
39
-
val decode_response : string -> (Rpc.response, Cbort.Error.t) result
40
-
(** [decode_response s] decodes a CBOR byte string to an RPC response. *)
41
-
42
-
(** {1 Message Envelope Encoding}
43
-
44
-
These types and functions handle protocol-level encoding that includes
45
-
request IDs for matching requests with responses. *)
46
-
47
-
type request = {
48
-
id : Rpc.t;
49
-
call : Rpc.call;
50
-
}
51
-
(** A request message envelope containing the request ID and call. *)
52
-
53
-
type response_msg = {
54
-
id : Rpc.t;
55
-
response : Rpc.response;
56
-
}
57
-
(** A response message envelope containing the request ID and response. *)
58
-
59
-
val encode_request : request -> string
60
-
(** [encode_request r] encodes a request envelope to CBOR. *)
61
-
62
-
val decode_request : string -> (request, Cbort.Error.t) result
63
-
(** [decode_request s] decodes a CBOR byte string to a request envelope. *)
64
-
65
-
val encode_response_msg : response_msg -> string
66
-
(** [encode_response_msg r] encodes a response envelope to CBOR. *)
67
-
68
-
val decode_response_msg : string -> (response_msg, Cbort.Error.t) result
69
-
(** [decode_response_msg s] decodes a CBOR byte string to a response envelope. *)
70
-
71
-
(** {1 Jsonrpc-compatible API}
72
-
73
-
These functions match the Jsonrpc module's API for easy drop-in replacement. *)
74
-
75
-
val string_of_call : ?id:Rpc.t -> Rpc.call -> string
76
-
(** [string_of_call ~id call] encodes a call with the given ID to CBOR.
77
-
If [id] is not provided, defaults to [Rpc.Int 0L]. *)
78
-
79
-
val id_and_call_of_string : string -> Rpc.t * Rpc.call
80
-
(** [id_and_call_of_string s] decodes a CBOR request and returns the ID and call.
81
-
@raise Failure if decoding fails. *)
82
-
83
-
val string_of_response : id:Rpc.t -> Rpc.response -> string
84
-
(** [string_of_response ~id response] encodes a response with the given ID to CBOR. *)
85
-
86
-
val response_of_string : string -> Rpc.response
87
-
(** [response_of_string s] decodes a CBOR response message and returns the response.
88
-
@raise Failure if decoding fails. *)
+1
-1
lib/dune
+1
-1
lib/dune
+89
lib/impl.ml
+89
lib/impl.ml
···
434
434
mime_vals;
435
435
}
436
436
437
+
(** {3 Incremental Phrase Execution}
438
+
439
+
Executes OCaml phrases incrementally, calling a callback after each
440
+
phrase with its output and location. *)
441
+
442
+
type phrase_output = {
443
+
loc : int;
444
+
caml_ppf : string option;
445
+
mime_vals : Toplevel_api_gen.mime_val list;
446
+
}
447
+
448
+
let execute_in_env_incremental env phrase ~on_phrase_output =
449
+
let code_buff = Buffer.create 100 in
450
+
let res_buff = Buffer.create 100 in
451
+
let pp_code = Format.formatter_of_buffer code_buff in
452
+
let pp_result = Format.formatter_of_buffer res_buff in
453
+
let highlighted = ref None in
454
+
let set_highlight loc =
455
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
456
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
457
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
458
+
in
459
+
Buffer.clear code_buff;
460
+
Buffer.clear res_buff;
461
+
Buffer.clear stderr_buff;
462
+
Buffer.clear stdout_buff;
463
+
let phrase =
464
+
let l = String.length phrase in
465
+
if l >= 2 && String.sub phrase (l - 2) 2 = ";;" then phrase
466
+
else phrase ^ ";;"
467
+
in
468
+
let o, () =
469
+
Environment.with_env env (fun () ->
470
+
S.capture
471
+
(fun () ->
472
+
let lb = Lexing.from_function (refill_lexbuf phrase (ref 0) (Some pp_code)) in
473
+
(try
474
+
while true do
475
+
try
476
+
let phr = !Toploop.parse_toplevel_phrase lb in
477
+
let phr = JsooTopPpx.preprocess_phrase phr in
478
+
ignore (Toploop.execute_phrase true pp_result phr : bool);
479
+
(* Get location from phrase AST *)
480
+
let loc = match phr with
481
+
| Parsetree.Ptop_def ({ pstr_loc; _ } :: _) ->
482
+
pstr_loc.loc_end.pos_cnum
483
+
| Parsetree.Ptop_dir { pdir_loc; _ } ->
484
+
pdir_loc.loc_end.pos_cnum
485
+
| _ -> lb.lex_curr_p.pos_cnum
486
+
in
487
+
(* Flush and get current output *)
488
+
Format.pp_print_flush pp_result ();
489
+
let caml_ppf = buff_opt res_buff in
490
+
let mime_vals = Mime_printer.get () in
491
+
(* Call callback with phrase output *)
492
+
on_phrase_output { loc; caml_ppf; mime_vals };
493
+
(* Clear for next phrase *)
494
+
Buffer.clear res_buff
495
+
with
496
+
| End_of_file -> raise End_of_file
497
+
| x ->
498
+
(match loc x with Some l -> set_highlight l | None -> ());
499
+
Errors.report_error Format.err_formatter x
500
+
done
501
+
with End_of_file -> ());
502
+
flush_all ())
503
+
())
504
+
in
505
+
(* Get any remaining mime_vals (shouldn't be any after last callback) *)
506
+
let mime_vals = Mime_printer.get () in
507
+
Format.pp_print_flush pp_code ();
508
+
Format.pp_print_flush pp_result ();
509
+
Toplevel_api_gen.
510
+
{
511
+
stdout = string_opt o.stdout;
512
+
stderr = string_opt o.stderr;
513
+
sharp_ppf = buff_opt code_buff;
514
+
caml_ppf = buff_opt res_buff;
515
+
highlight = !highlighted;
516
+
mime_vals;
517
+
}
518
+
437
519
(** {3 Dynamic CMI Loading}
438
520
439
521
Handles loading .cmi files on demand for packages that weren't
···
696
778
let env = resolve_env env_id in
697
779
let result = execute_in_env env phrase in
698
780
Logs.info (fun m -> m "execute() done for env_id=%s" env_id);
781
+
IdlM.ErrM.return result
782
+
783
+
let execute_incremental env_id (phrase : string) ~on_phrase_output =
784
+
Logs.info (fun m -> m "execute_incremental() for env_id=%s" env_id);
785
+
let env = resolve_env env_id in
786
+
let result = execute_in_env_incremental env phrase ~on_phrase_output in
787
+
Logs.info (fun m -> m "execute_incremental() done for env_id=%s" env_id);
699
788
IdlM.ErrM.return result
700
789
701
790
(** {3 Merlin Integration}
+14
-1
lib/worker.ml
+14
-1
lib/worker.ml
···
97
97
mime_vals;
98
98
}
99
99
100
+
(** Convert phrase_output to Message.OutputAt *)
101
+
let 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
+
100
112
(** Convert completions to Message.Completions *)
101
113
let completions_of_result cell_id (c : Toplevel_api_gen.completions) =
102
114
let entries = List.map (fun (e : Toplevel_api_gen.query_protocol_compl_entry) ->
···
214
226
215
227
| Msg.Eval { cell_id; env_id; code } ->
216
228
Jslib.log "Eval cell_id=%d env_id=%s" cell_id env_id;
217
-
Rpc_lwt.T.get (M.execute env_id code) >|= fun result ->
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 ->
218
231
(match result with
219
232
| Ok exec_result ->
220
233
send_message (output_of_exec_result cell_id exec_result)
+24
-4
test/cram/directives.t/run.t
+24
-4
test/cram/directives.t/run.t
···
519
519
bytesrw (version: 0.3.0)
520
520
bytesrw.sysrandom (version: 0.3.0)
521
521
bytesrw.unix (version: 0.3.0)
522
+
camlp-streams (version: n/a)
522
523
cbort (version: 2b102ae)
523
524
chrome-trace (version: 1.6.2-12057-g12f9ecb)
524
525
cmdliner (version: 2.1.0)
···
561
562
eio_linux (version: n/a)
562
563
eio_main (version: n/a)
563
564
eio_posix (version: n/a)
565
+
either (version: 1.0.0)
564
566
findlib (version: 1.9.8)
565
567
findlib.dynload (version: 1.9.8)
566
568
findlib.internal (version: 1.9.8)
567
569
findlib.top (version: 1.9.8)
570
+
fix (version: n/a)
568
571
fmt (version: 0.11.0)
569
572
fmt.cli (version: 0.11.0)
570
573
fmt.top (version: 0.11.0)
···
590
593
js_top_worker (version: 0.0.1)
591
594
js_top_worker-bin (version: n/a)
592
595
js_top_worker-client (version: 0.0.1)
593
-
js_top_worker-client.__private__ (version: n/a)
594
-
js_top_worker-client.__private__.js_top_worker_client_msg (version: 0.0.1)
596
+
js_top_worker-client.msg (version: 0.0.1)
595
597
js_top_worker-client_fut (version: 0.0.1)
596
598
js_top_worker-rpc (version: 0.0.1)
597
-
js_top_worker-rpc.__private__ (version: n/a)
598
-
js_top_worker-rpc.__private__.js_top_worker_message (version: 0.0.1)
599
+
js_top_worker-rpc.message (version: 0.0.1)
599
600
js_top_worker-unix (version: n/a)
600
601
js_top_worker-web (version: 0.0.1)
601
602
js_top_worker_rpc_def (version: n/a)
···
649
650
ocaml-compiler-libs.shadow (version: v0.17.0)
650
651
ocaml-compiler-libs.toplevel (version: v0.17.0)
651
652
ocaml-syntax-shims (version: n/a)
653
+
ocaml-version (version: n/a)
652
654
ocaml_intrinsics_kernel (version: v0.17.1)
653
655
ocamlbuild (version: 0.16.1)
654
656
ocamlc-loc (version: 1.6.2-12057-g12f9ecb)
655
657
ocamldoc (version: 5.4.0)
658
+
ocamlformat-lib (version: 0.28.1)
659
+
ocamlformat-lib.format_ (version: 0.28.1)
660
+
ocamlformat-lib.ocaml_common (version: 0.28.1)
661
+
ocamlformat-lib.ocamlformat_stdlib (version: 0.28.1)
662
+
ocamlformat-lib.odoc_parser (version: 0.28.1)
663
+
ocamlformat-lib.parser_extended (version: 0.28.1)
664
+
ocamlformat-lib.parser_shims (version: 0.28.1)
665
+
ocamlformat-lib.parser_standard (version: 0.28.1)
666
+
ocamlformat-lib.stdlib_shims (version: 0.28.1)
656
667
ocamlgraph (version: 2.2.0)
668
+
ocp-indent (version: n/a)
669
+
ocp-indent.dynlink (version: 1.9.0)
670
+
ocp-indent.lexer (version: 1.9.0)
671
+
ocp-indent.lib (version: 1.9.0)
672
+
ocp-indent.utils (version: 1.9.0)
657
673
ocplib-endian (version: n/a)
658
674
ocplib-endian.bigstring (version: n/a)
659
675
opam-core (version: n/a)
···
667
683
ppx_assert (version: v0.17.0)
668
684
ppx_assert.runtime-lib (version: v0.17.0)
669
685
ppx_base (version: v0.17.0)
686
+
ppx_blob (version: 0.9.0)
670
687
ppx_cold (version: v0.17.0)
671
688
ppx_compare (version: v0.17.0)
672
689
ppx_compare.expander (version: v0.17.0)
···
772
789
uri.services (version: 4.4.0)
773
790
uri.services_full (version: 4.4.0)
774
791
uring (version: v2.7.0)
792
+
uucp (version: 17.0.0)
793
+
uuseg (version: 17.0.0)
794
+
uuseg.string (version: 17.0.0)
775
795
uutf (version: 1.0.4)
776
796
xdg (version: 1.6.2-12057-g12f9ecb)
777
797
xmlm (version: 1.4.0)
+59
test/node/dune
+59
test/node/dune
···
356
356
(deps _opam)
357
357
(action
358
358
(diff node_dependency_test.expected node_dependency_test.out)))
359
+
360
+
; Incremental output test executable
361
+
(executable
362
+
(name node_incremental_test)
363
+
(modes byte)
364
+
(modules node_incremental_test)
365
+
(link_flags (-linkall))
366
+
(libraries
367
+
str
368
+
fpath
369
+
js_of_ocaml
370
+
js_top_worker-web
371
+
js_of_ocaml-toplevel
372
+
js_top_worker
373
+
logs
374
+
logs.fmt
375
+
rpclib.core
376
+
rpclib.json
377
+
findlib.top
378
+
js_of_ocaml-lwt
379
+
zarith_stubs_js))
380
+
381
+
(rule
382
+
(targets node_incremental_test.js)
383
+
(action
384
+
(run
385
+
%{bin:js_of_ocaml}
386
+
--toplevel
387
+
--pretty
388
+
--no-cmis
389
+
--effects=cps
390
+
--debuginfo
391
+
--target-env=nodejs
392
+
+toplevel.js
393
+
+dynlink.js
394
+
+bigstringaf/runtime.js
395
+
+zarith_stubs_js/runtime.js
396
+
%{lib:js_top_worker:stubs.js}
397
+
%{dep:node_incremental_test.bc}
398
+
-o
399
+
%{targets})))
400
+
401
+
(rule
402
+
(deps _opam)
403
+
(action
404
+
(with-outputs-to
405
+
node_incremental_test.out
406
+
(run
407
+
node
408
+
--stack-size=2000
409
+
-r
410
+
./%{dep:import_scripts.js}
411
+
%{dep:node_incremental_test.js}))))
412
+
413
+
(rule
414
+
(alias runtest)
415
+
(deps _opam)
416
+
(action
417
+
(diff node_incremental_test.expected node_incremental_test.out)))
+190
test/node/node_incremental_test.expected
+190
test/node/node_incremental_test.expected
···
1
+
node_incremental_test.js: [INFO] init()
2
+
Initializing findlib
3
+
node_incremental_test.js: [INFO] async_get: _opam/findlib_index
4
+
Loaded findlib_index findlib_index: 10 META files, 0 universes
5
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/stdlib-shims/META
6
+
Parsed uri: ./lib/stdlib-shims/META
7
+
Reading library: stdlib-shims
8
+
Number of children: 0
9
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/sexplib0/META
10
+
Parsed uri: ./lib/sexplib0/META
11
+
Reading library: sexplib0
12
+
Number of children: 0
13
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppxlib/META
14
+
Parsed uri: ./lib/ppxlib/META
15
+
Reading library: ppxlib
16
+
Number of children: 11
17
+
Found child: __private__
18
+
Reading library: ppxlib.__private__
19
+
Number of children: 1
20
+
Found child: ppx_foo_deriver
21
+
Reading library: ppxlib.__private__.ppx_foo_deriver
22
+
Number of children: 0
23
+
Found child: ast
24
+
Reading library: ppxlib.ast
25
+
Number of children: 0
26
+
Found child: astlib
27
+
Reading library: ppxlib.astlib
28
+
Number of children: 0
29
+
Found child: metaquot
30
+
Reading library: ppxlib.metaquot
31
+
Number of children: 0
32
+
Found child: metaquot_lifters
33
+
Reading library: ppxlib.metaquot_lifters
34
+
Number of children: 0
35
+
Found child: print_diff
36
+
Reading library: ppxlib.print_diff
37
+
Number of children: 0
38
+
Found child: runner
39
+
Reading library: ppxlib.runner
40
+
Number of children: 0
41
+
Found child: runner_as_ppx
42
+
Reading library: ppxlib.runner_as_ppx
43
+
Number of children: 0
44
+
Found child: stdppx
45
+
Reading library: ppxlib.stdppx
46
+
Number of children: 0
47
+
Found child: traverse
48
+
Reading library: ppxlib.traverse
49
+
Number of children: 0
50
+
Found child: traverse_builtins
51
+
Reading library: ppxlib.traverse_builtins
52
+
Number of children: 0
53
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppx_deriving/META
54
+
Parsed uri: ./lib/ppx_deriving/META
55
+
Reading library: ppx_deriving
56
+
Number of children: 12
57
+
Found child: api
58
+
Reading library: ppx_deriving.api
59
+
Number of children: 0
60
+
Found child: create
61
+
Reading library: ppx_deriving.create
62
+
Number of children: 0
63
+
Found child: enum
64
+
Reading library: ppx_deriving.enum
65
+
Number of children: 0
66
+
Found child: eq
67
+
Reading library: ppx_deriving.eq
68
+
Number of children: 0
69
+
Found child: fold
70
+
Reading library: ppx_deriving.fold
71
+
Number of children: 0
72
+
Found child: iter
73
+
Reading library: ppx_deriving.iter
74
+
Number of children: 0
75
+
Found child: make
76
+
Reading library: ppx_deriving.make
77
+
Number of children: 0
78
+
Found child: map
79
+
Reading library: ppx_deriving.map
80
+
Number of children: 0
81
+
Found child: ord
82
+
Reading library: ppx_deriving.ord
83
+
Number of children: 0
84
+
Found child: runtime
85
+
Reading library: ppx_deriving.runtime
86
+
Number of children: 0
87
+
Found child: show
88
+
Reading library: ppx_deriving.show
89
+
Number of children: 0
90
+
Found child: std
91
+
Reading library: ppx_deriving.std
92
+
Number of children: 0
93
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ppx_derivers/META
94
+
Parsed uri: ./lib/ppx_derivers/META
95
+
Reading library: ppx_derivers
96
+
Number of children: 0
97
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml_intrinsics_kernel/META
98
+
Parsed uri: ./lib/ocaml_intrinsics_kernel/META
99
+
Reading library: ocaml_intrinsics_kernel
100
+
Number of children: 0
101
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml/stdlib/META
102
+
Parsed uri: ./lib/ocaml/stdlib/META
103
+
Reading library: stdlib
104
+
Number of children: 0
105
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml/compiler-libs/META
106
+
Parsed uri: ./lib/ocaml/compiler-libs/META
107
+
Reading library: compiler-libs
108
+
Number of children: 5
109
+
Found child: common
110
+
Reading library: compiler-libs.common
111
+
Number of children: 0
112
+
Found child: bytecomp
113
+
Reading library: compiler-libs.bytecomp
114
+
Number of children: 0
115
+
Found child: optcomp
116
+
Reading library: compiler-libs.optcomp
117
+
Number of children: 0
118
+
Found child: toplevel
119
+
Reading library: compiler-libs.toplevel
120
+
Number of children: 0
121
+
Found child: native-toplevel
122
+
Reading library: compiler-libs.native-toplevel
123
+
Number of children: 0
124
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/ocaml-compiler-libs/META
125
+
Parsed uri: ./lib/ocaml-compiler-libs/META
126
+
Reading library: ocaml-compiler-libs
127
+
Number of children: 5
128
+
Found child: bytecomp
129
+
Reading library: ocaml-compiler-libs.bytecomp
130
+
Number of children: 0
131
+
Found child: common
132
+
Reading library: ocaml-compiler-libs.common
133
+
Number of children: 0
134
+
Found child: optcomp
135
+
Reading library: ocaml-compiler-libs.optcomp
136
+
Number of children: 0
137
+
Found child: shadow
138
+
Reading library: ocaml-compiler-libs.shadow
139
+
Number of children: 0
140
+
Found child: toplevel
141
+
Reading library: ocaml-compiler-libs.toplevel
142
+
Number of children: 0
143
+
node_incremental_test.js: [INFO] async_get: _opam/./lib/base/META
144
+
Parsed uri: ./lib/base/META
145
+
Reading library: base
146
+
Number of children: 3
147
+
Found child: base_internalhash_types
148
+
Reading library: base.base_internalhash_types
149
+
Number of children: 0
150
+
Found child: md5
151
+
Reading library: base.md5
152
+
Number of children: 0
153
+
Found child: shadow_stdlib
154
+
Reading library: base.shadow_stdlib
155
+
Number of children: 0
156
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
157
+
node_incremental_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
158
+
node_incremental_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
159
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
160
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
161
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
162
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
163
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
164
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
165
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
166
+
node_incremental_test.js: [INFO] init() finished
167
+
node_incremental_test.js: [INFO] setup() for env default...
168
+
node_incremental_test.js: [INFO] Fetching stdlib__Format.cmi
169
+
170
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Format.cmi
171
+
node_incremental_test.js: [INFO] Fetching stdlib__Sys.cmi
172
+
173
+
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/stdlib__Sys.cmi
174
+
error while evaluating #enable "pretty";;
175
+
error while evaluating #disable "shortvar";;
176
+
node_incremental_test.js: [INFO] Setup complete
177
+
node_incremental_test.js: [INFO] setup() finished for env default
178
+
node_incremental_test.js: [INFO] Setup complete, testing incremental output...
179
+
node_incremental_test.js: [INFO] Evaluating: let x = 1;; let y = 2;; let z = x + y;;
180
+
node_incremental_test.js: [INFO] execute_incremental() for env_id=
181
+
node_incremental_test.js: [INFO] OutputAt: loc=9 caml_ppf=val x : int = 1
182
+
node_incremental_test.js: [INFO] OutputAt: loc=21 caml_ppf=val y : int = 2
183
+
node_incremental_test.js: [INFO] OutputAt: loc=37 caml_ppf=val z : int = 3
184
+
node_incremental_test.js: [INFO] execute_incremental() done for env_id=
185
+
node_incremental_test.js: [INFO] Number of OutputAt callbacks: 3 (expected 3)
186
+
node_incremental_test.js: [INFO] PASS: Got expected number of callbacks
187
+
node_incremental_test.js: [INFO] PASS: Locations are in increasing order: 9, 21, 37
188
+
node_incremental_test.js: [INFO] Final result caml_ppf: <none>
189
+
node_incremental_test.js: [INFO] Final result stdout: <none>
190
+
node_incremental_test.js: [INFO] Test completed successfully
+140
test/node/node_incremental_test.ml
+140
test/node/node_incremental_test.ml
···
1
+
(* Test incremental output *)
2
+
open Js_top_worker
3
+
open Js_top_worker_rpc.Toplevel_api_gen
4
+
open Impl
5
+
6
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
7
+
fun f () ->
8
+
let stdout_buff = Buffer.create 1024 in
9
+
let stderr_buff = Buffer.create 1024 in
10
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
11
+
12
+
let x = f () in
13
+
let captured =
14
+
{
15
+
Impl.stdout = Buffer.contents stdout_buff;
16
+
stderr = Buffer.contents stderr_buff;
17
+
}
18
+
in
19
+
(captured, x)
20
+
21
+
module S : Impl.S = struct
22
+
type findlib_t = Js_top_worker_web.Findlibish.t
23
+
24
+
let capture = capture
25
+
26
+
let sync_get f =
27
+
let f = Fpath.v ("_opam/" ^ f) in
28
+
Logs.info (fun m -> m "sync_get: %a" Fpath.pp f);
29
+
try Some (In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all)
30
+
with e ->
31
+
Logs.err (fun m ->
32
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
33
+
None
34
+
35
+
let async_get f =
36
+
let f = Fpath.v ("_opam/" ^ f) in
37
+
Logs.info (fun m -> m "async_get: %a" Fpath.pp f);
38
+
try
39
+
let content =
40
+
In_channel.with_open_bin (Fpath.to_string f) In_channel.input_all
41
+
in
42
+
Lwt.return (Ok content)
43
+
with e ->
44
+
Logs.err (fun m ->
45
+
m "Error reading file %a: %s" Fpath.pp f (Printexc.to_string e));
46
+
Lwt.return (Error (`Msg (Printexc.to_string e)))
47
+
48
+
let create_file = Js_of_ocaml.Sys_js.create_file
49
+
50
+
let import_scripts urls =
51
+
let open Js_of_ocaml.Js in
52
+
let import_scripts_fn = Unsafe.get Unsafe.global (string "importScripts") in
53
+
List.iter
54
+
(fun url ->
55
+
let (_ : 'a) =
56
+
Unsafe.fun_call import_scripts_fn [| Unsafe.inject (string url) |]
57
+
in
58
+
())
59
+
urls
60
+
61
+
let init_function _ () = failwith "Not implemented"
62
+
let findlib_init = Js_top_worker_web.Findlibish.init async_get
63
+
64
+
let get_stdlib_dcs uri =
65
+
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
66
+
|> Result.to_list
67
+
68
+
let require b v = function
69
+
| [] -> []
70
+
| packages -> Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v packages
71
+
72
+
let path = "/static/cmis"
73
+
end
74
+
75
+
module U = Impl.Make (S)
76
+
77
+
let _ =
78
+
Logs.set_reporter (Logs_fmt.reporter ());
79
+
Logs.set_level (Some Logs.Info);
80
+
81
+
let ( let* ) = IdlM.ErrM.bind in
82
+
83
+
let init_config =
84
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
85
+
in
86
+
87
+
let x =
88
+
let* _ = IdlM.T.lift U.init init_config in
89
+
let* _ = IdlM.T.lift U.setup "" in
90
+
Logs.info (fun m -> m "Setup complete, testing incremental output...");
91
+
92
+
(* Test incremental output with multiple phrases *)
93
+
let phrase_outputs = ref [] in
94
+
let on_phrase_output (p : U.phrase_output) =
95
+
Logs.info (fun m -> m " OutputAt: loc=%d caml_ppf=%s"
96
+
p.loc
97
+
(Option.value ~default:"<none>" p.caml_ppf));
98
+
phrase_outputs := p :: !phrase_outputs
99
+
in
100
+
101
+
let code = "let x = 1;; let y = 2;; let z = x + y;;" in
102
+
Logs.info (fun m -> m "Evaluating: %s" code);
103
+
104
+
let* result = U.execute_incremental "" code ~on_phrase_output in
105
+
106
+
let num_callbacks = List.length !phrase_outputs in
107
+
Logs.info (fun m -> m "Number of OutputAt callbacks: %d (expected 3)" num_callbacks);
108
+
109
+
(* Verify we got 3 callbacks (one per phrase) *)
110
+
if num_callbacks <> 3 then
111
+
Logs.err (fun m -> m "FAIL: Expected 3 callbacks, got %d" num_callbacks)
112
+
else
113
+
Logs.info (fun m -> m "PASS: Got expected number of callbacks");
114
+
115
+
(* Verify the locations are increasing *)
116
+
let locs = List.rev_map (fun (p : U.phrase_output) -> p.loc) !phrase_outputs in
117
+
let sorted = List.sort compare locs in
118
+
if locs = sorted then
119
+
Logs.info (fun m -> m "PASS: Locations are in increasing order: %s"
120
+
(String.concat ", " (List.map string_of_int locs)))
121
+
else
122
+
Logs.err (fun m -> m "FAIL: Locations are not in order");
123
+
124
+
(* Verify final result has expected values *)
125
+
Logs.info (fun m -> m "Final result caml_ppf: %s"
126
+
(Option.value ~default:"<none>" result.caml_ppf));
127
+
Logs.info (fun m -> m "Final result stdout: %s"
128
+
(Option.value ~default:"<none>" result.stdout));
129
+
130
+
IdlM.ErrM.return ()
131
+
in
132
+
133
+
let promise = x |> IdlM.T.get in
134
+
match Lwt.state promise with
135
+
| Lwt.Return (Ok ()) -> Logs.info (fun m -> m "Test completed successfully")
136
+
| Lwt.Return (Error (InternalError s)) -> Logs.err (fun m -> m "Error: %s" s)
137
+
| Lwt.Fail e ->
138
+
Logs.err (fun m -> m "Unexpected failure: %s" (Printexc.to_string e))
139
+
| Lwt.Sleep ->
140
+
Logs.err (fun m -> m "Error: Promise is still pending")