this repo has no description
learno stuff
+592
-52
+2
-1
example/dune
+2
-1
example/dune
+41
example/example2.js
+41
example/example2.js
···
1
+
const worker = new Worker("worker.js")
2
+
3
+
4
+
var promises = new Map()
5
+
var id = 1
6
+
7
+
worker.onmessage = function (e) {
8
+
j = JSON.parse(e.data)
9
+
if (j.id) {
10
+
promise = promises[j.id]
11
+
promises.delete(j.id)
12
+
promise(j.result)
13
+
}
14
+
}
15
+
16
+
function rpc(method, params) {
17
+
const localid = id++;
18
+
return new Promise(function (resolve, reject) {
19
+
worker.postMessage(JSON.stringify({ id:localid, method, params }));
20
+
promises[localid] = resolve
21
+
})
22
+
}
23
+
24
+
function init(cmas,cmi_urls) {
25
+
return rpc("init",[{init_libs:{cmas,cmi_urls}}])
26
+
}
27
+
28
+
function setup() {
29
+
return rpc("setup",[null])
30
+
}
31
+
32
+
function exec(phrase) {
33
+
return rpc("exec",[phrase])
34
+
}
35
+
36
+
function dump(result) {
37
+
console.log(result.stdout)
38
+
}
39
+
40
+
init([],[]).then(() => setup()).then(function(result) { dump(result); exec("let _ = Mime_printer.push \"text/text\" \"hello, world\";;").then((result) => dump(result))})
41
+
+10
example/index2.html
+10
example/index2.html
+1
example/worker.ml
+1
example/worker.ml
+6
-3
idl/dune
+6
-3
idl/dune
···
1
1
(library
2
2
(name js_top_worker_rpc)
3
3
(public_name js_top_worker-rpc)
4
-
(modules idl rpc rpcmarshal toplevel_api_gen)
5
-
(libraries rresult))
4
+
(modules idl rpc rpcmarshal toplevel_api_gen jsonrpc)
5
+
(libraries rresult yojson mime_printer))
6
6
7
7
(library
8
8
(name js_top_worker_client)
9
9
(public_name js_top_worker-client)
10
10
(modules js_top_worker_client)
11
-
(libraries js_top_worker-rpc lwt brr))
11
+
(libraries js_top_worker-rpc lwt brr)
12
+
(preprocess
13
+
(pps js_of_ocaml-ppx)))
12
14
13
15
(library
14
16
(name js_top_worker_rpc_def)
···
16
18
(enabled_if
17
19
(>= %{ocaml_version} 4.12))
18
20
(package js_top_worker_rpc_def)
21
+
(libraries mime_printer)
19
22
(preprocess
20
23
(pps ppx_deriving_rpc)))
21
24
+6
-2
idl/js_top_worker_client.ml
+6
-2
idl/js_top_worker_client.ml
···
20
20
21
21
exception Timeout
22
22
23
+
let log s = Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s)
24
+
23
25
let demux context msg =
24
26
Lwt.async (fun () ->
25
27
match Queue.take_opt context.waiting with
···
27
29
| Some (mv, outstanding_execution) ->
28
30
Brr.G.stop_timer outstanding_execution;
29
31
let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in
30
-
Lwt_mvar.put mv (Ok (Marshal.from_string msg 0)))
32
+
log (Printf.sprintf "Client received: %s" msg);
33
+
Lwt_mvar.put mv (Ok (Jsonrpc.response_of_string msg)))
31
34
32
35
let rpc : context -> Rpc.call -> Rpc.response Lwt.t =
33
36
fun context call ->
34
37
let open Lwt in
35
-
let jv = Marshal.to_bytes call [] in
38
+
let jv = Jsonrpc.string_of_call call in
39
+
log (Printf.sprintf "Client sending: %s" jv);
36
40
let mv = Lwt_mvar.create_empty () in
37
41
let outstanding_execution =
38
42
Brr.G.set_timeout ~ms:context.timeout (fun () ->
+302
idl/jsonrpc.ml
+302
idl/jsonrpc.ml
···
1
+
(*
2
+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3
+
* Copyright (c) 2006-2014 Thomas Gazagnaire <thomas@gazagnaire.org>
4
+
*
5
+
* Permission to use, copy, modify, and distribute this software for any
6
+
* purpose with or without fee is hereby granted, provided that the above
7
+
* copyright notice and this permission notice appear in all copies.
8
+
*
9
+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
+
*)
17
+
18
+
open Rpc
19
+
20
+
module Yojson_private = struct
21
+
include Yojson.Safe
22
+
23
+
let from_string ?(strict = true) ?buf ?fname ?lnum s =
24
+
let open Yojson in
25
+
try
26
+
let lexbuf = Lexing.from_string s in
27
+
let v = init_lexer ?buf ?fname ?lnum () in
28
+
if strict then from_lexbuf v lexbuf else from_lexbuf v ~stream:true lexbuf
29
+
with
30
+
| End_of_input -> json_error "Blank input data"
31
+
end
32
+
33
+
module Y = Yojson_private
34
+
module U = Yojson.Basic.Util
35
+
36
+
type version =
37
+
| V1
38
+
| V2
39
+
40
+
let rec rpc_to_json t =
41
+
match t with
42
+
| Int i -> `Intlit (Int64.to_string i)
43
+
| Int32 i -> `Int (Int32.to_int i)
44
+
| Bool b -> `Bool b
45
+
| Float r -> `Float r
46
+
| String s -> `String s
47
+
| DateTime d -> `String d
48
+
| Base64 b -> `String b
49
+
| Null -> `Null
50
+
| Enum a -> `List (Rpcmarshal.tailrec_map rpc_to_json a)
51
+
| Dict a -> `Assoc (Rpcmarshal.tailrec_map (fun (k, v) -> k, rpc_to_json v) a)
52
+
53
+
54
+
exception JsonToRpcError of Y.t
55
+
56
+
let rec json_to_rpc t =
57
+
match t with
58
+
| `Intlit i -> Int (Int64.of_string i)
59
+
| `Int i -> Int (Int64.of_int i)
60
+
| `Bool b -> Bool b
61
+
| `Float r -> Float r
62
+
| `String s -> (* TODO: check if it is a DateTime *) String s
63
+
(* | DateTime d -> `String d *)
64
+
(* | Base64 b -> `String b *)
65
+
| `Null -> Null
66
+
| `List a -> Enum (Rpcmarshal.tailrec_map json_to_rpc a)
67
+
| `Assoc a -> Dict (Rpcmarshal.tailrec_map (fun (k, v) -> k, json_to_rpc v) a)
68
+
| unsupported -> raise (JsonToRpcError unsupported)
69
+
70
+
71
+
let to_fct t f = rpc_to_json t |> Y.to_string |> f
72
+
let to_buffer t buf = to_fct t (fun s -> Buffer.add_string buf s)
73
+
let to_string t = rpc_to_json t |> Y.to_string
74
+
75
+
let to_a ~empty ~append t =
76
+
let buf = empty () in
77
+
to_fct t (fun s -> append buf s);
78
+
buf
79
+
80
+
81
+
let new_id =
82
+
let count = ref 0L in
83
+
fun () ->
84
+
count := Int64.add 1L !count;
85
+
!count
86
+
87
+
88
+
let string_of_call ?(version = V1) call =
89
+
let json =
90
+
match version with
91
+
| V1 -> [ "method", String call.name; "params", Enum call.params ]
92
+
| V2 ->
93
+
let params =
94
+
match call.params with
95
+
| [ Dict x ] -> Dict x
96
+
| _ -> Enum call.params
97
+
in
98
+
[ "jsonrpc", String "2.0"; "method", String call.name; "params", params ]
99
+
in
100
+
let json =
101
+
if not call.is_notification then json @ [ "id", Int (new_id ()) ] else json
102
+
in
103
+
to_string (Dict json)
104
+
105
+
106
+
let json_of_response ?(id = Int 0L) version response =
107
+
if response.Rpc.success
108
+
then (
109
+
match version with
110
+
| V1 -> Dict [ "result", response.Rpc.contents; "error", Null; "id", id ]
111
+
| V2 -> Dict [ "jsonrpc", String "2.0"; "result", response.Rpc.contents; "id", id ])
112
+
else (
113
+
match version with
114
+
| V1 -> Dict [ "result", Null; "error", response.Rpc.contents; "id", id ]
115
+
| V2 -> Dict [ "jsonrpc", String "2.0"; "error", response.Rpc.contents; "id", id ])
116
+
117
+
118
+
let json_of_error_object ?(data = None) code message =
119
+
let data_json =
120
+
match data with
121
+
| Some d -> [ "data", d ]
122
+
| None -> []
123
+
in
124
+
Dict ([ "code", Int code; "message", String message ] @ data_json)
125
+
126
+
127
+
let string_of_response ?(id = Int 0L) ?(version = V1) response =
128
+
let json = json_of_response ~id version response in
129
+
to_string json
130
+
131
+
132
+
let a_of_response ?(id = Int 0L) ?(version = V1) ~empty ~append response =
133
+
let json = json_of_response ~id version response in
134
+
to_a ~empty ~append json
135
+
136
+
137
+
let of_string ?(strict = true) s = s |> Y.from_string ~strict |> json_to_rpc
138
+
139
+
let of_a ~next_char b =
140
+
let buf = Buffer.create 2048 in
141
+
let rec acc () =
142
+
match next_char b with
143
+
| Some c ->
144
+
Buffer.add_char buf c;
145
+
acc ()
146
+
| None -> ()
147
+
in
148
+
acc ();
149
+
Buffer.contents buf |> of_string
150
+
151
+
152
+
let get' name dict =
153
+
try Some (List.assoc name dict) with
154
+
| Not_found -> None
155
+
156
+
157
+
exception Malformed_method_request of string
158
+
exception Malformed_method_response of string
159
+
exception Missing_field of string
160
+
161
+
let get name dict =
162
+
match get' name dict with
163
+
| None ->
164
+
if Rpc.get_debug () then Printf.eprintf "%s was not found in the dictionary\n" name;
165
+
raise (Missing_field name)
166
+
| Some v -> v
167
+
168
+
169
+
let version_id_and_call_of_string_option str =
170
+
try
171
+
match of_string str with
172
+
| Dict d ->
173
+
let name =
174
+
match get "method" d with
175
+
| String s -> s
176
+
| _ -> raise (Malformed_method_request "Invalid field 'method' in request body")
177
+
in
178
+
let version =
179
+
match get' "jsonrpc" d with
180
+
| None -> V1
181
+
| Some (String "2.0") -> V2
182
+
| _ -> raise (Malformed_method_request "Invalid field 'jsonrpc' in request body")
183
+
in
184
+
let params =
185
+
match version with
186
+
| V1 ->
187
+
(match get "params" d with
188
+
| Enum l -> l
189
+
| _ -> raise (Malformed_method_request "Invalid field 'params' in request body"))
190
+
| V2 ->
191
+
(match get' "params" d with
192
+
| None | Some Null -> []
193
+
| Some (Enum l) -> l
194
+
| Some (Dict l) -> [ Dict l ]
195
+
| _ -> raise (Malformed_method_request "Invalid field 'params' in request body"))
196
+
in
197
+
let id =
198
+
match get' "id" d with
199
+
| None | Some Null -> None (* is a notification *)
200
+
| Some (Int a) -> Some (Int a)
201
+
| Some (String a) -> Some (String a)
202
+
| Some _ -> raise (Malformed_method_request "Invalid field 'id' in request body")
203
+
in
204
+
let c = call name params in
205
+
version, id, { c with is_notification = id == None }
206
+
| _ -> raise (Malformed_method_request "Invalid request body")
207
+
with
208
+
| Missing_field field ->
209
+
raise (Malformed_method_request (Printf.sprintf "Required field %s is missing" field))
210
+
| JsonToRpcError json ->
211
+
raise
212
+
(Malformed_method_request (Printf.sprintf "Unable to parse %s" (Y.to_string json)))
213
+
214
+
215
+
let version_id_and_call_of_string s =
216
+
let version, id_, call = version_id_and_call_of_string_option s in
217
+
match id_ with
218
+
| Some id -> version, id, call
219
+
| None -> raise (Malformed_method_request "Invalid field 'id' in request body")
220
+
221
+
222
+
let call_of_string str =
223
+
let _, _, call = version_id_and_call_of_string str in
224
+
call
225
+
226
+
227
+
(* This functions parses the json and tries to extract a valid jsonrpc response
228
+
* (See http://www.jsonrpc.org/ for the exact specs). *)
229
+
let get_response extractor str =
230
+
try
231
+
match extractor str with
232
+
| Dict d ->
233
+
let _ =
234
+
match get "id" d with
235
+
| Int _ as x -> x
236
+
| String _ as y -> y
237
+
| _ -> raise (Malformed_method_response "id")
238
+
in
239
+
(match get' "jsonrpc" d with
240
+
| None ->
241
+
let result = get "result" d in
242
+
let error = get "error" d in
243
+
(match result, error with
244
+
| v, Null -> success v
245
+
| Null, v -> failure v
246
+
| x, y ->
247
+
raise
248
+
(Malformed_method_response
249
+
(Printf.sprintf
250
+
"<result=%s><error=%s>"
251
+
(Rpc.to_string x)
252
+
(Rpc.to_string y))))
253
+
| Some (String "2.0") ->
254
+
let result = get' "result" d in
255
+
let error = get' "error" d in
256
+
(match result, error with
257
+
| Some v, None -> success v
258
+
| None, Some v ->
259
+
(match v with
260
+
| Dict err ->
261
+
let (_ : int64) =
262
+
match get "code" err with
263
+
| Int i -> i
264
+
| _ -> raise (Malformed_method_response "Error code")
265
+
in
266
+
let _ =
267
+
match get "message" err with
268
+
| String s -> s
269
+
| _ -> raise (Malformed_method_response "Error message")
270
+
in
271
+
failure v
272
+
| _ -> raise (Malformed_method_response "Error object"))
273
+
| Some x, Some y ->
274
+
raise
275
+
(Malformed_method_response
276
+
(Printf.sprintf
277
+
"<result=%s><error=%s>"
278
+
(Rpc.to_string x)
279
+
(Rpc.to_string y)))
280
+
| None, None ->
281
+
raise
282
+
(Malformed_method_response
283
+
(Printf.sprintf "neither <result> nor <error> was found")))
284
+
| _ -> raise (Malformed_method_response "jsonrpc"))
285
+
| rpc ->
286
+
raise
287
+
(Malformed_method_response
288
+
(Printf.sprintf "<response_of_stream(%s)>" (to_string rpc)))
289
+
with
290
+
| Missing_field field ->
291
+
raise (Malformed_method_response (Printf.sprintf "<%s was not found>" field))
292
+
| JsonToRpcError json ->
293
+
raise
294
+
(Malformed_method_response
295
+
(Printf.sprintf "<unable to parse %s>" (Y.to_string json)))
296
+
297
+
298
+
let response_of_string ?(strict = true) str = get_response (of_string ~strict) str
299
+
300
+
let response_of_in_channel channel =
301
+
let of_channel s = s |> Y.from_channel |> json_to_rpc in
302
+
get_response of_channel channel
+9
idl/toplevel_api.ml
+9
idl/toplevel_api.ml
···
6
6
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
7
7
[@@deriving rpcty]
8
8
(** An area to be highlighted *)
9
+
type encoding = Mime_printer.encoding = | Noencoding | Base64 [@@deriving rpcty]
10
+
11
+
type mime_val = Mime_printer.t = {
12
+
mime_type : string;
13
+
encoding : encoding;
14
+
data : string;
15
+
}
16
+
[@@deriving rpcty]
9
17
10
18
type exec_result = {
11
19
stdout : string option;
···
13
21
sharp_ppf : string option;
14
22
caml_ppf : string option;
15
23
highlight : highlight option;
24
+
mime_vals : mime_val list;
16
25
}
17
26
[@@deriving rpcty]
18
27
(** Represents the result of executing a toplevel phrase *)
+203
-43
idl/toplevel_api_gen.ml
+203
-43
idl/toplevel_api_gen.ml
···
26
26
include
27
27
struct
28
28
let _ = fun (_ : highlight) -> ()
29
-
let rec (highlight_line1 : (_, highlight) Rpc.Types.field) =
29
+
let rec highlight_line1 : (_, highlight) Rpc.Types.field =
30
30
{
31
31
Rpc.Types.fname = "line1";
32
32
Rpc.Types.field = (let open Rpc.Types in Basic Int);
···
36
36
Rpc.Types.fget = (fun _r -> _r.line1);
37
37
Rpc.Types.fset = (fun v -> fun _s -> { _s with line1 = v })
38
38
}
39
-
and (highlight_line2 : (_, highlight) Rpc.Types.field) =
39
+
and highlight_line2 : (_, highlight) Rpc.Types.field =
40
40
{
41
41
Rpc.Types.fname = "line2";
42
42
Rpc.Types.field = (let open Rpc.Types in Basic Int);
···
46
46
Rpc.Types.fget = (fun _r -> _r.line2);
47
47
Rpc.Types.fset = (fun v -> fun _s -> { _s with line2 = v })
48
48
}
49
-
and (highlight_col1 : (_, highlight) Rpc.Types.field) =
49
+
and highlight_col1 : (_, highlight) Rpc.Types.field =
50
50
{
51
51
Rpc.Types.fname = "col1";
52
52
Rpc.Types.field = (let open Rpc.Types in Basic Int);
···
56
56
Rpc.Types.fget = (fun _r -> _r.col1);
57
57
Rpc.Types.fset = (fun v -> fun _s -> { _s with col1 = v })
58
58
}
59
-
and (highlight_col2 : (_, highlight) Rpc.Types.field) =
59
+
and highlight_col2 : (_, highlight) Rpc.Types.field =
60
60
{
61
61
Rpc.Types.fname = "col2";
62
62
Rpc.Types.field = (let open Rpc.Types in Basic Int);
···
116
116
and _ = typ_of_highlight
117
117
and _ = highlight
118
118
end[@@ocaml.doc "@inline"][@@merlin.hide ]
119
+
type encoding = Mime_printer.encoding =
120
+
| Noencoding
121
+
| Base64 [@@ocaml.doc " An area to be highlighted "][@@deriving rpcty]
122
+
include
123
+
struct
124
+
let _ = fun (_ : encoding) -> ()
125
+
let rec typ_of_encoding =
126
+
Rpc.Types.Variant
127
+
({
128
+
Rpc.Types.vname = "encoding";
129
+
Rpc.Types.variants =
130
+
[BoxedTag
131
+
{
132
+
Rpc.Types.tname = "Noencoding";
133
+
Rpc.Types.tcontents = Unit;
134
+
Rpc.Types.tversion = None;
135
+
Rpc.Types.tdescription = [];
136
+
Rpc.Types.tpreview =
137
+
((function | Noencoding -> Some () | _ -> None));
138
+
Rpc.Types.treview = ((function | () -> Noencoding))
139
+
};
140
+
BoxedTag
141
+
{
142
+
Rpc.Types.tname = "Base64";
143
+
Rpc.Types.tcontents = Unit;
144
+
Rpc.Types.tversion = None;
145
+
Rpc.Types.tdescription = [];
146
+
Rpc.Types.tpreview =
147
+
((function | Base64 -> Some () | _ -> None));
148
+
Rpc.Types.treview = ((function | () -> Base64))
149
+
}];
150
+
Rpc.Types.vdefault = None;
151
+
Rpc.Types.vversion = None;
152
+
Rpc.Types.vconstructor =
153
+
(fun s' ->
154
+
fun t ->
155
+
let s = String.lowercase_ascii s' in
156
+
match s with
157
+
| "noencoding" ->
158
+
Rresult.R.bind (t.tget Unit)
159
+
(function | () -> Rresult.R.ok Noencoding)
160
+
| "base64" ->
161
+
Rresult.R.bind (t.tget Unit)
162
+
(function | () -> Rresult.R.ok Base64)
163
+
| _ ->
164
+
Rresult.R.error_msg
165
+
(Printf.sprintf "Unknown tag '%s'" s))
166
+
} : encoding Rpc.Types.variant)
167
+
and encoding =
168
+
{
169
+
Rpc.Types.name = "encoding";
170
+
Rpc.Types.description = ["An area to be highlighted"];
171
+
Rpc.Types.ty = typ_of_encoding
172
+
}
173
+
let _ = typ_of_encoding
174
+
and _ = encoding
175
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
176
+
type mime_val = Mime_printer.t =
177
+
{
178
+
mime_type: string ;
179
+
encoding: encoding ;
180
+
data: string }[@@deriving rpcty]
181
+
include
182
+
struct
183
+
let _ = fun (_ : mime_val) -> ()
184
+
let rec mime_val_mime_type : (_, mime_val) Rpc.Types.field =
185
+
{
186
+
Rpc.Types.fname = "mime_type";
187
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
188
+
Rpc.Types.fdefault = None;
189
+
Rpc.Types.fdescription = [];
190
+
Rpc.Types.fversion = None;
191
+
Rpc.Types.fget = (fun _r -> _r.mime_type);
192
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with mime_type = v })
193
+
}
194
+
and mime_val_encoding : (_, mime_val) Rpc.Types.field =
195
+
{
196
+
Rpc.Types.fname = "encoding";
197
+
Rpc.Types.field = typ_of_encoding;
198
+
Rpc.Types.fdefault = None;
199
+
Rpc.Types.fdescription = [];
200
+
Rpc.Types.fversion = None;
201
+
Rpc.Types.fget = (fun _r -> _r.encoding);
202
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with encoding = v })
203
+
}
204
+
and mime_val_data : (_, mime_val) Rpc.Types.field =
205
+
{
206
+
Rpc.Types.fname = "data";
207
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
208
+
Rpc.Types.fdefault = None;
209
+
Rpc.Types.fdescription = [];
210
+
Rpc.Types.fversion = None;
211
+
Rpc.Types.fget = (fun _r -> _r.data);
212
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with data = v })
213
+
}
214
+
and typ_of_mime_val =
215
+
Rpc.Types.Struct
216
+
({
217
+
Rpc.Types.fields =
218
+
[Rpc.Types.BoxedField mime_val_mime_type;
219
+
Rpc.Types.BoxedField mime_val_encoding;
220
+
Rpc.Types.BoxedField mime_val_data];
221
+
Rpc.Types.sname = "mime_val";
222
+
Rpc.Types.version = None;
223
+
Rpc.Types.constructor =
224
+
(fun getter ->
225
+
let open Rresult.R in
226
+
(getter.Rpc.Types.field_get "data"
227
+
(let open Rpc.Types in Basic String))
228
+
>>=
229
+
(fun mime_val_data ->
230
+
(getter.Rpc.Types.field_get "encoding" typ_of_encoding)
231
+
>>=
232
+
(fun mime_val_encoding ->
233
+
(getter.Rpc.Types.field_get "mime_type"
234
+
(let open Rpc.Types in Basic String))
235
+
>>=
236
+
(fun mime_val_mime_type ->
237
+
return
238
+
{
239
+
mime_type = mime_val_mime_type;
240
+
encoding = mime_val_encoding;
241
+
data = mime_val_data
242
+
}))))
243
+
} : mime_val Rpc.Types.structure)
244
+
and mime_val =
245
+
{
246
+
Rpc.Types.name = "mime_val";
247
+
Rpc.Types.description = [];
248
+
Rpc.Types.ty = typ_of_mime_val
249
+
}
250
+
let _ = mime_val_mime_type
251
+
and _ = mime_val_encoding
252
+
and _ = mime_val_data
253
+
and _ = typ_of_mime_val
254
+
and _ = mime_val
255
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
119
256
type exec_result =
120
257
{
121
258
stdout: string option ;
122
259
stderr: string option ;
123
260
sharp_ppf: string option ;
124
261
caml_ppf: string option ;
125
-
highlight: highlight option }[@@deriving rpcty][@@ocaml.doc
126
-
" Represents the result of executing a toplevel phrase "]
262
+
highlight: highlight option ;
263
+
mime_vals: mime_val list }[@@deriving rpcty][@@ocaml.doc
264
+
" Represents the result of executing a toplevel phrase "]
127
265
include
128
266
struct
129
267
let _ = fun (_ : exec_result) -> ()
130
-
let rec (exec_result_stdout : (_, exec_result) Rpc.Types.field) =
268
+
let rec exec_result_stdout : (_, exec_result) Rpc.Types.field =
131
269
{
132
270
Rpc.Types.fname = "stdout";
133
271
Rpc.Types.field =
···
138
276
Rpc.Types.fget = (fun _r -> _r.stdout);
139
277
Rpc.Types.fset = (fun v -> fun _s -> { _s with stdout = v })
140
278
}
141
-
and (exec_result_stderr : (_, exec_result) Rpc.Types.field) =
279
+
and exec_result_stderr : (_, exec_result) Rpc.Types.field =
142
280
{
143
281
Rpc.Types.fname = "stderr";
144
282
Rpc.Types.field =
···
149
287
Rpc.Types.fget = (fun _r -> _r.stderr);
150
288
Rpc.Types.fset = (fun v -> fun _s -> { _s with stderr = v })
151
289
}
152
-
and (exec_result_sharp_ppf : (_, exec_result) Rpc.Types.field) =
290
+
and exec_result_sharp_ppf : (_, exec_result) Rpc.Types.field =
153
291
{
154
292
Rpc.Types.fname = "sharp_ppf";
155
293
Rpc.Types.field =
···
160
298
Rpc.Types.fget = (fun _r -> _r.sharp_ppf);
161
299
Rpc.Types.fset = (fun v -> fun _s -> { _s with sharp_ppf = v })
162
300
}
163
-
and (exec_result_caml_ppf : (_, exec_result) Rpc.Types.field) =
301
+
and exec_result_caml_ppf : (_, exec_result) Rpc.Types.field =
164
302
{
165
303
Rpc.Types.fname = "caml_ppf";
166
304
Rpc.Types.field =
···
171
309
Rpc.Types.fget = (fun _r -> _r.caml_ppf);
172
310
Rpc.Types.fset = (fun v -> fun _s -> { _s with caml_ppf = v })
173
311
}
174
-
and (exec_result_highlight : (_, exec_result) Rpc.Types.field) =
312
+
and exec_result_highlight : (_, exec_result) Rpc.Types.field =
175
313
{
176
314
Rpc.Types.fname = "highlight";
177
315
Rpc.Types.field = (Rpc.Types.Option typ_of_highlight);
···
180
318
Rpc.Types.fversion = None;
181
319
Rpc.Types.fget = (fun _r -> _r.highlight);
182
320
Rpc.Types.fset = (fun v -> fun _s -> { _s with highlight = v })
321
+
}
322
+
and exec_result_mime_vals : (_, exec_result) Rpc.Types.field =
323
+
{
324
+
Rpc.Types.fname = "mime_vals";
325
+
Rpc.Types.field = (Rpc.Types.List typ_of_mime_val);
326
+
Rpc.Types.fdefault = None;
327
+
Rpc.Types.fdescription = [];
328
+
Rpc.Types.fversion = None;
329
+
Rpc.Types.fget = (fun _r -> _r.mime_vals);
330
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with mime_vals = v })
183
331
}
184
332
and typ_of_exec_result =
185
333
Rpc.Types.Struct
···
189
337
Rpc.Types.BoxedField exec_result_stderr;
190
338
Rpc.Types.BoxedField exec_result_sharp_ppf;
191
339
Rpc.Types.BoxedField exec_result_caml_ppf;
192
-
Rpc.Types.BoxedField exec_result_highlight];
340
+
Rpc.Types.BoxedField exec_result_highlight;
341
+
Rpc.Types.BoxedField exec_result_mime_vals];
193
342
Rpc.Types.sname = "exec_result";
194
343
Rpc.Types.version = None;
195
344
Rpc.Types.constructor =
196
345
(fun getter ->
197
346
let open Rresult.R in
198
-
(getter.Rpc.Types.field_get "highlight"
199
-
(Rpc.Types.Option typ_of_highlight))
347
+
(getter.Rpc.Types.field_get "mime_vals"
348
+
(Rpc.Types.List typ_of_mime_val))
200
349
>>=
201
-
(fun exec_result_highlight ->
202
-
(getter.Rpc.Types.field_get "caml_ppf"
203
-
(Rpc.Types.Option
204
-
(let open Rpc.Types in Basic String)))
350
+
(fun exec_result_mime_vals ->
351
+
(getter.Rpc.Types.field_get "highlight"
352
+
(Rpc.Types.Option typ_of_highlight))
205
353
>>=
206
-
(fun exec_result_caml_ppf ->
207
-
(getter.Rpc.Types.field_get "sharp_ppf"
354
+
(fun exec_result_highlight ->
355
+
(getter.Rpc.Types.field_get "caml_ppf"
208
356
(Rpc.Types.Option
209
357
(let open Rpc.Types in Basic String)))
210
358
>>=
211
-
(fun exec_result_sharp_ppf ->
212
-
(getter.Rpc.Types.field_get "stderr"
359
+
(fun exec_result_caml_ppf ->
360
+
(getter.Rpc.Types.field_get "sharp_ppf"
213
361
(Rpc.Types.Option
214
362
(let open Rpc.Types in Basic String)))
215
363
>>=
216
-
(fun exec_result_stderr ->
217
-
(getter.Rpc.Types.field_get "stdout"
364
+
(fun exec_result_sharp_ppf ->
365
+
(getter.Rpc.Types.field_get "stderr"
218
366
(Rpc.Types.Option
219
367
(let open Rpc.Types in
220
368
Basic String)))
221
369
>>=
222
-
(fun exec_result_stdout ->
223
-
return
224
-
{
225
-
stdout = exec_result_stdout;
226
-
stderr = exec_result_stderr;
227
-
sharp_ppf =
228
-
exec_result_sharp_ppf;
229
-
caml_ppf =
230
-
exec_result_caml_ppf;
231
-
highlight =
232
-
exec_result_highlight
233
-
}))))))
370
+
(fun exec_result_stderr ->
371
+
(getter.Rpc.Types.field_get
372
+
"stdout"
373
+
(Rpc.Types.Option
374
+
(let open Rpc.Types in
375
+
Basic String)))
376
+
>>=
377
+
(fun exec_result_stdout ->
378
+
return
379
+
{
380
+
stdout =
381
+
exec_result_stdout;
382
+
stderr =
383
+
exec_result_stderr;
384
+
sharp_ppf =
385
+
exec_result_sharp_ppf;
386
+
caml_ppf =
387
+
exec_result_caml_ppf;
388
+
highlight =
389
+
exec_result_highlight;
390
+
mime_vals =
391
+
exec_result_mime_vals
392
+
})))))))
234
393
} : exec_result Rpc.Types.structure)
235
394
and exec_result =
236
395
{
···
244
403
and _ = exec_result_sharp_ppf
245
404
and _ = exec_result_caml_ppf
246
405
and _ = exec_result_highlight
406
+
and _ = exec_result_mime_vals
247
407
and _ = typ_of_exec_result
248
408
and _ = exec_result
249
409
end[@@ocaml.doc "@inline"][@@merlin.hide ]
···
257
417
include
258
418
struct
259
419
let _ = fun (_ : completion_result) -> ()
260
-
let rec (completion_result_n : (_, completion_result) Rpc.Types.field) =
420
+
let rec completion_result_n : (_, completion_result) Rpc.Types.field =
261
421
{
262
422
Rpc.Types.fname = "n";
263
423
Rpc.Types.field = (let open Rpc.Types in Basic Int);
···
269
429
Rpc.Types.fget = (fun _r -> _r.n);
270
430
Rpc.Types.fset = (fun v -> fun _s -> { _s with n = v })
271
431
}
272
-
and (completion_result_completions :
273
-
(_, completion_result) Rpc.Types.field) =
432
+
and completion_result_completions :
433
+
(_, completion_result) Rpc.Types.field =
274
434
{
275
435
Rpc.Types.fname = "completions";
276
436
Rpc.Types.field =
···
325
485
include
326
486
struct
327
487
let _ = fun (_ : cma) -> ()
328
-
let rec (cma_url : (_, cma) Rpc.Types.field) =
488
+
let rec cma_url : (_, cma) Rpc.Types.field =
329
489
{
330
490
Rpc.Types.fname = "url";
331
491
Rpc.Types.field = (let open Rpc.Types in Basic String);
···
335
495
Rpc.Types.fget = (fun _r -> _r.url);
336
496
Rpc.Types.fset = (fun v -> fun _s -> { _s with url = v })
337
497
}
338
-
and (cma_fn : (_, cma) Rpc.Types.field) =
498
+
and cma_fn : (_, cma) Rpc.Types.field =
339
499
{
340
500
Rpc.Types.fname = "fn";
341
501
Rpc.Types.field = (let open Rpc.Types in Basic String);
···
382
542
include
383
543
struct
384
544
let _ = fun (_ : init_libs) -> ()
385
-
let rec (init_libs_cmi_urls : (_, init_libs) Rpc.Types.field) =
545
+
let rec init_libs_cmi_urls : (_, init_libs) Rpc.Types.field =
386
546
{
387
547
Rpc.Types.fname = "cmi_urls";
388
548
Rpc.Types.field =
···
393
553
Rpc.Types.fget = (fun _r -> _r.cmi_urls);
394
554
Rpc.Types.fset = (fun v -> fun _s -> { _s with cmi_urls = v })
395
555
}
396
-
and (init_libs_cmas : (_, init_libs) Rpc.Types.field) =
556
+
and init_libs_cmas : (_, init_libs) Rpc.Types.field =
397
557
{
398
558
Rpc.Types.fname = "cmas";
399
559
Rpc.Types.field = (Rpc.Types.List typ_of_cma);
+2
-1
lib/dune
+2
-1
lib/dune
+10
-2
lib/worker.cppo.ml
+10
-2
lib/worker.cppo.ml
···
113
113
Buffer.clear stderr_buff;
114
114
Buffer.clear stdout_buff;
115
115
JsooTop.execute true ~pp_code ~highlight_location pp_result phrase;
116
+
let mime_vals = Mime_printer.get () in
116
117
Format.pp_print_flush pp_code ();
117
118
Format.pp_print_flush pp_result ();
118
119
IdlM.ErrM.return
···
123
124
sharp_ppf = buff_opt code_buff;
124
125
caml_ppf = buff_opt res_buff;
125
126
highlight = !highlighted;
127
+
mime_vals;
126
128
}
127
129
128
130
let sync_get url =
···
245
247
sharp_ppf = None;
246
248
caml_ppf = None;
247
249
highlight = None;
250
+
mime_vals = [];
248
251
}
249
252
with e ->
250
253
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))
···
267
270
IdlM.ErrM.return Toplevel_api_gen.{ n; completions }
268
271
269
272
let server process e =
270
-
let call : Rpc.call = Marshal.from_bytes e 0 in
273
+
log "Worker received: %s" e;
274
+
let (_, id, call) = Jsonrpc.version_id_and_call_of_string e in
271
275
M.bind (process call) (fun response ->
272
-
Js_of_ocaml.Worker.post_message (Marshal.to_string response []));
276
+
let rtxt = Jsonrpc.string_of_response ~id response in
277
+
log "Worker sending: %s" rtxt;
278
+
Js_of_ocaml.Worker.post_message rtxt);
273
279
()
274
280
275
281
let loc = function
···
355
361
; sharp_ppf = None
356
362
; caml_ppf = buff_opt res_buff
357
363
; highlight = !highlighted
364
+
; mime_vals = []
358
365
}
359
366
| _ ->
360
367
failwith "Typechecking"
···
369
376
; sharp_ppf = None
370
377
; caml_ppf = buff_opt res_buff
371
378
; highlight = !highlighted
379
+
; mime_vals = []
372
380
}
373
381
374
382
let run () =