jon.recoil.org
this repo has no description
wip
+17
-2
example/dune
+17
-2
example/dune
···
11
11
(modes byte)
12
12
(modules worker)
13
13
(link_flags (-linkall))
14
-
(libraries js_top_worker imagelib base64 tyxml uutf))
14
+
(libraries js_top_worker-web logs.browser))
15
+
16
+
(executable
17
+
(name unix_worker)
18
+
(modes byte)
19
+
(modules unix_worker)
20
+
(link_flags (-linkall))
21
+
(libraries js_top_worker logs logs.fmt rpclib.core))
22
+
23
+
(executable
24
+
(name unix_client)
25
+
(modules unix_client)
26
+
(libraries js_top_worker_client rpclib.cmdliner))
15
27
16
28
(rule
17
29
(targets worker.js)
30
+
(deps stubs.js)
18
31
(action
19
32
(run
20
33
%{bin:js_of_ocaml}
21
34
--toplevel
22
-
--pretty
35
+
; --pretty
36
+
--no-cmis
23
37
+toplevel.js
24
38
+dynlink.js
39
+
stubs.js
25
40
%{dep:worker.bc}
26
41
-o
27
42
%{targets})))
+9
-1
example/example.ml
+9
-1
example/example.ml
···
8
8
let initialise s callback =
9
9
let ( let* ) = Lwt_result.bind in
10
10
let rpc = Js_top_worker_client.start s 100000 callback in
11
-
let* () = W.init rpc Toplevel_api_gen.{ cmas = []; cmi_urls = [] } in
11
+
let* () =
12
+
W.init rpc
13
+
Toplevel_api_gen.
14
+
{
15
+
path = "/static/cmis";
16
+
cmas = [];
17
+
cmis = { dynamic_cmis = None; static_cmis = [] };
18
+
}
19
+
in
12
20
Lwt.return (Ok rpc)
13
21
14
22
let log_output (o : Toplevel_api_gen.exec_result) =
+14
example/stubs.js
+14
example/stubs.js
···
1
+
//Provides: caml_unix_times
2
+
function caml_unix_times() {
3
+
return 4.2
4
+
}
5
+
6
+
//Provides: ml_merlin_fs_exact_case_basename
7
+
function ml_merlin_fs_exact_case_basename(str) {
8
+
return 0
9
+
}
10
+
11
+
//Provides: ml_merlin_fs_exact_case
12
+
function ml_merlin_fs_exact_case(str) {
13
+
return str
14
+
}
+53
example/unix_client.ml
+53
example/unix_client.ml
···
1
+
open Js_top_worker_rpc
2
+
module M = Idl.IdM (* Server is synchronous *)
3
+
module IdlM = Idl.Make (M)
4
+
module Client = Toplevel_api_gen.Make (IdlM.GenClient ())
5
+
module Cmds = Toplevel_api_gen.Make (Cmdlinergen.Gen ())
6
+
7
+
(* Use a binary 16-byte length to frame RPC messages *)
8
+
let binary_rpc path (call : Rpc.call) : Rpc.response =
9
+
let sockaddr = Unix.ADDR_UNIX path in
10
+
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
11
+
Unix.connect s sockaddr;
12
+
let ic = Unix.in_channel_of_descr s in
13
+
let oc = Unix.out_channel_of_descr s in
14
+
let msg_buf = Jsonrpc.string_of_call call in
15
+
let len = Printf.sprintf "%016d" (String.length msg_buf) in
16
+
output_string oc len;
17
+
output_string oc msg_buf;
18
+
flush oc;
19
+
let len_buf = Bytes.make 16 '\000' in
20
+
really_input ic len_buf 0 16;
21
+
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
22
+
let msg_buf = Bytes.make len '\000' in
23
+
really_input ic msg_buf 0 len;
24
+
let (response : Rpc.response) =
25
+
Jsonrpc.response_of_string (Bytes.unsafe_to_string msg_buf)
26
+
in
27
+
response
28
+
(*
29
+
let server_cmd =
30
+
let doc = "Start the server" in
31
+
Cmdliner.(Cmd.v
32
+
(Cmd.info "server" ~doc )
33
+
(Term.(const Example2_server.start_server $ const ())))
34
+
*)
35
+
36
+
let cli () =
37
+
let default =
38
+
Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ()))
39
+
in
40
+
let info = Cmdliner.Cmd.info "cli" ~version:"1.6.1" ~doc:"a cli for an API" in
41
+
let rpc = binary_rpc Toplevel_api_gen.sockpath in
42
+
let cmds =
43
+
(* server_cmd :: *)
44
+
List.map
45
+
(fun t ->
46
+
let term, info = t rpc in
47
+
Cmdliner.(Cmd.v info Term.(term $ const ())))
48
+
(Cmds.implementation ())
49
+
in
50
+
let cmd = Cmdliner.Cmd.group ~default info cmds in
51
+
exit (Cmdliner.Cmd.eval cmd)
52
+
53
+
let () = cli ()
+127
example/unix_worker.ml
+127
example/unix_worker.ml
···
1
+
(* Unix worker *)
2
+
open Js_top_worker
3
+
open Impl
4
+
5
+
let capture f () =
6
+
let stdout_backup = Unix.dup ~cloexec:true Unix.stdout in
7
+
let stderr_backup = Unix.dup ~cloexec:true Unix.stderr in
8
+
let filename_out = Filename.temp_file "ocaml-mdx-" ".stdout" in
9
+
let filename_err = Filename.temp_file "ocaml-mdx-" ".stderr" in
10
+
let fd_out =
11
+
Unix.openfile filename_out
12
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
13
+
0o600
14
+
in
15
+
let fd_err =
16
+
Unix.openfile filename_err
17
+
Unix.[ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ]
18
+
0o600
19
+
in
20
+
Unix.dup2 ~cloexec:false fd_out Unix.stdout;
21
+
Unix.dup2 ~cloexec:false fd_err Unix.stderr;
22
+
let ic_out = open_in filename_out in
23
+
let ic_err = open_in filename_err in
24
+
let capture oc ic fd buf =
25
+
flush oc;
26
+
let len = Unix.lseek fd 0 Unix.SEEK_CUR in
27
+
Buffer.add_channel buf ic len
28
+
in
29
+
Fun.protect
30
+
(fun () ->
31
+
let x = f () in
32
+
let buf_out = Buffer.create 1024 in
33
+
let buf_err = Buffer.create 1024 in
34
+
capture stdout ic_out fd_out buf_out;
35
+
capture stderr ic_err fd_err buf_err;
36
+
( {
37
+
Impl.stdout = Buffer.contents buf_out;
38
+
stderr = Buffer.contents buf_err;
39
+
},
40
+
x ))
41
+
~finally:(fun () ->
42
+
close_in_noerr ic_out;
43
+
close_in_noerr ic_out;
44
+
Unix.close fd_out;
45
+
Unix.close fd_err;
46
+
Unix.dup2 ~cloexec:false stdout_backup Unix.stdout;
47
+
Unix.dup2 ~cloexec:false stderr_backup Unix.stderr;
48
+
Unix.close stdout_backup;
49
+
Unix.close stderr_backup;
50
+
Sys.remove filename_out;
51
+
Sys.remove filename_err)
52
+
53
+
let binary_handler process s =
54
+
let ic = Unix.in_channel_of_descr s in
55
+
let oc = Unix.out_channel_of_descr s in
56
+
(* Read a 16 byte length encoded as a string *)
57
+
let len_buf = Bytes.make 16 '\000' in
58
+
really_input ic len_buf 0 (Bytes.length len_buf);
59
+
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
60
+
let msg_buf = Bytes.make len '\000' in
61
+
really_input ic msg_buf 0 (Bytes.length msg_buf);
62
+
let ( >>= ) = M.bind in
63
+
process msg_buf >>= fun result ->
64
+
let len_buf = Printf.sprintf "%016d" (String.length result) in
65
+
output_string oc len_buf;
66
+
output_string oc result;
67
+
flush oc;
68
+
M.return ()
69
+
70
+
let mkdir_rec dir perm =
71
+
let rec p_mkdir dir =
72
+
let p_name = Filename.dirname dir in
73
+
if p_name <> "/" && p_name <> "." then p_mkdir p_name;
74
+
try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
75
+
in
76
+
p_mkdir dir
77
+
78
+
let serve_requests rpcfn path =
79
+
(try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ());
80
+
mkdir_rec (Filename.dirname path) 0o0755;
81
+
let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
82
+
Unix.bind sock (Unix.ADDR_UNIX path);
83
+
Unix.listen sock 5;
84
+
while true do
85
+
let this_connection, _ = Unix.accept sock in
86
+
Fun.protect
87
+
~finally:(fun () -> Unix.close this_connection)
88
+
(fun () ->
89
+
(* Here I am calling M.run to make sure that I am running the process,
90
+
this is not much of a problem with IdM or ExnM, but in general you
91
+
should ensure that the computation is started by a runner. *)
92
+
binary_handler rpcfn this_connection |> M.run)
93
+
done
94
+
95
+
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
96
+
97
+
module S : Impl.S = struct
98
+
let capture = capture
99
+
let sync_get _ = None
100
+
let create_file ~name:_ ~content:_ = failwith "Not implemented"
101
+
end
102
+
103
+
module U = Impl.Make (S)
104
+
105
+
let start_server () =
106
+
let open U in
107
+
Logs.set_reporter (Logs_fmt.reporter ());
108
+
Logs.set_level (Some Logs.Info);
109
+
let pid = Unix.getpid () in
110
+
Server.exec execute;
111
+
Server.setup setup;
112
+
Server.init init;
113
+
Server.typecheck typecheck_phrase;
114
+
Server.complete_prefix complete_prefix;
115
+
Server.query_errors query_errors;
116
+
Server.type_enclosing type_enclosing;
117
+
Server.compile_js compile_js;
118
+
let rpc_fn = IdlM.server Server.implementation in
119
+
let process x =
120
+
let open M in
121
+
rpc_fn (Jsonrpc.call_of_string (Bytes.unsafe_to_string x))
122
+
>>= fun response -> Jsonrpc.string_of_response response |> return
123
+
in
124
+
serve_requests process
125
+
(Js_top_worker_rpc.Toplevel_api_gen.sockpath ^ string_of_int pid)
126
+
127
+
let _ = start_server ()
+1
-2
example/worker.ml
+1
-2
example/worker.ml
+312
idl/_old/jsonrpc.ml
+312
idl/_old/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 End_of_input -> json_error "Blank input data"
30
+
end
31
+
32
+
module Y = Yojson_private
33
+
module U = Yojson.Basic.Util
34
+
35
+
type version = V1 | V2
36
+
37
+
let rec rpc_to_json t =
38
+
match t with
39
+
| Int i -> `Intlit (Int64.to_string i)
40
+
| Int32 i -> `Int (Int32.to_int i)
41
+
| Bool b -> `Bool b
42
+
| Float r -> `Float r
43
+
| String s -> `String s
44
+
| DateTime d -> `String d
45
+
| Base64 b -> `String b
46
+
| Null -> `Null
47
+
| Enum a -> `List (Rpcmarshal.tailrec_map rpc_to_json a)
48
+
| Dict a ->
49
+
`Assoc (Rpcmarshal.tailrec_map (fun (k, v) -> (k, rpc_to_json v)) a)
50
+
51
+
exception JsonToRpcError of Y.t
52
+
53
+
let rec json_to_rpc t =
54
+
match t with
55
+
| `Intlit i -> Int (Int64.of_string i)
56
+
| `Int i -> Int (Int64.of_int i)
57
+
| `Bool b -> Bool b
58
+
| `Float r -> Float r
59
+
| `String s -> (* TODO: check if it is a DateTime *) String s
60
+
(* | DateTime d -> `String d *)
61
+
(* | Base64 b -> `String b *)
62
+
| `Null -> Null
63
+
| `List a -> Enum (Rpcmarshal.tailrec_map json_to_rpc a)
64
+
| `Assoc a ->
65
+
Dict (Rpcmarshal.tailrec_map (fun (k, v) -> (k, json_to_rpc v)) a)
66
+
| unsupported -> raise (JsonToRpcError unsupported)
67
+
68
+
let to_fct t f = rpc_to_json t |> Y.to_string |> f
69
+
let to_buffer t buf = to_fct t (fun s -> Buffer.add_string buf s)
70
+
let to_string t = rpc_to_json t |> Y.to_string
71
+
72
+
let to_a ~empty ~append t =
73
+
let buf = empty () in
74
+
to_fct t (fun s -> append buf s);
75
+
buf
76
+
77
+
let new_id =
78
+
let count = ref 0L in
79
+
fun () ->
80
+
count := Int64.add 1L !count;
81
+
!count
82
+
83
+
let string_of_call ?(version = V1) call =
84
+
let json =
85
+
match version with
86
+
| V1 -> [ ("method", String call.name); ("params", Enum call.params) ]
87
+
| V2 ->
88
+
let params =
89
+
match call.params with [ Dict x ] -> Dict x | _ -> Enum call.params
90
+
in
91
+
[
92
+
("jsonrpc", String "2.0");
93
+
("method", String call.name);
94
+
("params", params);
95
+
]
96
+
in
97
+
let json =
98
+
if not call.is_notification then json @ [ ("id", Int (new_id ())) ]
99
+
else json
100
+
in
101
+
to_string (Dict json)
102
+
103
+
let json_of_response ?(id = Int 0L) version response =
104
+
if response.Rpc.success then
105
+
match version with
106
+
| V1 ->
107
+
Dict [ ("result", response.Rpc.contents); ("error", Null); ("id", id) ]
108
+
| V2 ->
109
+
Dict
110
+
[
111
+
("jsonrpc", String "2.0");
112
+
("result", response.Rpc.contents);
113
+
("id", id);
114
+
]
115
+
else
116
+
match version with
117
+
| V1 ->
118
+
Dict [ ("result", Null); ("error", response.Rpc.contents); ("id", id) ]
119
+
| V2 ->
120
+
Dict
121
+
[
122
+
("jsonrpc", String "2.0");
123
+
("error", response.Rpc.contents);
124
+
("id", id);
125
+
]
126
+
127
+
let json_of_error_object ?(data = None) code message =
128
+
let data_json = match data with Some d -> [ ("data", d) ] | None -> [] in
129
+
Dict ([ ("code", Int code); ("message", String message) ] @ data_json)
130
+
131
+
let string_of_response ?(id = Int 0L) ?(version = V1) response =
132
+
let json = json_of_response ~id version response in
133
+
to_string json
134
+
135
+
let a_of_response ?(id = Int 0L) ?(version = V1) ~empty ~append response =
136
+
let json = json_of_response ~id version response in
137
+
to_a ~empty ~append json
138
+
139
+
let of_string ?(strict = true) s = s |> Y.from_string ~strict |> json_to_rpc
140
+
141
+
let of_a ~next_char b =
142
+
let buf = Buffer.create 2048 in
143
+
let rec acc () =
144
+
match next_char b with
145
+
| Some c ->
146
+
Buffer.add_char buf c;
147
+
acc ()
148
+
| None -> ()
149
+
in
150
+
acc ();
151
+
Buffer.contents buf |> of_string
152
+
153
+
let get' name dict = try Some (List.assoc name dict) with Not_found -> None
154
+
155
+
exception Malformed_method_request of string
156
+
exception Malformed_method_response of string
157
+
exception Missing_field of string
158
+
159
+
let get name dict =
160
+
match get' name dict with
161
+
| None ->
162
+
if Rpc.get_debug () then
163
+
Printf.eprintf "%s was not found in the dictionary\n" name;
164
+
raise (Missing_field name)
165
+
| Some v -> v
166
+
167
+
let version_id_and_call_of_string_option str =
168
+
try
169
+
match of_string str with
170
+
| Dict d ->
171
+
let name =
172
+
match get "method" d with
173
+
| String s -> s
174
+
| _ ->
175
+
raise
176
+
(Malformed_method_request
177
+
"Invalid field 'method' in request body")
178
+
in
179
+
let version =
180
+
match get' "jsonrpc" d with
181
+
| None -> V1
182
+
| Some (String "2.0") -> V2
183
+
| _ ->
184
+
raise
185
+
(Malformed_method_request
186
+
"Invalid field 'jsonrpc' in request body")
187
+
in
188
+
let params =
189
+
match version with
190
+
| V1 -> (
191
+
match get "params" d with
192
+
| Enum l -> l
193
+
| _ ->
194
+
raise
195
+
(Malformed_method_request
196
+
"Invalid field 'params' in request body"))
197
+
| V2 -> (
198
+
match get' "params" d with
199
+
| None | Some Null -> []
200
+
| Some (Enum l) -> l
201
+
| Some (Dict l) -> [ Dict l ]
202
+
| _ ->
203
+
raise
204
+
(Malformed_method_request
205
+
"Invalid field 'params' in request body"))
206
+
in
207
+
let id =
208
+
match get' "id" d with
209
+
| None | Some Null -> None (* is a notification *)
210
+
| Some (Int a) -> Some (Int a)
211
+
| Some (String a) -> Some (String a)
212
+
| Some _ ->
213
+
raise
214
+
(Malformed_method_request "Invalid field 'id' in request body")
215
+
in
216
+
let c = call name params in
217
+
(version, id, { c with is_notification = id == None })
218
+
| _ -> raise (Malformed_method_request "Invalid request body")
219
+
with
220
+
| Missing_field field ->
221
+
raise
222
+
(Malformed_method_request
223
+
(Printf.sprintf "Required field %s is missing" field))
224
+
| JsonToRpcError json ->
225
+
raise
226
+
(Malformed_method_request
227
+
(Printf.sprintf "Unable to parse %s" (Y.to_string json)))
228
+
229
+
let version_id_and_call_of_string s =
230
+
let version, id_, call = version_id_and_call_of_string_option s in
231
+
match id_ with
232
+
| Some id -> (version, id, call)
233
+
| None ->
234
+
raise (Malformed_method_request "Invalid field 'id' in request body")
235
+
236
+
let call_of_string str =
237
+
let _, _, call = version_id_and_call_of_string str in
238
+
call
239
+
240
+
(* This functions parses the json and tries to extract a valid jsonrpc response
241
+
* (See http://www.jsonrpc.org/ for the exact specs). *)
242
+
let get_response extractor str =
243
+
try
244
+
match extractor str with
245
+
| Dict d -> (
246
+
let _ =
247
+
match get "id" d with
248
+
| Int _ as x -> x
249
+
| String _ as y -> y
250
+
| _ -> raise (Malformed_method_response "id")
251
+
in
252
+
match get' "jsonrpc" d with
253
+
| None -> (
254
+
let result = get "result" d in
255
+
let error = get "error" d in
256
+
match (result, error) with
257
+
| v, Null -> success v
258
+
| Null, v -> failure v
259
+
| x, y ->
260
+
raise
261
+
(Malformed_method_response
262
+
(Printf.sprintf "<result=%s><error=%s>" (Rpc.to_string x)
263
+
(Rpc.to_string y))))
264
+
| Some (String "2.0") -> (
265
+
let result = get' "result" d in
266
+
let error = get' "error" d in
267
+
match (result, error) with
268
+
| Some v, None -> success v
269
+
| None, Some v -> (
270
+
match v with
271
+
| Dict err ->
272
+
let (_ : int64) =
273
+
match get "code" err with
274
+
| Int i -> i
275
+
| _ -> raise (Malformed_method_response "Error code")
276
+
in
277
+
let _ =
278
+
match get "message" err with
279
+
| String s -> s
280
+
| _ -> raise (Malformed_method_response "Error message")
281
+
in
282
+
failure v
283
+
| _ -> raise (Malformed_method_response "Error object"))
284
+
| Some x, Some y ->
285
+
raise
286
+
(Malformed_method_response
287
+
(Printf.sprintf "<result=%s><error=%s>" (Rpc.to_string x)
288
+
(Rpc.to_string y)))
289
+
| None, None ->
290
+
raise
291
+
(Malformed_method_response
292
+
(Printf.sprintf "neither <result> nor <error> was found")))
293
+
| _ -> raise (Malformed_method_response "jsonrpc"))
294
+
| rpc ->
295
+
raise
296
+
(Malformed_method_response
297
+
(Printf.sprintf "<response_of_stream(%s)>" (to_string rpc)))
298
+
with
299
+
| Missing_field field ->
300
+
raise
301
+
(Malformed_method_response (Printf.sprintf "<%s was not found>" field))
302
+
| JsonToRpcError json ->
303
+
raise
304
+
(Malformed_method_response
305
+
(Printf.sprintf "<unable to parse %s>" (Y.to_string json)))
306
+
307
+
let response_of_string ?(strict = true) str =
308
+
get_response (of_string ~strict) str
309
+
310
+
let response_of_in_channel channel =
311
+
let of_channel s = s |> Y.from_channel |> json_to_rpc in
312
+
get_response of_channel channel
+17
-3
idl/dune
+17
-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 jsonrpc)
5
-
(libraries rresult yojson mime_printer))
4
+
(modules toplevel_api_gen)
5
+
(libraries
6
+
rresult
7
+
yojson
8
+
mime_printer
9
+
merlin-lib.query_protocol
10
+
rpclib
11
+
rpclib.json))
6
12
7
13
(library
8
14
(name js_top_worker_client)
···
13
19
(pps js_of_ocaml-ppx)))
14
20
15
21
(library
22
+
(name js_top_worker_client_fut)
23
+
(public_name js_top_worker-client_fut)
24
+
(modules js_top_worker_client_fut)
25
+
(libraries js_top_worker-rpc brr)
26
+
(preprocess
27
+
(pps js_of_ocaml-ppx)))
28
+
29
+
(library
16
30
(name js_top_worker_rpc_def)
17
31
(modules toplevel_api)
18
32
(enabled_if
19
33
(>= %{ocaml_version} 4.12))
20
34
(package js_top_worker_rpc_def)
21
-
(libraries mime_printer)
35
+
(libraries mime_printer merlin-lib.query_protocol)
22
36
(preprocess
23
37
(pps ppx_deriving_rpc)))
24
38
idl/idl.ml
idl/_old/idl.ml
idl/idl.ml
idl/_old/idl.ml
+5
-10
idl/js_top_worker_client.ml
+5
-10
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)
23
+
(* let log s = Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s) *)
24
24
25
25
let demux context msg =
26
26
Lwt.async (fun () ->
···
29
29
| Some (mv, outstanding_execution) ->
30
30
Brr.G.stop_timer outstanding_execution;
31
31
let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in
32
-
log (Printf.sprintf "Client received: %s" msg);
32
+
(* log (Printf.sprintf "Client received: %s" msg); *)
33
33
Lwt_mvar.put mv (Ok (Jsonrpc.response_of_string msg)))
34
34
35
35
let rpc : context -> Rpc.call -> Rpc.response Lwt.t =
36
36
fun context call ->
37
37
let open Lwt in
38
38
let jv = Jsonrpc.string_of_call call in
39
-
log (Printf.sprintf "Client sending: %s" jv);
39
+
(* log (Printf.sprintf "Client sending: %s" jv); *)
40
40
let mv = Lwt_mvar.create_empty () in
41
41
let outstanding_execution =
42
42
Brr.G.set_timeout ~ms:context.timeout (fun () ->
···
68
68
type init_libs = Toplevel_api_gen.init_libs
69
69
type err = Toplevel_api_gen.err
70
70
type exec_result = Toplevel_api_gen.exec_result
71
-
type completion_result = Toplevel_api_gen.completion_result
72
71
73
72
val init :
74
73
rpc ->
···
90
89
string ->
91
90
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
92
91
93
-
val complete :
94
-
rpc ->
95
-
string ->
96
-
(Toplevel_api_gen.completion_result, Toplevel_api_gen.err) result Lwt.t
92
+
val compile_js : rpc -> string -> string -> (string, Toplevel_api_gen.err) result Lwt.t
97
93
end = struct
98
94
type init_libs = Toplevel_api_gen.init_libs
99
95
type err = Toplevel_api_gen.err
100
96
type exec_result = Toplevel_api_gen.exec_result
101
-
type completion_result = Toplevel_api_gen.completion_result
102
97
103
98
let init rpc a = Wraw.init rpc a |> Rpc_lwt.T.get
104
99
let setup rpc a = Wraw.setup rpc a |> Rpc_lwt.T.get
105
100
let typecheck rpc a = Wraw.typecheck rpc a |> Rpc_lwt.T.get
106
101
let exec rpc a = Wraw.exec rpc a |> Rpc_lwt.T.get
107
-
let complete rpc a = Wraw.complete rpc a |> Rpc_lwt.T.get
102
+
let compile_js rpc id s = Wraw.compile_js rpc id s |> Rpc_lwt.T.get
108
103
end
+1
-6
idl/js_top_worker_client.mli
+1
-6
idl/js_top_worker_client.mli
···
27
27
type init_libs = Toplevel_api_gen.init_libs
28
28
type err = Toplevel_api_gen.err
29
29
type exec_result = Toplevel_api_gen.exec_result
30
-
type completion_result = Toplevel_api_gen.completion_result
31
30
32
31
(** {2 RPC calls}
33
32
···
53
52
(** Execute a phrase using the toplevel. The toplevel must have been
54
53
initialised first. *)
55
54
56
-
val complete : rpc -> string -> (completion_result, err) result Lwt.t
57
-
(** Find completions of the incomplete phrase. Completion occurs at the
58
-
end of the phrase passed in. If completion is required at a point
59
-
other than the end of a string, then take the substring before calling
60
-
this API. *)
55
+
val compile_js : rpc -> string -> string -> (string, err) result Lwt.t
61
56
end
+89
idl/js_top_worker_client_fut.ml
+89
idl/js_top_worker_client_fut.ml
···
1
+
(** Worker rpc *)
2
+
3
+
(** Functions to facilitate RPC calls to web workers. *)
4
+
5
+
module Worker = Brr_webworkers.Worker
6
+
open Brr_io
7
+
open Js_top_worker_rpc
8
+
9
+
(** The assumption made in this module is that RPCs are answered in the order
10
+
they are made. *)
11
+
12
+
type context = {
13
+
worker : Worker.t;
14
+
timeout : int;
15
+
timeout_fn : unit -> unit;
16
+
waiting : (((Rpc.response, exn) Result.t -> unit) * int) Queue.t;
17
+
}
18
+
19
+
type rpc = Rpc.call -> Rpc.response Fut.t
20
+
21
+
exception Timeout
22
+
23
+
(* let log s = Js_of_ocaml.Firebug.console##log (Js_of_ocaml.Js.string s) *)
24
+
25
+
let demux context msg =
26
+
match Queue.take_opt context.waiting with
27
+
| None -> ()
28
+
| Some (mv, outstanding_execution) ->
29
+
Brr.G.stop_timer outstanding_execution;
30
+
let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in
31
+
(* log (Printf.sprintf "Client received: %s" msg); *)
32
+
mv (Ok (Jsonrpc.response_of_string msg))
33
+
34
+
let rpc : context -> Rpc.call -> Rpc.response Fut.t =
35
+
fun context call ->
36
+
let open Fut.Syntax in
37
+
let jv = Jsonrpc.string_of_call call in
38
+
(* log (Printf.sprintf "Client sending: %s" jv); *)
39
+
let v, mv = Fut.create () in
40
+
let outstanding_execution =
41
+
Brr.G.set_timeout ~ms:context.timeout (fun () ->
42
+
mv (Error Timeout);
43
+
Worker.terminate context.worker;
44
+
context.timeout_fn ())
45
+
in
46
+
Queue.push (mv, outstanding_execution) context.waiting;
47
+
Worker.post context.worker jv;
48
+
let* r = v in
49
+
match r with
50
+
| Ok jv ->
51
+
let response = jv in
52
+
Fut.return response
53
+
| Error exn -> raise exn
54
+
55
+
let start url timeout timeout_fn : rpc =
56
+
let worker = Worker.create (Jstr.v url) in
57
+
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
58
+
let _listener =
59
+
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
60
+
in
61
+
rpc context
62
+
63
+
module M = struct
64
+
include Fut
65
+
66
+
let fail e = raise e
67
+
end
68
+
69
+
module Rpc_fut = Idl.Make (M)
70
+
module Wraw = Toplevel_api_gen.Make (Rpc_fut.GenClient ())
71
+
72
+
module W = struct
73
+
type init_libs = Toplevel_api_gen.init_libs
74
+
type err = Toplevel_api_gen.err
75
+
type exec_result = Toplevel_api_gen.exec_result
76
+
77
+
let init rpc a = Wraw.init rpc a |> Rpc_fut.T.get
78
+
let setup rpc a = Wraw.setup rpc a |> Rpc_fut.T.get
79
+
let typecheck rpc a = Wraw.typecheck rpc a |> Rpc_fut.T.get
80
+
let exec rpc a = Wraw.exec rpc a |> Rpc_fut.T.get
81
+
let compile_js rpc id s = Wraw.compile_js rpc id s |> Rpc_fut.T.get
82
+
let query_errors rpc doc = Wraw.query_errors rpc doc |> Rpc_fut.T.get
83
+
84
+
let complete_prefix rpc doc pos =
85
+
Wraw.complete_prefix rpc doc pos |> Rpc_fut.T.get
86
+
87
+
let type_enclosing rpc doc pos =
88
+
Wraw.type_enclosing rpc doc pos |> Rpc_fut.T.get
89
+
end
-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
idl/rpc.ml
idl/_old/rpc.ml
idl/rpc.ml
idl/_old/rpc.ml
idl/rpc.mli
idl/_old/rpc.mli
idl/rpc.mli
idl/_old/rpc.mli
idl/rpcmarshal.ml
idl/_old/rpcmarshal.ml
idl/rpcmarshal.ml
idl/_old/rpcmarshal.ml
+577
-18
idl/toplevel_api.ml
+577
-18
idl/toplevel_api.ml
···
3
3
open Rpc
4
4
open Idl
5
5
6
+
let sockpath = "/tmp/js_top_worker.sock"
7
+
8
+
open Merlin_kernel
9
+
module Location = Ocaml_parsing.Location
10
+
11
+
type lexing_position = Lexing.position = {
12
+
pos_fname: string;
13
+
pos_lnum: int;
14
+
pos_bol: int;
15
+
pos_cnum: int;
16
+
} [@@deriving rpcty]
17
+
18
+
type location = Location.t = {
19
+
loc_start: lexing_position;
20
+
loc_end: lexing_position;
21
+
loc_ghost: bool;
22
+
} [@@deriving rpcty]
23
+
24
+
type location_error_source = Location.error_source =
25
+
| Lexer
26
+
| Parser
27
+
| Typer
28
+
| Warning
29
+
| Unknown
30
+
| Env
31
+
| Config [@@deriving rpcty]
32
+
33
+
type location_report_kind = Location.report_kind =
34
+
| Report_error
35
+
| Report_warning of string
36
+
| Report_warning_as_error of string
37
+
| Report_alert of string
38
+
| Report_alert_as_error of string [@@deriving rpcty]
39
+
40
+
type source = string [@@deriving rpcty]
41
+
42
+
(** CMIs are provided either statically or as URLs to be downloaded on demand *)
43
+
44
+
(** Dynamic cmis are loaded from beneath the given url. In addition the
45
+
top-level modules are specified, and prefixes for other modules. For
46
+
example, for the OCaml standard library, a user might pass:
47
+
48
+
{[
49
+
{ dcs_url="/static/stdlib";
50
+
dcs_toplevel_modules=["Stdlib"];
51
+
dcs_file_prefixes=["stdlib__"]; }
52
+
]}
53
+
54
+
In which case, merlin will expect to be able to download a valid file
55
+
from the url ["/static/stdlib/stdlib.cmi"] corresponding to the
56
+
specified toplevel module, and it will also attempt to download any
57
+
module with the prefix ["Stdlib__"] from the same base url, so for
58
+
example if an attempt is made to look up the module ["Stdlib__Foo"]
59
+
then merlin-js will attempt to download a file from the url
60
+
["/static/stdlib/stdlib__Foo.cmi"].
61
+
*)
62
+
63
+
type dynamic_cmis = {
64
+
dcs_url : string;
65
+
dcs_toplevel_modules : string list;
66
+
dcs_file_prefixes : string list;
67
+
}
68
+
69
+
and static_cmi = {
70
+
sc_name : string; (* capitalised, e.g. 'Stdlib' *)
71
+
sc_content : string;
72
+
}
73
+
74
+
and cmis = {
75
+
static_cmis : static_cmi list;
76
+
dynamic_cmis : dynamic_cmis option;
77
+
} [@@deriving rpcty]
78
+
79
+
type action =
80
+
| Complete_prefix of source * Msource.position
81
+
| Type_enclosing of source * Msource.position
82
+
| All_errors of source
83
+
| Add_cmis of cmis
84
+
85
+
type error = {
86
+
kind : location_report_kind;
87
+
loc: location;
88
+
main : string;
89
+
sub : string list;
90
+
source : location_error_source;
91
+
} [@@deriving rpcty]
92
+
93
+
type error_list = error list [@@deriving rpcty]
94
+
95
+
type kind_ty =
96
+
[ `Constructor
97
+
| `Keyword
98
+
| `Label
99
+
| `MethodCall
100
+
| `Modtype
101
+
| `Module
102
+
| `Type
103
+
| `Value
104
+
| `Variant ]
105
+
106
+
include
107
+
struct
108
+
open Rpc.Types
109
+
let _ = fun (_ : kind_ty) -> ()
110
+
let rec typ_of_kind_ty =
111
+
let mk tname tpreview treview =
112
+
BoxedTag
113
+
{
114
+
tname;
115
+
tcontents = Unit;
116
+
tversion = None;
117
+
tdescription = [];
118
+
tpreview;
119
+
treview;
120
+
}
121
+
in
122
+
123
+
Variant
124
+
({
125
+
vname = "kind";
126
+
variants =
127
+
[mk "Constructor" (function | `Constructor -> Some () | _ -> None) (function | () -> `Constructor);
128
+
mk "Keyword" (function | `Keyword -> Some () | _ -> None) (function | () -> `Keyword);
129
+
mk "Label" (function | `Label -> Some () | _ -> None) (function | () -> `Label);
130
+
mk "MethodCall" (function | `MethodCall -> Some () | _ -> None) (function | () -> `MethodCall);
131
+
mk "Modtype" (function | `Modtype -> Some () | _ -> None) (function | () -> `Modtype);
132
+
mk "Module" (function | `Module -> Some () | _ -> None) (function | () -> `Module);
133
+
mk "Type" (function | `Type -> Some () | _ -> None) (function | () -> `Type);
134
+
mk "Value" (function | `Value -> Some () | _ -> None) (function | () -> `Value);
135
+
mk "Variant" (function | `Variant -> Some () | _ -> None) (function | () -> `Variant)];
136
+
vdefault = None;
137
+
vversion = None;
138
+
vconstructor =
139
+
(fun s' ->
140
+
fun t ->
141
+
let s = String.lowercase_ascii s' in
142
+
match s with
143
+
| "constructor" ->
144
+
Rresult.R.bind (t.tget Unit)
145
+
(function | () -> Rresult.R.ok `Constructor)
146
+
| "keyword" ->
147
+
Rresult.R.bind (t.tget Unit)
148
+
(function | () -> Rresult.R.ok `Keyword)
149
+
| "label" ->
150
+
Rresult.R.bind (t.tget Unit)
151
+
(function | () -> Rresult.R.ok `Label)
152
+
| "methodcall" ->
153
+
Rresult.R.bind (t.tget Unit)
154
+
(function | () -> Rresult.R.ok `MethodCall)
155
+
| "modtype" ->
156
+
Rresult.R.bind (t.tget Unit)
157
+
(function | () -> Rresult.R.ok `Modtype)
158
+
| "module" ->
159
+
Rresult.R.bind (t.tget Unit)
160
+
(function | () -> Rresult.R.ok `Module)
161
+
| "type" ->
162
+
Rresult.R.bind (t.tget Unit)
163
+
(function | () -> Rresult.R.ok `Type)
164
+
| "value" ->
165
+
Rresult.R.bind (t.tget Unit)
166
+
(function | () -> Rresult.R.ok `Value)
167
+
| "variant" ->
168
+
Rresult.R.bind (t.tget Unit)
169
+
(function | () -> Rresult.R.ok `Variant)
170
+
| _ ->
171
+
Rresult.R.error_msg
172
+
(Printf.sprintf "Unknown tag '%s'" s))
173
+
} : kind_ty variant)
174
+
and kind_ty =
175
+
{
176
+
name = "kind_ty";
177
+
description = [];
178
+
ty = typ_of_kind_ty
179
+
}
180
+
let _ = typ_of_kind_ty
181
+
and _ = kind_ty
182
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
183
+
184
+
185
+
type query_protocol_compl_entry = Query_protocol.Compl.entry
186
+
include
187
+
struct
188
+
open Rpc.Types
189
+
let _ = fun (_ : query_protocol_compl_entry) -> ()
190
+
let rec query_protocol_compl_entry_name :
191
+
(_, query_protocol_compl_entry) field =
192
+
{
193
+
fname = "name";
194
+
field = typ_of_source;
195
+
fdefault = None;
196
+
fdescription = [];
197
+
fversion = None;
198
+
fget = (fun _r -> _r.name);
199
+
fset = (fun v -> fun _s -> { _s with name = v })
200
+
}
201
+
and query_protocol_compl_entry_kind :
202
+
(_, query_protocol_compl_entry) field =
203
+
{
204
+
fname = "kind";
205
+
field = typ_of_kind_ty;
206
+
fdefault = None;
207
+
fdescription = [];
208
+
fversion = None;
209
+
fget = (fun _r -> _r.kind);
210
+
fset = (fun v -> fun _s -> { _s with kind = v })
211
+
}
212
+
and query_protocol_compl_entry_desc :
213
+
(_, query_protocol_compl_entry) field =
214
+
{
215
+
fname = "desc";
216
+
field = typ_of_source;
217
+
fdefault = None;
218
+
fdescription = [];
219
+
fversion = None;
220
+
fget = (fun _r -> _r.desc);
221
+
fset = (fun v -> fun _s -> { _s with desc = v })
222
+
}
223
+
and query_protocol_compl_entry_info :
224
+
(_, query_protocol_compl_entry) field =
225
+
{
226
+
fname = "info";
227
+
field = typ_of_source;
228
+
fdefault = None;
229
+
fdescription = [];
230
+
fversion = None;
231
+
fget = (fun _r -> _r.info);
232
+
fset = (fun v -> fun _s -> { _s with info = v })
233
+
}
234
+
and query_protocol_compl_entry_deprecated :
235
+
(_, query_protocol_compl_entry) field =
236
+
{
237
+
fname = "deprecated";
238
+
field = (let open Rpc.Types in Basic Bool);
239
+
fdefault = None;
240
+
fdescription = [];
241
+
fversion = None;
242
+
fget = (fun _r -> _r.deprecated);
243
+
fset = (fun v -> fun _s -> { _s with deprecated = v })
244
+
}
245
+
and typ_of_query_protocol_compl_entry =
246
+
Struct
247
+
({
248
+
fields =
249
+
[BoxedField query_protocol_compl_entry_name;
250
+
BoxedField query_protocol_compl_entry_kind;
251
+
BoxedField query_protocol_compl_entry_desc;
252
+
BoxedField query_protocol_compl_entry_info;
253
+
BoxedField query_protocol_compl_entry_deprecated];
254
+
sname = "query_protocol_compl_entry";
255
+
version = None;
256
+
constructor =
257
+
(fun getter ->
258
+
let open Rresult.R in
259
+
(getter.field_get "deprecated"
260
+
(let open Rpc.Types in Basic Bool))
261
+
>>=
262
+
(fun query_protocol_compl_entry_deprecated ->
263
+
(getter.field_get "info" typ_of_source) >>=
264
+
(fun query_protocol_compl_entry_info ->
265
+
(getter.field_get "desc" typ_of_source)
266
+
>>=
267
+
(fun query_protocol_compl_entry_desc ->
268
+
(getter.field_get "kind"
269
+
typ_of_kind_ty)
270
+
>>=
271
+
(fun query_protocol_compl_entry_kind ->
272
+
(getter.field_get "name"
273
+
typ_of_source)
274
+
>>=
275
+
(fun query_protocol_compl_entry_name
276
+
->
277
+
return
278
+
{
279
+
Query_protocol.Compl.name =
280
+
query_protocol_compl_entry_name;
281
+
kind =
282
+
query_protocol_compl_entry_kind;
283
+
desc =
284
+
query_protocol_compl_entry_desc;
285
+
info =
286
+
query_protocol_compl_entry_info;
287
+
deprecated =
288
+
query_protocol_compl_entry_deprecated
289
+
}))))))
290
+
} : query_protocol_compl_entry structure)
291
+
and query_protocol_compl_entry =
292
+
{
293
+
name = "query_protocol_compl_entry";
294
+
description = [];
295
+
ty = typ_of_query_protocol_compl_entry
296
+
}
297
+
let _ = query_protocol_compl_entry_name
298
+
and _ = query_protocol_compl_entry_kind
299
+
and _ = query_protocol_compl_entry_desc
300
+
and _ = query_protocol_compl_entry_info
301
+
and _ = query_protocol_compl_entry_deprecated
302
+
and _ = typ_of_query_protocol_compl_entry
303
+
and _ = query_protocol_compl_entry
304
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
305
+
306
+
307
+
include
308
+
struct
309
+
open Rpc.Types
310
+
let _ = fun (_ : Merlin_kernel.Msource.position) -> ()
311
+
let rec typ_of_msource_position =
312
+
Variant
313
+
({
314
+
vname = "msource_position";
315
+
variants =
316
+
[BoxedTag
317
+
{
318
+
tname = "Start";
319
+
tcontents = Unit;
320
+
tversion = None;
321
+
tdescription = [];
322
+
tpreview =
323
+
((function | `Start -> Some () | _ -> None));
324
+
treview = ((function | () -> `Start))
325
+
};
326
+
BoxedTag
327
+
{
328
+
tname = "Offset";
329
+
tcontents = ((let open Rpc.Types in Basic Int));
330
+
tversion = None;
331
+
tdescription = [];
332
+
tpreview =
333
+
((function | `Offset a0 -> Some a0 | _ -> None));
334
+
treview = ((function | a0 -> `Offset a0))
335
+
};
336
+
BoxedTag
337
+
{
338
+
tname = "Logical";
339
+
tcontents =
340
+
(Tuple
341
+
(((let open Rpc.Types in Basic Int)),
342
+
((let open Rpc.Types in Basic Int))));
343
+
tversion = None;
344
+
tdescription = [];
345
+
tpreview =
346
+
((function | `Logical (a0, a1) -> Some (a0, a1) | _ -> None));
347
+
treview =
348
+
((function | (a0, a1) -> `Logical (a0, a1)))
349
+
};
350
+
BoxedTag
351
+
{
352
+
tname = "End";
353
+
tcontents = Unit;
354
+
tversion = None;
355
+
tdescription = [];
356
+
tpreview =
357
+
((function | `End -> Some () | _ -> None));
358
+
treview = ((function | () -> `End))
359
+
}];
360
+
vdefault = None;
361
+
vversion = None;
362
+
vconstructor =
363
+
(fun s' ->
364
+
fun t ->
365
+
let s = String.lowercase_ascii s' in
366
+
match s with
367
+
| "start" ->
368
+
Rresult.R.bind (t.tget Unit)
369
+
(function | () -> Rresult.R.ok `Start)
370
+
| "offset" ->
371
+
Rresult.R.bind
372
+
(t.tget (let open Rpc.Types in Basic Int))
373
+
(function | a0 -> Rresult.R.ok (`Offset a0))
374
+
| "logical" ->
375
+
Rresult.R.bind
376
+
(t.tget
377
+
(Tuple
378
+
((let open Rpc.Types in Basic Int),
379
+
(let open Rpc.Types in Basic Int))))
380
+
(function
381
+
| (a0, a1) -> Rresult.R.ok (`Logical (a0, a1)))
382
+
| "end" ->
383
+
Rresult.R.bind (t.tget Unit)
384
+
(function | () -> Rresult.R.ok `End)
385
+
| _ ->
386
+
Rresult.R.error_msg
387
+
(Printf.sprintf "Unknown tag '%s'" s))
388
+
} : Merlin_kernel.Msource.position variant)
389
+
and msource_position =
390
+
{
391
+
name = "msource_position";
392
+
description = [];
393
+
ty = typ_of_msource_position
394
+
}
395
+
let _ = typ_of_msource_position
396
+
and _ = msource_position
397
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
398
+
399
+
type completions = {
400
+
from: int;
401
+
to_: int;
402
+
entries : query_protocol_compl_entry list
403
+
} [@@deriving rpcty]
404
+
405
+
type is_tail_position =
406
+
[ `No | `Tail_position | `Tail_call ]
407
+
include
408
+
struct
409
+
open Rpc.Types
410
+
let _ = fun (_ : is_tail_position) -> ()
411
+
let rec typ_of_is_tail_position =
412
+
Variant
413
+
({
414
+
vname = "is_tail_position";
415
+
variants =
416
+
[BoxedTag
417
+
{
418
+
tname = "No";
419
+
tcontents = Unit;
420
+
tversion = None;
421
+
tdescription = [];
422
+
tpreview =
423
+
((function | `No -> Some () | _ -> None));
424
+
treview = ((function | () -> `No))
425
+
};
426
+
BoxedTag
427
+
{
428
+
tname = "Tail_position";
429
+
tcontents = Unit;
430
+
tversion = None;
431
+
tdescription = [];
432
+
tpreview =
433
+
((function | `Tail_position -> Some () | _ -> None));
434
+
treview = ((function | () -> `Tail_position))
435
+
};
436
+
BoxedTag
437
+
{
438
+
tname = "Tail_call";
439
+
tcontents = Unit;
440
+
tversion = None;
441
+
tdescription = [];
442
+
tpreview =
443
+
((function | `Tail_call -> Some () | _ -> None));
444
+
treview = ((function | () -> `Tail_call))
445
+
}];
446
+
vdefault = None;
447
+
vversion = None;
448
+
vconstructor =
449
+
(fun s' ->
450
+
fun t ->
451
+
let s = String.lowercase_ascii s' in
452
+
match s with
453
+
| "no" ->
454
+
Rresult.R.bind (t.tget Unit)
455
+
(function | () -> Rresult.R.ok `No)
456
+
| "tail_position" ->
457
+
Rresult.R.bind (t.tget Unit)
458
+
(function | () -> Rresult.R.ok `Tail_position)
459
+
| "tail_call" ->
460
+
Rresult.R.bind (t.tget Unit)
461
+
(function | () -> Rresult.R.ok `Tail_call)
462
+
| _ ->
463
+
Rresult.R.error_msg
464
+
(Printf.sprintf "Unknown tag '%s'" s))
465
+
} : is_tail_position variant)
466
+
and is_tail_position =
467
+
{
468
+
name = "is_tail_position";
469
+
description = [];
470
+
ty = typ_of_is_tail_position
471
+
}
472
+
let _ = typ_of_is_tail_position
473
+
and _ = is_tail_position
474
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
475
+
476
+
type index_or_string =
477
+
[ `Index of int
478
+
| `String of string ]
479
+
include
480
+
struct
481
+
open Rpc.Types
482
+
let _ = fun (_ : index_or_string) -> ()
483
+
let rec typ_of_index_or_string =
484
+
Variant
485
+
({
486
+
vname = "index_or_string";
487
+
variants =
488
+
[BoxedTag
489
+
{
490
+
tname = "Index";
491
+
tcontents = ((let open Rpc.Types in Basic Int));
492
+
tversion = None;
493
+
tdescription = [];
494
+
tpreview =
495
+
((function | `Index a0 -> Some a0 | _ -> None));
496
+
treview = ((function | a0 -> `Index a0))
497
+
};
498
+
BoxedTag
499
+
{
500
+
tname = "String";
501
+
tcontents = ((let open Rpc.Types in Basic String));
502
+
tversion = None;
503
+
tdescription = [];
504
+
tpreview =
505
+
((function | `String a0 -> Some a0 | _ -> None));
506
+
treview = ((function | a0 -> `String a0))
507
+
}];
508
+
vdefault = None;
509
+
vversion = None;
510
+
vconstructor =
511
+
(fun s' ->
512
+
fun t ->
513
+
let s = String.lowercase_ascii s' in
514
+
match s with
515
+
| "index" ->
516
+
Rresult.R.bind
517
+
(t.tget (let open Rpc.Types in Basic Int))
518
+
(function | a0 -> Rresult.R.ok (`Index a0))
519
+
| "string" ->
520
+
Rresult.R.bind
521
+
(t.tget (let open Rpc.Types in Basic String))
522
+
(function | a0 -> Rresult.R.ok (`String a0))
523
+
| _ ->
524
+
Rresult.R.error_msg
525
+
(Printf.sprintf "Unknown tag '%s'" s))
526
+
} : index_or_string variant)
527
+
and index_or_string =
528
+
{
529
+
name = "index_or_string";
530
+
description = [];
531
+
ty = typ_of_index_or_string
532
+
}
533
+
let _ = typ_of_index_or_string
534
+
and _ = index_or_string
535
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
536
+
537
+
type typed_enclosings = location * index_or_string * is_tail_position [@@deriving rpcty]
538
+
type typed_enclosings_list = typed_enclosings list [@@deriving rpcty]
539
+
let report_source_to_string = function
540
+
| Location.Lexer -> "lexer"
541
+
| Location.Parser -> "parser"
542
+
| Location.Typer -> "typer"
543
+
| Location.Warning -> "warning" (* todo incorrect ?*)
544
+
| Location.Unknown -> "unknown"
545
+
| Location.Env -> "env"
546
+
| Location.Config -> "config"
547
+
6
548
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
7
549
[@@deriving rpcty]
8
550
(** An area to be highlighted *)
···
26
568
[@@deriving rpcty]
27
569
(** Represents the result of executing a toplevel phrase *)
28
570
29
-
type completion_result = {
30
-
n : int;
31
-
(** The position in the input string from where the completions may be
32
-
inserted *)
33
-
completions : string list; (** The list of possible completions *)
34
-
}
35
-
[@@deriving rpcty]
36
-
(** The result returned by a 'complete' call. *)
37
-
38
571
type cma = {
39
572
url : string; (** URL where the cma is available *)
40
573
fn : string; (** Name of the 'wrapping' function *)
41
574
}
42
575
[@@deriving rpcty]
43
576
44
-
type init_libs = { cmi_urls : string list; cmas : cma list } [@@deriving rpcty]
577
+
type init_libs = { path : string; cmis : cmis; cmas : cma list } [@@deriving rpcty]
45
578
type err = InternalError of string [@@deriving rpcty]
46
579
47
580
module E = Idl.Error.Make (struct
···
69
602
let implementation = implement description
70
603
let unit_p = Param.mk Types.unit
71
604
let phrase_p = Param.mk Types.string
605
+
let id_p = Param.mk Types.string
72
606
let typecheck_result_p = Param.mk exec_result
73
607
let exec_result_p = Param.mk exec_result
74
-
let completion_p = Param.mk completion_result
608
+
609
+
let source_p = Param.mk source
610
+
let position_p = Param.mk msource_position
611
+
612
+
let completions_p = Param.mk completions
613
+
let error_list_p = Param.mk error_list
614
+
let typed_enclosings_p = Param.mk typed_enclosings_list
75
615
76
616
let init_libs =
77
617
Param.mk ~name:"init_libs"
···
110
650
]
111
651
(phrase_p @-> returning exec_result_p err)
112
652
113
-
let complete =
114
-
declare "complete"
653
+
let compile_js =
654
+
declare "compile_js"
655
+
[
656
+
"Compile a phrase to javascript. The toplevel must have been";
657
+
"Initialised first.";
658
+
]
659
+
(id_p @-> phrase_p @-> returning phrase_p err)
660
+
661
+
let complete_prefix =
662
+
declare "complete_prefix"
663
+
[
664
+
"Complete a prefix"
665
+
]
666
+
(source_p @-> position_p @-> returning completions_p err)
667
+
668
+
let query_errors =
669
+
declare "query_errors"
115
670
[
116
-
"Find completions of the incomplete phrase. Completion occurs at the";
117
-
"end of the phrase passed in. If completion is required at a point";
118
-
"other than the end of a string, then take the substring before calling";
119
-
"this API.";
671
+
"Query the errors in the given source"
120
672
]
121
-
(phrase_p @-> returning completion_p err)
673
+
(source_p @-> returning error_list_p err)
674
+
675
+
let type_enclosing =
676
+
declare "type_enclosing"
677
+
[
678
+
"Get the type of the enclosing expression"
679
+
]
680
+
(source_p @-> position_p @-> returning typed_enclosings_p err)
122
681
end
+1373
-96
idl/toplevel_api_gen.ml
+1373
-96
idl/toplevel_api_gen.ml
···
18
18
[@@@ocaml.text " IDL for talking to the toplevel webworker "]
19
19
open Rpc
20
20
open Idl
21
+
let sockpath = "/tmp/js_top_worker.sock"
22
+
open Merlin_kernel
23
+
module Location = Ocaml_parsing.Location
24
+
type lexing_position = Lexing.position =
25
+
{
26
+
pos_fname: string ;
27
+
pos_lnum: int ;
28
+
pos_bol: int ;
29
+
pos_cnum: int }[@@deriving rpcty]
30
+
include
31
+
struct
32
+
let _ = fun (_ : lexing_position) -> ()
33
+
let rec lexing_position_pos_fname : (_, lexing_position) Rpc.Types.field
34
+
=
35
+
{
36
+
Rpc.Types.fname = "pos_fname";
37
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
38
+
Rpc.Types.fdefault = None;
39
+
Rpc.Types.fdescription = [];
40
+
Rpc.Types.fversion = None;
41
+
Rpc.Types.fget = (fun _r -> _r.pos_fname);
42
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with pos_fname = v })
43
+
}
44
+
and lexing_position_pos_lnum : (_, lexing_position) Rpc.Types.field =
45
+
{
46
+
Rpc.Types.fname = "pos_lnum";
47
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
48
+
Rpc.Types.fdefault = None;
49
+
Rpc.Types.fdescription = [];
50
+
Rpc.Types.fversion = None;
51
+
Rpc.Types.fget = (fun _r -> _r.pos_lnum);
52
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with pos_lnum = v })
53
+
}
54
+
and lexing_position_pos_bol : (_, lexing_position) Rpc.Types.field =
55
+
{
56
+
Rpc.Types.fname = "pos_bol";
57
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
58
+
Rpc.Types.fdefault = None;
59
+
Rpc.Types.fdescription = [];
60
+
Rpc.Types.fversion = None;
61
+
Rpc.Types.fget = (fun _r -> _r.pos_bol);
62
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with pos_bol = v })
63
+
}
64
+
and lexing_position_pos_cnum : (_, lexing_position) Rpc.Types.field =
65
+
{
66
+
Rpc.Types.fname = "pos_cnum";
67
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
68
+
Rpc.Types.fdefault = None;
69
+
Rpc.Types.fdescription = [];
70
+
Rpc.Types.fversion = None;
71
+
Rpc.Types.fget = (fun _r -> _r.pos_cnum);
72
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with pos_cnum = v })
73
+
}
74
+
and typ_of_lexing_position =
75
+
Rpc.Types.Struct
76
+
({
77
+
Rpc.Types.fields =
78
+
[Rpc.Types.BoxedField lexing_position_pos_fname;
79
+
Rpc.Types.BoxedField lexing_position_pos_lnum;
80
+
Rpc.Types.BoxedField lexing_position_pos_bol;
81
+
Rpc.Types.BoxedField lexing_position_pos_cnum];
82
+
Rpc.Types.sname = "lexing_position";
83
+
Rpc.Types.version = None;
84
+
Rpc.Types.constructor =
85
+
(fun getter ->
86
+
let open Rresult.R in
87
+
(getter.Rpc.Types.field_get "pos_cnum"
88
+
(let open Rpc.Types in Basic Int))
89
+
>>=
90
+
(fun lexing_position_pos_cnum ->
91
+
(getter.Rpc.Types.field_get "pos_bol"
92
+
(let open Rpc.Types in Basic Int))
93
+
>>=
94
+
(fun lexing_position_pos_bol ->
95
+
(getter.Rpc.Types.field_get "pos_lnum"
96
+
(let open Rpc.Types in Basic Int))
97
+
>>=
98
+
(fun lexing_position_pos_lnum ->
99
+
(getter.Rpc.Types.field_get "pos_fname"
100
+
(let open Rpc.Types in Basic String))
101
+
>>=
102
+
(fun lexing_position_pos_fname ->
103
+
return
104
+
{
105
+
pos_fname =
106
+
lexing_position_pos_fname;
107
+
pos_lnum = lexing_position_pos_lnum;
108
+
pos_bol = lexing_position_pos_bol;
109
+
pos_cnum = lexing_position_pos_cnum
110
+
})))))
111
+
} : lexing_position Rpc.Types.structure)
112
+
and lexing_position =
113
+
{
114
+
Rpc.Types.name = "lexing_position";
115
+
Rpc.Types.description = [];
116
+
Rpc.Types.ty = typ_of_lexing_position
117
+
}
118
+
let _ = lexing_position_pos_fname
119
+
and _ = lexing_position_pos_lnum
120
+
and _ = lexing_position_pos_bol
121
+
and _ = lexing_position_pos_cnum
122
+
and _ = typ_of_lexing_position
123
+
and _ = lexing_position
124
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
125
+
type location = Location.t =
126
+
{
127
+
loc_start: lexing_position ;
128
+
loc_end: lexing_position ;
129
+
loc_ghost: bool }[@@deriving rpcty]
130
+
include
131
+
struct
132
+
let _ = fun (_ : location) -> ()
133
+
let rec location_loc_start : (_, location) Rpc.Types.field =
134
+
{
135
+
Rpc.Types.fname = "loc_start";
136
+
Rpc.Types.field = typ_of_lexing_position;
137
+
Rpc.Types.fdefault = None;
138
+
Rpc.Types.fdescription = [];
139
+
Rpc.Types.fversion = None;
140
+
Rpc.Types.fget = (fun _r -> _r.loc_start);
141
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with loc_start = v })
142
+
}
143
+
and location_loc_end : (_, location) Rpc.Types.field =
144
+
{
145
+
Rpc.Types.fname = "loc_end";
146
+
Rpc.Types.field = typ_of_lexing_position;
147
+
Rpc.Types.fdefault = None;
148
+
Rpc.Types.fdescription = [];
149
+
Rpc.Types.fversion = None;
150
+
Rpc.Types.fget = (fun _r -> _r.loc_end);
151
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with loc_end = v })
152
+
}
153
+
and location_loc_ghost : (_, location) Rpc.Types.field =
154
+
{
155
+
Rpc.Types.fname = "loc_ghost";
156
+
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
157
+
Rpc.Types.fdefault = None;
158
+
Rpc.Types.fdescription = [];
159
+
Rpc.Types.fversion = None;
160
+
Rpc.Types.fget = (fun _r -> _r.loc_ghost);
161
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with loc_ghost = v })
162
+
}
163
+
and typ_of_location =
164
+
Rpc.Types.Struct
165
+
({
166
+
Rpc.Types.fields =
167
+
[Rpc.Types.BoxedField location_loc_start;
168
+
Rpc.Types.BoxedField location_loc_end;
169
+
Rpc.Types.BoxedField location_loc_ghost];
170
+
Rpc.Types.sname = "location";
171
+
Rpc.Types.version = None;
172
+
Rpc.Types.constructor =
173
+
(fun getter ->
174
+
let open Rresult.R in
175
+
(getter.Rpc.Types.field_get "loc_ghost"
176
+
(let open Rpc.Types in Basic Bool))
177
+
>>=
178
+
(fun location_loc_ghost ->
179
+
(getter.Rpc.Types.field_get "loc_end"
180
+
typ_of_lexing_position)
181
+
>>=
182
+
(fun location_loc_end ->
183
+
(getter.Rpc.Types.field_get "loc_start"
184
+
typ_of_lexing_position)
185
+
>>=
186
+
(fun location_loc_start ->
187
+
return
188
+
{
189
+
loc_start = location_loc_start;
190
+
loc_end = location_loc_end;
191
+
loc_ghost = location_loc_ghost
192
+
}))))
193
+
} : location Rpc.Types.structure)
194
+
and location =
195
+
{
196
+
Rpc.Types.name = "location";
197
+
Rpc.Types.description = [];
198
+
Rpc.Types.ty = typ_of_location
199
+
}
200
+
let _ = location_loc_start
201
+
and _ = location_loc_end
202
+
and _ = location_loc_ghost
203
+
and _ = typ_of_location
204
+
and _ = location
205
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
206
+
type location_error_source = Location.error_source =
207
+
| Lexer
208
+
| Parser
209
+
| Typer
210
+
| Warning
211
+
| Unknown
212
+
| Env
213
+
| Config [@@deriving rpcty]
214
+
include
215
+
struct
216
+
let _ = fun (_ : location_error_source) -> ()
217
+
let rec typ_of_location_error_source =
218
+
Rpc.Types.Variant
219
+
({
220
+
Rpc.Types.vname = "location_error_source";
221
+
Rpc.Types.variants =
222
+
[BoxedTag
223
+
{
224
+
Rpc.Types.tname = "Lexer";
225
+
Rpc.Types.tcontents = Unit;
226
+
Rpc.Types.tversion = None;
227
+
Rpc.Types.tdescription = [];
228
+
Rpc.Types.tpreview =
229
+
((function | Lexer -> Some () | _ -> None));
230
+
Rpc.Types.treview = ((function | () -> Lexer))
231
+
};
232
+
BoxedTag
233
+
{
234
+
Rpc.Types.tname = "Parser";
235
+
Rpc.Types.tcontents = Unit;
236
+
Rpc.Types.tversion = None;
237
+
Rpc.Types.tdescription = [];
238
+
Rpc.Types.tpreview =
239
+
((function | Parser -> Some () | _ -> None));
240
+
Rpc.Types.treview = ((function | () -> Parser))
241
+
};
242
+
BoxedTag
243
+
{
244
+
Rpc.Types.tname = "Typer";
245
+
Rpc.Types.tcontents = Unit;
246
+
Rpc.Types.tversion = None;
247
+
Rpc.Types.tdescription = [];
248
+
Rpc.Types.tpreview =
249
+
((function | Typer -> Some () | _ -> None));
250
+
Rpc.Types.treview = ((function | () -> Typer))
251
+
};
252
+
BoxedTag
253
+
{
254
+
Rpc.Types.tname = "Warning";
255
+
Rpc.Types.tcontents = Unit;
256
+
Rpc.Types.tversion = None;
257
+
Rpc.Types.tdescription = [];
258
+
Rpc.Types.tpreview =
259
+
((function | Warning -> Some () | _ -> None));
260
+
Rpc.Types.treview = ((function | () -> Warning))
261
+
};
262
+
BoxedTag
263
+
{
264
+
Rpc.Types.tname = "Unknown";
265
+
Rpc.Types.tcontents = Unit;
266
+
Rpc.Types.tversion = None;
267
+
Rpc.Types.tdescription = [];
268
+
Rpc.Types.tpreview =
269
+
((function | Unknown -> Some () | _ -> None));
270
+
Rpc.Types.treview = ((function | () -> Unknown))
271
+
};
272
+
BoxedTag
273
+
{
274
+
Rpc.Types.tname = "Env";
275
+
Rpc.Types.tcontents = Unit;
276
+
Rpc.Types.tversion = None;
277
+
Rpc.Types.tdescription = [];
278
+
Rpc.Types.tpreview =
279
+
((function | Env -> Some () | _ -> None));
280
+
Rpc.Types.treview = ((function | () -> Env))
281
+
};
282
+
BoxedTag
283
+
{
284
+
Rpc.Types.tname = "Config";
285
+
Rpc.Types.tcontents = Unit;
286
+
Rpc.Types.tversion = None;
287
+
Rpc.Types.tdescription = [];
288
+
Rpc.Types.tpreview =
289
+
((function | Config -> Some () | _ -> None));
290
+
Rpc.Types.treview = ((function | () -> Config))
291
+
}];
292
+
Rpc.Types.vdefault = None;
293
+
Rpc.Types.vversion = None;
294
+
Rpc.Types.vconstructor =
295
+
(fun s' ->
296
+
fun t ->
297
+
let s = String.lowercase_ascii s' in
298
+
match s with
299
+
| "lexer" ->
300
+
Rresult.R.bind (t.tget Unit)
301
+
(function | () -> Rresult.R.ok Lexer)
302
+
| "parser" ->
303
+
Rresult.R.bind (t.tget Unit)
304
+
(function | () -> Rresult.R.ok Parser)
305
+
| "typer" ->
306
+
Rresult.R.bind (t.tget Unit)
307
+
(function | () -> Rresult.R.ok Typer)
308
+
| "warning" ->
309
+
Rresult.R.bind (t.tget Unit)
310
+
(function | () -> Rresult.R.ok Warning)
311
+
| "unknown" ->
312
+
Rresult.R.bind (t.tget Unit)
313
+
(function | () -> Rresult.R.ok Unknown)
314
+
| "env" ->
315
+
Rresult.R.bind (t.tget Unit)
316
+
(function | () -> Rresult.R.ok Env)
317
+
| "config" ->
318
+
Rresult.R.bind (t.tget Unit)
319
+
(function | () -> Rresult.R.ok Config)
320
+
| _ ->
321
+
Rresult.R.error_msg
322
+
(Printf.sprintf "Unknown tag '%s'" s))
323
+
} : location_error_source Rpc.Types.variant)
324
+
and location_error_source =
325
+
{
326
+
Rpc.Types.name = "location_error_source";
327
+
Rpc.Types.description = [];
328
+
Rpc.Types.ty = typ_of_location_error_source
329
+
}
330
+
let _ = typ_of_location_error_source
331
+
and _ = location_error_source
332
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
333
+
type location_report_kind = Location.report_kind =
334
+
| Report_error
335
+
| Report_warning of string
336
+
| Report_warning_as_error of string
337
+
| Report_alert of string
338
+
| Report_alert_as_error of string [@@deriving rpcty]
339
+
include
340
+
struct
341
+
let _ = fun (_ : location_report_kind) -> ()
342
+
let rec typ_of_location_report_kind =
343
+
Rpc.Types.Variant
344
+
({
345
+
Rpc.Types.vname = "location_report_kind";
346
+
Rpc.Types.variants =
347
+
[BoxedTag
348
+
{
349
+
Rpc.Types.tname = "Report_error";
350
+
Rpc.Types.tcontents = Unit;
351
+
Rpc.Types.tversion = None;
352
+
Rpc.Types.tdescription = [];
353
+
Rpc.Types.tpreview =
354
+
((function | Report_error -> Some () | _ -> None));
355
+
Rpc.Types.treview = ((function | () -> Report_error))
356
+
};
357
+
BoxedTag
358
+
{
359
+
Rpc.Types.tname = "Report_warning";
360
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
361
+
Rpc.Types.tversion = None;
362
+
Rpc.Types.tdescription = [];
363
+
Rpc.Types.tpreview =
364
+
((function | Report_warning a0 -> Some a0 | _ -> None));
365
+
Rpc.Types.treview = ((function | a0 -> Report_warning a0))
366
+
};
367
+
BoxedTag
368
+
{
369
+
Rpc.Types.tname = "Report_warning_as_error";
370
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
371
+
Rpc.Types.tversion = None;
372
+
Rpc.Types.tdescription = [];
373
+
Rpc.Types.tpreview =
374
+
((function
375
+
| Report_warning_as_error a0 -> Some a0
376
+
| _ -> None));
377
+
Rpc.Types.treview =
378
+
((function | a0 -> Report_warning_as_error a0))
379
+
};
380
+
BoxedTag
381
+
{
382
+
Rpc.Types.tname = "Report_alert";
383
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
384
+
Rpc.Types.tversion = None;
385
+
Rpc.Types.tdescription = [];
386
+
Rpc.Types.tpreview =
387
+
((function | Report_alert a0 -> Some a0 | _ -> None));
388
+
Rpc.Types.treview = ((function | a0 -> Report_alert a0))
389
+
};
390
+
BoxedTag
391
+
{
392
+
Rpc.Types.tname = "Report_alert_as_error";
393
+
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
394
+
Rpc.Types.tversion = None;
395
+
Rpc.Types.tdescription = [];
396
+
Rpc.Types.tpreview =
397
+
((function
398
+
| Report_alert_as_error a0 -> Some a0
399
+
| _ -> None));
400
+
Rpc.Types.treview =
401
+
((function | a0 -> Report_alert_as_error a0))
402
+
}];
403
+
Rpc.Types.vdefault = None;
404
+
Rpc.Types.vversion = None;
405
+
Rpc.Types.vconstructor =
406
+
(fun s' ->
407
+
fun t ->
408
+
let s = String.lowercase_ascii s' in
409
+
match s with
410
+
| "report_error" ->
411
+
Rresult.R.bind (t.tget Unit)
412
+
(function | () -> Rresult.R.ok Report_error)
413
+
| "report_warning" ->
414
+
Rresult.R.bind
415
+
(t.tget (let open Rpc.Types in Basic String))
416
+
(function | a0 -> Rresult.R.ok (Report_warning a0))
417
+
| "report_warning_as_error" ->
418
+
Rresult.R.bind
419
+
(t.tget (let open Rpc.Types in Basic String))
420
+
(function
421
+
| a0 -> Rresult.R.ok (Report_warning_as_error a0))
422
+
| "report_alert" ->
423
+
Rresult.R.bind
424
+
(t.tget (let open Rpc.Types in Basic String))
425
+
(function | a0 -> Rresult.R.ok (Report_alert a0))
426
+
| "report_alert_as_error" ->
427
+
Rresult.R.bind
428
+
(t.tget (let open Rpc.Types in Basic String))
429
+
(function
430
+
| a0 -> Rresult.R.ok (Report_alert_as_error a0))
431
+
| _ ->
432
+
Rresult.R.error_msg
433
+
(Printf.sprintf "Unknown tag '%s'" s))
434
+
} : location_report_kind Rpc.Types.variant)
435
+
and location_report_kind =
436
+
{
437
+
Rpc.Types.name = "location_report_kind";
438
+
Rpc.Types.description = [];
439
+
Rpc.Types.ty = typ_of_location_report_kind
440
+
}
441
+
let _ = typ_of_location_report_kind
442
+
and _ = location_report_kind
443
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
444
+
type source = string[@@deriving rpcty]
445
+
include
446
+
struct
447
+
let _ = fun (_ : source) -> ()
448
+
let rec typ_of_source = let open Rpc.Types in Basic String
449
+
and source =
450
+
{
451
+
Rpc.Types.name = "source";
452
+
Rpc.Types.description = [];
453
+
Rpc.Types.ty = typ_of_source
454
+
}
455
+
let _ = typ_of_source
456
+
and _ = source
457
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
458
+
[@@@ocaml.text
459
+
" CMIs are provided either statically or as URLs to be downloaded on demand "]
460
+
[@@@ocaml.text
461
+
" Dynamic cmis are loaded from beneath the given url. In addition the\n top-level modules are specified, and prefixes for other modules. For\n example, for the OCaml standard library, a user might pass:\n\n {[\n { dcs_url=\"/static/stdlib\";\n dcs_toplevel_modules=[\"Stdlib\"];\n dcs_file_prefixes=[\"stdlib__\"]; }\n ]}\n\n In which case, merlin will expect to be able to download a valid file\n from the url [\"/static/stdlib/stdlib.cmi\"] corresponding to the\n specified toplevel module, and it will also attempt to download any\n module with the prefix [\"Stdlib__\"] from the same base url, so for\n example if an attempt is made to look up the module [\"Stdlib__Foo\"]\n then merlin-js will attempt to download a file from the url\n [\"/static/stdlib/stdlib__Foo.cmi\"].\n "]
462
+
type dynamic_cmis =
463
+
{
464
+
dcs_url: string ;
465
+
dcs_toplevel_modules: string list ;
466
+
dcs_file_prefixes: string list }
467
+
and static_cmi = {
468
+
sc_name: string ;
469
+
sc_content: string }
470
+
and cmis = {
471
+
static_cmis: static_cmi list ;
472
+
dynamic_cmis: dynamic_cmis option }[@@deriving rpcty]
473
+
include
474
+
struct
475
+
let _ = fun (_ : dynamic_cmis) -> ()
476
+
let _ = fun (_ : static_cmi) -> ()
477
+
let _ = fun (_ : cmis) -> ()
478
+
let rec dynamic_cmis_dcs_url : (_, dynamic_cmis) Rpc.Types.field =
479
+
{
480
+
Rpc.Types.fname = "dcs_url";
481
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
482
+
Rpc.Types.fdefault = None;
483
+
Rpc.Types.fdescription = [];
484
+
Rpc.Types.fversion = None;
485
+
Rpc.Types.fget = (fun _r -> _r.dcs_url);
486
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with dcs_url = v })
487
+
}
488
+
and dynamic_cmis_dcs_toplevel_modules : (_, dynamic_cmis) Rpc.Types.field
489
+
=
490
+
{
491
+
Rpc.Types.fname = "dcs_toplevel_modules";
492
+
Rpc.Types.field =
493
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
494
+
Rpc.Types.fdefault = None;
495
+
Rpc.Types.fdescription = [];
496
+
Rpc.Types.fversion = None;
497
+
Rpc.Types.fget = (fun _r -> _r.dcs_toplevel_modules);
498
+
Rpc.Types.fset =
499
+
(fun v -> fun _s -> { _s with dcs_toplevel_modules = v })
500
+
}
501
+
and dynamic_cmis_dcs_file_prefixes : (_, dynamic_cmis) Rpc.Types.field =
502
+
{
503
+
Rpc.Types.fname = "dcs_file_prefixes";
504
+
Rpc.Types.field =
505
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
506
+
Rpc.Types.fdefault = None;
507
+
Rpc.Types.fdescription = [];
508
+
Rpc.Types.fversion = None;
509
+
Rpc.Types.fget = (fun _r -> _r.dcs_file_prefixes);
510
+
Rpc.Types.fset =
511
+
(fun v -> fun _s -> { _s with dcs_file_prefixes = v })
512
+
}
513
+
and typ_of_dynamic_cmis =
514
+
Rpc.Types.Struct
515
+
({
516
+
Rpc.Types.fields =
517
+
[Rpc.Types.BoxedField dynamic_cmis_dcs_url;
518
+
Rpc.Types.BoxedField dynamic_cmis_dcs_toplevel_modules;
519
+
Rpc.Types.BoxedField dynamic_cmis_dcs_file_prefixes];
520
+
Rpc.Types.sname = "dynamic_cmis";
521
+
Rpc.Types.version = None;
522
+
Rpc.Types.constructor =
523
+
(fun getter ->
524
+
let open Rresult.R in
525
+
(getter.Rpc.Types.field_get "dcs_file_prefixes"
526
+
(Rpc.Types.List (let open Rpc.Types in Basic String)))
527
+
>>=
528
+
(fun dynamic_cmis_dcs_file_prefixes ->
529
+
(getter.Rpc.Types.field_get "dcs_toplevel_modules"
530
+
(Rpc.Types.List
531
+
(let open Rpc.Types in Basic String)))
532
+
>>=
533
+
(fun dynamic_cmis_dcs_toplevel_modules ->
534
+
(getter.Rpc.Types.field_get "dcs_url"
535
+
(let open Rpc.Types in Basic String))
536
+
>>=
537
+
(fun dynamic_cmis_dcs_url ->
538
+
return
539
+
{
540
+
dcs_url = dynamic_cmis_dcs_url;
541
+
dcs_toplevel_modules =
542
+
dynamic_cmis_dcs_toplevel_modules;
543
+
dcs_file_prefixes =
544
+
dynamic_cmis_dcs_file_prefixes
545
+
}))))
546
+
} : dynamic_cmis Rpc.Types.structure)
547
+
and dynamic_cmis =
548
+
{
549
+
Rpc.Types.name = "dynamic_cmis";
550
+
Rpc.Types.description = [];
551
+
Rpc.Types.ty = typ_of_dynamic_cmis
552
+
}
553
+
and static_cmi_sc_name : (_, static_cmi) Rpc.Types.field =
554
+
{
555
+
Rpc.Types.fname = "sc_name";
556
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
557
+
Rpc.Types.fdefault = None;
558
+
Rpc.Types.fdescription = [];
559
+
Rpc.Types.fversion = None;
560
+
Rpc.Types.fget = (fun _r -> _r.sc_name);
561
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with sc_name = v })
562
+
}
563
+
and static_cmi_sc_content : (_, static_cmi) Rpc.Types.field =
564
+
{
565
+
Rpc.Types.fname = "sc_content";
566
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
567
+
Rpc.Types.fdefault = None;
568
+
Rpc.Types.fdescription = [];
569
+
Rpc.Types.fversion = None;
570
+
Rpc.Types.fget = (fun _r -> _r.sc_content);
571
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with sc_content = v })
572
+
}
573
+
and typ_of_static_cmi =
574
+
Rpc.Types.Struct
575
+
({
576
+
Rpc.Types.fields =
577
+
[Rpc.Types.BoxedField static_cmi_sc_name;
578
+
Rpc.Types.BoxedField static_cmi_sc_content];
579
+
Rpc.Types.sname = "static_cmi";
580
+
Rpc.Types.version = None;
581
+
Rpc.Types.constructor =
582
+
(fun getter ->
583
+
let open Rresult.R in
584
+
(getter.Rpc.Types.field_get "sc_content"
585
+
(let open Rpc.Types in Basic String))
586
+
>>=
587
+
(fun static_cmi_sc_content ->
588
+
(getter.Rpc.Types.field_get "sc_name"
589
+
(let open Rpc.Types in Basic String))
590
+
>>=
591
+
(fun static_cmi_sc_name ->
592
+
return
593
+
{
594
+
sc_name = static_cmi_sc_name;
595
+
sc_content = static_cmi_sc_content
596
+
})))
597
+
} : static_cmi Rpc.Types.structure)
598
+
and static_cmi =
599
+
{
600
+
Rpc.Types.name = "static_cmi";
601
+
Rpc.Types.description = [];
602
+
Rpc.Types.ty = typ_of_static_cmi
603
+
}
604
+
and cmis_static_cmis : (_, cmis) Rpc.Types.field =
605
+
{
606
+
Rpc.Types.fname = "static_cmis";
607
+
Rpc.Types.field = (Rpc.Types.List typ_of_static_cmi);
608
+
Rpc.Types.fdefault = None;
609
+
Rpc.Types.fdescription = [];
610
+
Rpc.Types.fversion = None;
611
+
Rpc.Types.fget = (fun _r -> _r.static_cmis);
612
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with static_cmis = v })
613
+
}
614
+
and cmis_dynamic_cmis : (_, cmis) Rpc.Types.field =
615
+
{
616
+
Rpc.Types.fname = "dynamic_cmis";
617
+
Rpc.Types.field = (Rpc.Types.Option typ_of_dynamic_cmis);
618
+
Rpc.Types.fdefault = None;
619
+
Rpc.Types.fdescription = [];
620
+
Rpc.Types.fversion = None;
621
+
Rpc.Types.fget = (fun _r -> _r.dynamic_cmis);
622
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with dynamic_cmis = v })
623
+
}
624
+
and typ_of_cmis =
625
+
Rpc.Types.Struct
626
+
({
627
+
Rpc.Types.fields =
628
+
[Rpc.Types.BoxedField cmis_static_cmis;
629
+
Rpc.Types.BoxedField cmis_dynamic_cmis];
630
+
Rpc.Types.sname = "cmis";
631
+
Rpc.Types.version = None;
632
+
Rpc.Types.constructor =
633
+
(fun getter ->
634
+
let open Rresult.R in
635
+
(getter.Rpc.Types.field_get "dynamic_cmis"
636
+
(Rpc.Types.Option typ_of_dynamic_cmis))
637
+
>>=
638
+
(fun cmis_dynamic_cmis ->
639
+
(getter.Rpc.Types.field_get "static_cmis"
640
+
(Rpc.Types.List typ_of_static_cmi))
641
+
>>=
642
+
(fun cmis_static_cmis ->
643
+
return
644
+
{
645
+
static_cmis = cmis_static_cmis;
646
+
dynamic_cmis = cmis_dynamic_cmis
647
+
})))
648
+
} : cmis Rpc.Types.structure)
649
+
and cmis =
650
+
{
651
+
Rpc.Types.name = "cmis";
652
+
Rpc.Types.description = [];
653
+
Rpc.Types.ty = typ_of_cmis
654
+
}
655
+
let _ = dynamic_cmis_dcs_url
656
+
and _ = dynamic_cmis_dcs_toplevel_modules
657
+
and _ = dynamic_cmis_dcs_file_prefixes
658
+
and _ = typ_of_dynamic_cmis
659
+
and _ = dynamic_cmis
660
+
and _ = static_cmi_sc_name
661
+
and _ = static_cmi_sc_content
662
+
and _ = typ_of_static_cmi
663
+
and _ = static_cmi
664
+
and _ = cmis_static_cmis
665
+
and _ = cmis_dynamic_cmis
666
+
and _ = typ_of_cmis
667
+
and _ = cmis
668
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
669
+
type action =
670
+
| Complete_prefix of source * Msource.position
671
+
| Type_enclosing of source * Msource.position
672
+
| All_errors of source
673
+
| Add_cmis of cmis
674
+
type error =
675
+
{
676
+
kind: location_report_kind ;
677
+
loc: location ;
678
+
main: string ;
679
+
sub: string list ;
680
+
source: location_error_source }[@@deriving rpcty]
681
+
include
682
+
struct
683
+
let _ = fun (_ : error) -> ()
684
+
let rec error_kind : (_, error) Rpc.Types.field =
685
+
{
686
+
Rpc.Types.fname = "kind";
687
+
Rpc.Types.field = typ_of_location_report_kind;
688
+
Rpc.Types.fdefault = None;
689
+
Rpc.Types.fdescription = [];
690
+
Rpc.Types.fversion = None;
691
+
Rpc.Types.fget = (fun _r -> _r.kind);
692
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with kind = v })
693
+
}
694
+
and error_loc : (_, error) Rpc.Types.field =
695
+
{
696
+
Rpc.Types.fname = "loc";
697
+
Rpc.Types.field = typ_of_location;
698
+
Rpc.Types.fdefault = None;
699
+
Rpc.Types.fdescription = [];
700
+
Rpc.Types.fversion = None;
701
+
Rpc.Types.fget = (fun _r -> _r.loc);
702
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with loc = v })
703
+
}
704
+
and error_main : (_, error) Rpc.Types.field =
705
+
{
706
+
Rpc.Types.fname = "main";
707
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
708
+
Rpc.Types.fdefault = None;
709
+
Rpc.Types.fdescription = [];
710
+
Rpc.Types.fversion = None;
711
+
Rpc.Types.fget = (fun _r -> _r.main);
712
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with main = v })
713
+
}
714
+
and error_sub : (_, error) Rpc.Types.field =
715
+
{
716
+
Rpc.Types.fname = "sub";
717
+
Rpc.Types.field =
718
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
719
+
Rpc.Types.fdefault = None;
720
+
Rpc.Types.fdescription = [];
721
+
Rpc.Types.fversion = None;
722
+
Rpc.Types.fget = (fun _r -> _r.sub);
723
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with sub = v })
724
+
}
725
+
and error_source : (_, error) Rpc.Types.field =
726
+
{
727
+
Rpc.Types.fname = "source";
728
+
Rpc.Types.field = typ_of_location_error_source;
729
+
Rpc.Types.fdefault = None;
730
+
Rpc.Types.fdescription = [];
731
+
Rpc.Types.fversion = None;
732
+
Rpc.Types.fget = (fun _r -> _r.source);
733
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with source = v })
734
+
}
735
+
and typ_of_error =
736
+
Rpc.Types.Struct
737
+
({
738
+
Rpc.Types.fields =
739
+
[Rpc.Types.BoxedField error_kind;
740
+
Rpc.Types.BoxedField error_loc;
741
+
Rpc.Types.BoxedField error_main;
742
+
Rpc.Types.BoxedField error_sub;
743
+
Rpc.Types.BoxedField error_source];
744
+
Rpc.Types.sname = "error";
745
+
Rpc.Types.version = None;
746
+
Rpc.Types.constructor =
747
+
(fun getter ->
748
+
let open Rresult.R in
749
+
(getter.Rpc.Types.field_get "source"
750
+
typ_of_location_error_source)
751
+
>>=
752
+
(fun error_source ->
753
+
(getter.Rpc.Types.field_get "sub"
754
+
(Rpc.Types.List
755
+
(let open Rpc.Types in Basic String)))
756
+
>>=
757
+
(fun error_sub ->
758
+
(getter.Rpc.Types.field_get "main"
759
+
(let open Rpc.Types in Basic String))
760
+
>>=
761
+
(fun error_main ->
762
+
(getter.Rpc.Types.field_get "loc"
763
+
typ_of_location)
764
+
>>=
765
+
(fun error_loc ->
766
+
(getter.Rpc.Types.field_get "kind"
767
+
typ_of_location_report_kind)
768
+
>>=
769
+
(fun error_kind ->
770
+
return
771
+
{
772
+
kind = error_kind;
773
+
loc = error_loc;
774
+
main = error_main;
775
+
sub = error_sub;
776
+
source = error_source
777
+
}))))))
778
+
} : error Rpc.Types.structure)
779
+
and error =
780
+
{
781
+
Rpc.Types.name = "error";
782
+
Rpc.Types.description = [];
783
+
Rpc.Types.ty = typ_of_error
784
+
}
785
+
let _ = error_kind
786
+
and _ = error_loc
787
+
and _ = error_main
788
+
and _ = error_sub
789
+
and _ = error_source
790
+
and _ = typ_of_error
791
+
and _ = error
792
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
793
+
type error_list = error list[@@deriving rpcty]
794
+
include
795
+
struct
796
+
let _ = fun (_ : error_list) -> ()
797
+
let rec typ_of_error_list = Rpc.Types.List typ_of_error
798
+
and error_list =
799
+
{
800
+
Rpc.Types.name = "error_list";
801
+
Rpc.Types.description = [];
802
+
Rpc.Types.ty = typ_of_error_list
803
+
}
804
+
let _ = typ_of_error_list
805
+
and _ = error_list
806
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
807
+
type kind_ty =
808
+
[ `Constructor | `Keyword | `Label | `MethodCall | `Modtype |
809
+
`Module
810
+
| `Type | `Value | `Variant ]
811
+
include
812
+
struct
813
+
open Rpc.Types
814
+
let _ = fun (_ : kind_ty) -> ()
815
+
let rec typ_of_kind_ty =
816
+
let mk tname tpreview treview =
817
+
BoxedTag
818
+
{
819
+
tname;
820
+
tcontents = Unit;
821
+
tversion = None;
822
+
tdescription = [];
823
+
tpreview;
824
+
treview
825
+
} in
826
+
Variant
827
+
({
828
+
vname = "kind";
829
+
variants =
830
+
[mk "Constructor"
831
+
(function | `Constructor -> Some () | _ -> None)
832
+
(function | () -> `Constructor);
833
+
mk "Keyword" (function | `Keyword -> Some () | _ -> None)
834
+
(function | () -> `Keyword);
835
+
mk "Label" (function | `Label -> Some () | _ -> None)
836
+
(function | () -> `Label);
837
+
mk "MethodCall" (function | `MethodCall -> Some () | _ -> None)
838
+
(function | () -> `MethodCall);
839
+
mk "Modtype" (function | `Modtype -> Some () | _ -> None)
840
+
(function | () -> `Modtype);
841
+
mk "Module" (function | `Module -> Some () | _ -> None)
842
+
(function | () -> `Module);
843
+
mk "Type" (function | `Type -> Some () | _ -> None)
844
+
(function | () -> `Type);
845
+
mk "Value" (function | `Value -> Some () | _ -> None)
846
+
(function | () -> `Value);
847
+
mk "Variant" (function | `Variant -> Some () | _ -> None)
848
+
(function | () -> `Variant)];
849
+
vdefault = None;
850
+
vversion = None;
851
+
vconstructor =
852
+
(fun s' ->
853
+
fun t ->
854
+
let s = String.lowercase_ascii s' in
855
+
match s with
856
+
| "constructor" ->
857
+
Rresult.R.bind (t.tget Unit)
858
+
(function | () -> Rresult.R.ok `Constructor)
859
+
| "keyword" ->
860
+
Rresult.R.bind (t.tget Unit)
861
+
(function | () -> Rresult.R.ok `Keyword)
862
+
| "label" ->
863
+
Rresult.R.bind (t.tget Unit)
864
+
(function | () -> Rresult.R.ok `Label)
865
+
| "methodcall" ->
866
+
Rresult.R.bind (t.tget Unit)
867
+
(function | () -> Rresult.R.ok `MethodCall)
868
+
| "modtype" ->
869
+
Rresult.R.bind (t.tget Unit)
870
+
(function | () -> Rresult.R.ok `Modtype)
871
+
| "module" ->
872
+
Rresult.R.bind (t.tget Unit)
873
+
(function | () -> Rresult.R.ok `Module)
874
+
| "type" ->
875
+
Rresult.R.bind (t.tget Unit)
876
+
(function | () -> Rresult.R.ok `Type)
877
+
| "value" ->
878
+
Rresult.R.bind (t.tget Unit)
879
+
(function | () -> Rresult.R.ok `Value)
880
+
| "variant" ->
881
+
Rresult.R.bind (t.tget Unit)
882
+
(function | () -> Rresult.R.ok `Variant)
883
+
| _ ->
884
+
Rresult.R.error_msg
885
+
(Printf.sprintf "Unknown tag '%s'" s))
886
+
} : kind_ty variant)
887
+
and kind_ty = { name = "kind_ty"; description = []; ty = typ_of_kind_ty }
888
+
let _ = typ_of_kind_ty
889
+
and _ = kind_ty
890
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
891
+
type query_protocol_compl_entry = Query_protocol.Compl.entry
892
+
include
893
+
struct
894
+
open Rpc.Types
895
+
let _ = fun (_ : query_protocol_compl_entry) -> ()
896
+
let rec query_protocol_compl_entry_name :
897
+
(_, query_protocol_compl_entry) field =
898
+
{
899
+
fname = "name";
900
+
field = typ_of_source;
901
+
fdefault = None;
902
+
fdescription = [];
903
+
fversion = None;
904
+
fget = (fun _r -> _r.name);
905
+
fset = (fun v -> fun _s -> { _s with name = v })
906
+
}
907
+
and query_protocol_compl_entry_kind :
908
+
(_, query_protocol_compl_entry) field =
909
+
{
910
+
fname = "kind";
911
+
field = typ_of_kind_ty;
912
+
fdefault = None;
913
+
fdescription = [];
914
+
fversion = None;
915
+
fget = (fun _r -> _r.kind);
916
+
fset = (fun v -> fun _s -> { _s with kind = v })
917
+
}
918
+
and query_protocol_compl_entry_desc :
919
+
(_, query_protocol_compl_entry) field =
920
+
{
921
+
fname = "desc";
922
+
field = typ_of_source;
923
+
fdefault = None;
924
+
fdescription = [];
925
+
fversion = None;
926
+
fget = (fun _r -> _r.desc);
927
+
fset = (fun v -> fun _s -> { _s with desc = v })
928
+
}
929
+
and query_protocol_compl_entry_info :
930
+
(_, query_protocol_compl_entry) field =
931
+
{
932
+
fname = "info";
933
+
field = typ_of_source;
934
+
fdefault = None;
935
+
fdescription = [];
936
+
fversion = None;
937
+
fget = (fun _r -> _r.info);
938
+
fset = (fun v -> fun _s -> { _s with info = v })
939
+
}
940
+
and query_protocol_compl_entry_deprecated :
941
+
(_, query_protocol_compl_entry) field =
942
+
{
943
+
fname = "deprecated";
944
+
field = (let open Rpc.Types in Basic Bool);
945
+
fdefault = None;
946
+
fdescription = [];
947
+
fversion = None;
948
+
fget = (fun _r -> _r.deprecated);
949
+
fset = (fun v -> fun _s -> { _s with deprecated = v })
950
+
}
951
+
and typ_of_query_protocol_compl_entry =
952
+
Struct
953
+
({
954
+
fields =
955
+
[BoxedField query_protocol_compl_entry_name;
956
+
BoxedField query_protocol_compl_entry_kind;
957
+
BoxedField query_protocol_compl_entry_desc;
958
+
BoxedField query_protocol_compl_entry_info;
959
+
BoxedField query_protocol_compl_entry_deprecated];
960
+
sname = "query_protocol_compl_entry";
961
+
version = None;
962
+
constructor =
963
+
(fun getter ->
964
+
let open Rresult.R in
965
+
(getter.field_get "deprecated"
966
+
(let open Rpc.Types in Basic Bool))
967
+
>>=
968
+
(fun query_protocol_compl_entry_deprecated ->
969
+
(getter.field_get "info" typ_of_source) >>=
970
+
(fun query_protocol_compl_entry_info ->
971
+
(getter.field_get "desc" typ_of_source) >>=
972
+
(fun query_protocol_compl_entry_desc ->
973
+
(getter.field_get "kind" typ_of_kind_ty) >>=
974
+
(fun query_protocol_compl_entry_kind ->
975
+
(getter.field_get "name" typ_of_source)
976
+
>>=
977
+
(fun query_protocol_compl_entry_name
978
+
->
979
+
return
980
+
{
981
+
Query_protocol.Compl.name =
982
+
query_protocol_compl_entry_name;
983
+
kind =
984
+
query_protocol_compl_entry_kind;
985
+
desc =
986
+
query_protocol_compl_entry_desc;
987
+
info =
988
+
query_protocol_compl_entry_info;
989
+
deprecated =
990
+
query_protocol_compl_entry_deprecated
991
+
}))))))
992
+
} : query_protocol_compl_entry structure)
993
+
and query_protocol_compl_entry =
994
+
{
995
+
name = "query_protocol_compl_entry";
996
+
description = [];
997
+
ty = typ_of_query_protocol_compl_entry
998
+
}
999
+
let _ = query_protocol_compl_entry_name
1000
+
and _ = query_protocol_compl_entry_kind
1001
+
and _ = query_protocol_compl_entry_desc
1002
+
and _ = query_protocol_compl_entry_info
1003
+
and _ = query_protocol_compl_entry_deprecated
1004
+
and _ = typ_of_query_protocol_compl_entry
1005
+
and _ = query_protocol_compl_entry
1006
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1007
+
include
1008
+
struct
1009
+
open Rpc.Types
1010
+
let _ = fun (_ : Merlin_kernel.Msource.position) -> ()
1011
+
let rec typ_of_msource_position =
1012
+
Variant
1013
+
({
1014
+
vname = "msource_position";
1015
+
variants =
1016
+
[BoxedTag
1017
+
{
1018
+
tname = "Start";
1019
+
tcontents = Unit;
1020
+
tversion = None;
1021
+
tdescription = [];
1022
+
tpreview = ((function | `Start -> Some () | _ -> None));
1023
+
treview = ((function | () -> `Start))
1024
+
};
1025
+
BoxedTag
1026
+
{
1027
+
tname = "Offset";
1028
+
tcontents = ((let open Rpc.Types in Basic Int));
1029
+
tversion = None;
1030
+
tdescription = [];
1031
+
tpreview = ((function | `Offset a0 -> Some a0 | _ -> None));
1032
+
treview = ((function | a0 -> `Offset a0))
1033
+
};
1034
+
BoxedTag
1035
+
{
1036
+
tname = "Logical";
1037
+
tcontents =
1038
+
(Tuple
1039
+
(((let open Rpc.Types in Basic Int)),
1040
+
((let open Rpc.Types in Basic Int))));
1041
+
tversion = None;
1042
+
tdescription = [];
1043
+
tpreview =
1044
+
((function
1045
+
| `Logical (a0, a1) -> Some (a0, a1)
1046
+
| _ -> None));
1047
+
treview = ((function | (a0, a1) -> `Logical (a0, a1)))
1048
+
};
1049
+
BoxedTag
1050
+
{
1051
+
tname = "End";
1052
+
tcontents = Unit;
1053
+
tversion = None;
1054
+
tdescription = [];
1055
+
tpreview = ((function | `End -> Some () | _ -> None));
1056
+
treview = ((function | () -> `End))
1057
+
}];
1058
+
vdefault = None;
1059
+
vversion = None;
1060
+
vconstructor =
1061
+
(fun s' ->
1062
+
fun t ->
1063
+
let s = String.lowercase_ascii s' in
1064
+
match s with
1065
+
| "start" ->
1066
+
Rresult.R.bind (t.tget Unit)
1067
+
(function | () -> Rresult.R.ok `Start)
1068
+
| "offset" ->
1069
+
Rresult.R.bind
1070
+
(t.tget (let open Rpc.Types in Basic Int))
1071
+
(function | a0 -> Rresult.R.ok (`Offset a0))
1072
+
| "logical" ->
1073
+
Rresult.R.bind
1074
+
(t.tget
1075
+
(Tuple
1076
+
((let open Rpc.Types in Basic Int),
1077
+
(let open Rpc.Types in Basic Int))))
1078
+
(function
1079
+
| (a0, a1) -> Rresult.R.ok (`Logical (a0, a1)))
1080
+
| "end" ->
1081
+
Rresult.R.bind (t.tget Unit)
1082
+
(function | () -> Rresult.R.ok `End)
1083
+
| _ ->
1084
+
Rresult.R.error_msg
1085
+
(Printf.sprintf "Unknown tag '%s'" s))
1086
+
} : Merlin_kernel.Msource.position variant)
1087
+
and msource_position =
1088
+
{
1089
+
name = "msource_position";
1090
+
description = [];
1091
+
ty = typ_of_msource_position
1092
+
}
1093
+
let _ = typ_of_msource_position
1094
+
and _ = msource_position
1095
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1096
+
type completions =
1097
+
{
1098
+
from: int ;
1099
+
to_: int ;
1100
+
entries: query_protocol_compl_entry list }[@@deriving rpcty]
1101
+
include
1102
+
struct
1103
+
let _ = fun (_ : completions) -> ()
1104
+
let rec completions_from : (_, completions) Rpc.Types.field =
1105
+
{
1106
+
Rpc.Types.fname = "from";
1107
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1108
+
Rpc.Types.fdefault = None;
1109
+
Rpc.Types.fdescription = [];
1110
+
Rpc.Types.fversion = None;
1111
+
Rpc.Types.fget = (fun _r -> _r.from);
1112
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with from = v })
1113
+
}
1114
+
and completions_to_ : (_, completions) Rpc.Types.field =
1115
+
{
1116
+
Rpc.Types.fname = "to_";
1117
+
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1118
+
Rpc.Types.fdefault = None;
1119
+
Rpc.Types.fdescription = [];
1120
+
Rpc.Types.fversion = None;
1121
+
Rpc.Types.fget = (fun _r -> _r.to_);
1122
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with to_ = v })
1123
+
}
1124
+
and completions_entries : (_, completions) Rpc.Types.field =
1125
+
{
1126
+
Rpc.Types.fname = "entries";
1127
+
Rpc.Types.field = (Rpc.Types.List typ_of_query_protocol_compl_entry);
1128
+
Rpc.Types.fdefault = None;
1129
+
Rpc.Types.fdescription = [];
1130
+
Rpc.Types.fversion = None;
1131
+
Rpc.Types.fget = (fun _r -> _r.entries);
1132
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with entries = v })
1133
+
}
1134
+
and typ_of_completions =
1135
+
Rpc.Types.Struct
1136
+
({
1137
+
Rpc.Types.fields =
1138
+
[Rpc.Types.BoxedField completions_from;
1139
+
Rpc.Types.BoxedField completions_to_;
1140
+
Rpc.Types.BoxedField completions_entries];
1141
+
Rpc.Types.sname = "completions";
1142
+
Rpc.Types.version = None;
1143
+
Rpc.Types.constructor =
1144
+
(fun getter ->
1145
+
let open Rresult.R in
1146
+
(getter.Rpc.Types.field_get "entries"
1147
+
(Rpc.Types.List typ_of_query_protocol_compl_entry))
1148
+
>>=
1149
+
(fun completions_entries ->
1150
+
(getter.Rpc.Types.field_get "to_"
1151
+
(let open Rpc.Types in Basic Int))
1152
+
>>=
1153
+
(fun completions_to_ ->
1154
+
(getter.Rpc.Types.field_get "from"
1155
+
(let open Rpc.Types in Basic Int))
1156
+
>>=
1157
+
(fun completions_from ->
1158
+
return
1159
+
{
1160
+
from = completions_from;
1161
+
to_ = completions_to_;
1162
+
entries = completions_entries
1163
+
}))))
1164
+
} : completions Rpc.Types.structure)
1165
+
and completions =
1166
+
{
1167
+
Rpc.Types.name = "completions";
1168
+
Rpc.Types.description = [];
1169
+
Rpc.Types.ty = typ_of_completions
1170
+
}
1171
+
let _ = completions_from
1172
+
and _ = completions_to_
1173
+
and _ = completions_entries
1174
+
and _ = typ_of_completions
1175
+
and _ = completions
1176
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1177
+
type is_tail_position = [ `No | `Tail_position | `Tail_call ]
1178
+
include
1179
+
struct
1180
+
open Rpc.Types
1181
+
let _ = fun (_ : is_tail_position) -> ()
1182
+
let rec typ_of_is_tail_position =
1183
+
Variant
1184
+
({
1185
+
vname = "is_tail_position";
1186
+
variants =
1187
+
[BoxedTag
1188
+
{
1189
+
tname = "No";
1190
+
tcontents = Unit;
1191
+
tversion = None;
1192
+
tdescription = [];
1193
+
tpreview = ((function | `No -> Some () | _ -> None));
1194
+
treview = ((function | () -> `No))
1195
+
};
1196
+
BoxedTag
1197
+
{
1198
+
tname = "Tail_position";
1199
+
tcontents = Unit;
1200
+
tversion = None;
1201
+
tdescription = [];
1202
+
tpreview =
1203
+
((function | `Tail_position -> Some () | _ -> None));
1204
+
treview = ((function | () -> `Tail_position))
1205
+
};
1206
+
BoxedTag
1207
+
{
1208
+
tname = "Tail_call";
1209
+
tcontents = Unit;
1210
+
tversion = None;
1211
+
tdescription = [];
1212
+
tpreview = ((function | `Tail_call -> Some () | _ -> None));
1213
+
treview = ((function | () -> `Tail_call))
1214
+
}];
1215
+
vdefault = None;
1216
+
vversion = None;
1217
+
vconstructor =
1218
+
(fun s' ->
1219
+
fun t ->
1220
+
let s = String.lowercase_ascii s' in
1221
+
match s with
1222
+
| "no" ->
1223
+
Rresult.R.bind (t.tget Unit)
1224
+
(function | () -> Rresult.R.ok `No)
1225
+
| "tail_position" ->
1226
+
Rresult.R.bind (t.tget Unit)
1227
+
(function | () -> Rresult.R.ok `Tail_position)
1228
+
| "tail_call" ->
1229
+
Rresult.R.bind (t.tget Unit)
1230
+
(function | () -> Rresult.R.ok `Tail_call)
1231
+
| _ ->
1232
+
Rresult.R.error_msg
1233
+
(Printf.sprintf "Unknown tag '%s'" s))
1234
+
} : is_tail_position variant)
1235
+
and is_tail_position =
1236
+
{
1237
+
name = "is_tail_position";
1238
+
description = [];
1239
+
ty = typ_of_is_tail_position
1240
+
}
1241
+
let _ = typ_of_is_tail_position
1242
+
and _ = is_tail_position
1243
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1244
+
type index_or_string = [ `Index of int | `String of string ]
1245
+
include
1246
+
struct
1247
+
open Rpc.Types
1248
+
let _ = fun (_ : index_or_string) -> ()
1249
+
let rec typ_of_index_or_string =
1250
+
Variant
1251
+
({
1252
+
vname = "index_or_string";
1253
+
variants =
1254
+
[BoxedTag
1255
+
{
1256
+
tname = "Index";
1257
+
tcontents = ((let open Rpc.Types in Basic Int));
1258
+
tversion = None;
1259
+
tdescription = [];
1260
+
tpreview = ((function | `Index a0 -> Some a0 | _ -> None));
1261
+
treview = ((function | a0 -> `Index a0))
1262
+
};
1263
+
BoxedTag
1264
+
{
1265
+
tname = "String";
1266
+
tcontents = ((let open Rpc.Types in Basic String));
1267
+
tversion = None;
1268
+
tdescription = [];
1269
+
tpreview = ((function | `String a0 -> Some a0 | _ -> None));
1270
+
treview = ((function | a0 -> `String a0))
1271
+
}];
1272
+
vdefault = None;
1273
+
vversion = None;
1274
+
vconstructor =
1275
+
(fun s' ->
1276
+
fun t ->
1277
+
let s = String.lowercase_ascii s' in
1278
+
match s with
1279
+
| "index" ->
1280
+
Rresult.R.bind
1281
+
(t.tget (let open Rpc.Types in Basic Int))
1282
+
(function | a0 -> Rresult.R.ok (`Index a0))
1283
+
| "string" ->
1284
+
Rresult.R.bind
1285
+
(t.tget (let open Rpc.Types in Basic String))
1286
+
(function | a0 -> Rresult.R.ok (`String a0))
1287
+
| _ ->
1288
+
Rresult.R.error_msg
1289
+
(Printf.sprintf "Unknown tag '%s'" s))
1290
+
} : index_or_string variant)
1291
+
and index_or_string =
1292
+
{
1293
+
name = "index_or_string";
1294
+
description = [];
1295
+
ty = typ_of_index_or_string
1296
+
}
1297
+
let _ = typ_of_index_or_string
1298
+
and _ = index_or_string
1299
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1300
+
type typed_enclosings = (location * index_or_string * is_tail_position)
1301
+
[@@deriving rpcty]
1302
+
include
1303
+
struct
1304
+
let _ = fun (_ : typed_enclosings) -> ()
1305
+
let rec typ_of_typed_enclosings =
1306
+
Rpc.Types.Tuple3
1307
+
(typ_of_location, typ_of_index_or_string, typ_of_is_tail_position)
1308
+
and typed_enclosings =
1309
+
{
1310
+
Rpc.Types.name = "typed_enclosings";
1311
+
Rpc.Types.description = [];
1312
+
Rpc.Types.ty = typ_of_typed_enclosings
1313
+
}
1314
+
let _ = typ_of_typed_enclosings
1315
+
and _ = typed_enclosings
1316
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1317
+
type typed_enclosings_list = typed_enclosings list[@@deriving rpcty]
1318
+
include
1319
+
struct
1320
+
let _ = fun (_ : typed_enclosings_list) -> ()
1321
+
let rec typ_of_typed_enclosings_list =
1322
+
Rpc.Types.List typ_of_typed_enclosings
1323
+
and typed_enclosings_list =
1324
+
{
1325
+
Rpc.Types.name = "typed_enclosings_list";
1326
+
Rpc.Types.description = [];
1327
+
Rpc.Types.ty = typ_of_typed_enclosings_list
1328
+
}
1329
+
let _ = typ_of_typed_enclosings_list
1330
+
and _ = typed_enclosings_list
1331
+
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1332
+
let report_source_to_string =
1333
+
function
1334
+
| Location.Lexer -> "lexer"
1335
+
| Location.Parser -> "parser"
1336
+
| Location.Typer -> "typer"
1337
+
| Location.Warning -> "warning"
1338
+
| Location.Unknown -> "unknown"
1339
+
| Location.Env -> "env"
1340
+
| Location.Config -> "config"
21
1341
type highlight = {
22
1342
line1: int ;
23
1343
line2: int ;
···
407
1727
and _ = typ_of_exec_result
408
1728
and _ = exec_result
409
1729
end[@@ocaml.doc "@inline"][@@merlin.hide ]
410
-
type completion_result =
411
-
{
412
-
n: int
413
-
[@ocaml.doc
414
-
" The position in the input string from where the completions may be\n inserted "];
415
-
completions: string list [@ocaml.doc " The list of possible completions "]}
416
-
[@@deriving rpcty][@@ocaml.doc " The result returned by a 'complete' call. "]
417
-
include
418
-
struct
419
-
let _ = fun (_ : completion_result) -> ()
420
-
let rec completion_result_n : (_, completion_result) Rpc.Types.field =
421
-
{
422
-
Rpc.Types.fname = "n";
423
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
424
-
Rpc.Types.fdefault = None;
425
-
Rpc.Types.fdescription =
426
-
["The position in the input string from where the completions may be";
427
-
"inserted"];
428
-
Rpc.Types.fversion = None;
429
-
Rpc.Types.fget = (fun _r -> _r.n);
430
-
Rpc.Types.fset = (fun v -> fun _s -> { _s with n = v })
431
-
}
432
-
and completion_result_completions :
433
-
(_, completion_result) Rpc.Types.field =
434
-
{
435
-
Rpc.Types.fname = "completions";
436
-
Rpc.Types.field =
437
-
(Rpc.Types.List (let open Rpc.Types in Basic String));
438
-
Rpc.Types.fdefault = None;
439
-
Rpc.Types.fdescription = ["The list of possible completions"];
440
-
Rpc.Types.fversion = None;
441
-
Rpc.Types.fget = (fun _r -> _r.completions);
442
-
Rpc.Types.fset = (fun v -> fun _s -> { _s with completions = v })
443
-
}
444
-
and typ_of_completion_result =
445
-
Rpc.Types.Struct
446
-
({
447
-
Rpc.Types.fields =
448
-
[Rpc.Types.BoxedField completion_result_n;
449
-
Rpc.Types.BoxedField completion_result_completions];
450
-
Rpc.Types.sname = "completion_result";
451
-
Rpc.Types.version = None;
452
-
Rpc.Types.constructor =
453
-
(fun getter ->
454
-
let open Rresult.R in
455
-
(getter.Rpc.Types.field_get "completions"
456
-
(Rpc.Types.List (let open Rpc.Types in Basic String)))
457
-
>>=
458
-
(fun completion_result_completions ->
459
-
(getter.Rpc.Types.field_get "n"
460
-
(let open Rpc.Types in Basic Int))
461
-
>>=
462
-
(fun completion_result_n ->
463
-
return
464
-
{
465
-
n = completion_result_n;
466
-
completions = completion_result_completions
467
-
})))
468
-
} : completion_result Rpc.Types.structure)
469
-
and completion_result =
470
-
{
471
-
Rpc.Types.name = "completion_result";
472
-
Rpc.Types.description = ["The result returned by a 'complete' call."];
473
-
Rpc.Types.ty = typ_of_completion_result
474
-
}
475
-
let _ = completion_result_n
476
-
and _ = completion_result_completions
477
-
and _ = typ_of_completion_result
478
-
and _ = completion_result
479
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
480
1730
type cma =
481
1731
{
482
1732
url: string [@ocaml.doc " URL where the cma is available "];
···
537
1787
and _ = cma
538
1788
end[@@ocaml.doc "@inline"][@@merlin.hide ]
539
1789
type init_libs = {
540
-
cmi_urls: string list ;
1790
+
path: string ;
1791
+
cmis: cmis ;
541
1792
cmas: cma list }[@@deriving rpcty]
542
1793
include
543
1794
struct
544
1795
let _ = fun (_ : init_libs) -> ()
545
-
let rec init_libs_cmi_urls : (_, init_libs) Rpc.Types.field =
1796
+
let rec init_libs_path : (_, init_libs) Rpc.Types.field =
1797
+
{
1798
+
Rpc.Types.fname = "path";
1799
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
1800
+
Rpc.Types.fdefault = None;
1801
+
Rpc.Types.fdescription = [];
1802
+
Rpc.Types.fversion = None;
1803
+
Rpc.Types.fget = (fun _r -> _r.path);
1804
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with path = v })
1805
+
}
1806
+
and init_libs_cmis : (_, init_libs) Rpc.Types.field =
546
1807
{
547
-
Rpc.Types.fname = "cmi_urls";
548
-
Rpc.Types.field =
549
-
(Rpc.Types.List (let open Rpc.Types in Basic String));
1808
+
Rpc.Types.fname = "cmis";
1809
+
Rpc.Types.field = typ_of_cmis;
550
1810
Rpc.Types.fdefault = None;
551
1811
Rpc.Types.fdescription = [];
552
1812
Rpc.Types.fversion = None;
553
-
Rpc.Types.fget = (fun _r -> _r.cmi_urls);
554
-
Rpc.Types.fset = (fun v -> fun _s -> { _s with cmi_urls = v })
1813
+
Rpc.Types.fget = (fun _r -> _r.cmis);
1814
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with cmis = v })
555
1815
}
556
1816
and init_libs_cmas : (_, init_libs) Rpc.Types.field =
557
1817
{
···
567
1827
Rpc.Types.Struct
568
1828
({
569
1829
Rpc.Types.fields =
570
-
[Rpc.Types.BoxedField init_libs_cmi_urls;
1830
+
[Rpc.Types.BoxedField init_libs_path;
1831
+
Rpc.Types.BoxedField init_libs_cmis;
571
1832
Rpc.Types.BoxedField init_libs_cmas];
572
1833
Rpc.Types.sname = "init_libs";
573
1834
Rpc.Types.version = None;
···
578
1839
(Rpc.Types.List typ_of_cma))
579
1840
>>=
580
1841
(fun init_libs_cmas ->
581
-
(getter.Rpc.Types.field_get "cmi_urls"
582
-
(Rpc.Types.List
583
-
(let open Rpc.Types in Basic String)))
584
-
>>=
585
-
(fun init_libs_cmi_urls ->
586
-
return
587
-
{
588
-
cmi_urls = init_libs_cmi_urls;
589
-
cmas = init_libs_cmas
590
-
})))
1842
+
(getter.Rpc.Types.field_get "cmis" typ_of_cmis) >>=
1843
+
(fun init_libs_cmis ->
1844
+
(getter.Rpc.Types.field_get "path"
1845
+
(let open Rpc.Types in Basic String))
1846
+
>>=
1847
+
(fun init_libs_path ->
1848
+
return
1849
+
{
1850
+
path = init_libs_path;
1851
+
cmis = init_libs_cmis;
1852
+
cmas = init_libs_cmas
1853
+
}))))
591
1854
} : init_libs Rpc.Types.structure)
592
1855
and init_libs =
593
1856
{
···
595
1858
Rpc.Types.description = [];
596
1859
Rpc.Types.ty = typ_of_init_libs
597
1860
}
598
-
let _ = init_libs_cmi_urls
1861
+
let _ = init_libs_path
1862
+
and _ = init_libs_cmis
599
1863
and _ = init_libs_cmas
600
1864
and _ = typ_of_init_libs
601
1865
and _ = init_libs
···
668
1932
let implementation = implement description
669
1933
let unit_p = Param.mk Types.unit
670
1934
let phrase_p = Param.mk Types.string
1935
+
let id_p = Param.mk Types.string
671
1936
let typecheck_result_p = Param.mk exec_result
672
1937
let exec_result_p = Param.mk exec_result
673
-
let completion_p = Param.mk completion_result
1938
+
let source_p = Param.mk source
1939
+
let position_p = Param.mk msource_position
1940
+
let completions_p = Param.mk completions
1941
+
let error_list_p = Param.mk error_list
1942
+
let typed_enclosings_p = Param.mk typed_enclosings_list
674
1943
let init_libs =
675
1944
Param.mk ~name:"init_libs"
676
1945
~description:["Libraries to load during the initialisation of the toplevel. ";
···
695
1964
declare "exec"
696
1965
["Execute a phrase using the toplevel. The toplevel must have been";
697
1966
"Initialised first."] (phrase_p @-> (returning exec_result_p err))
698
-
let complete =
699
-
declare "complete"
700
-
["Find completions of the incomplete phrase. Completion occurs at the";
701
-
"end of the phrase passed in. If completion is required at a point";
702
-
"other than the end of a string, then take the substring before calling";
703
-
"this API."] (phrase_p @-> (returning completion_p err))
1967
+
let compile_js =
1968
+
declare "compile_js"
1969
+
["Compile a phrase to javascript. The toplevel must have been";
1970
+
"Initialised first."]
1971
+
(id_p @-> (phrase_p @-> (returning phrase_p err)))
1972
+
let complete_prefix =
1973
+
declare "complete_prefix" ["Complete a prefix"]
1974
+
(source_p @-> (position_p @-> (returning completions_p err)))
1975
+
let query_errors =
1976
+
declare "query_errors" ["Query the errors in the given source"]
1977
+
(source_p @-> (returning error_list_p err))
1978
+
let type_enclosing =
1979
+
declare "type_enclosing" ["Get the type of the enclosing expression"]
1980
+
(source_p @-> (position_p @-> (returning typed_enclosings_p err)))
704
1981
end
+25
js_top_worker-client_fut.opam
+25
js_top_worker-client_fut.opam
···
1
+
version: "0.0.1"
2
+
opam-version: "2.0"
3
+
maintainer: "jon@recoil.org"
4
+
authors: "various"
5
+
license: "ISC"
6
+
homepage: "https://github.com/jonludlam/js_top_worker"
7
+
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
+
depends: [
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"rresult"
13
+
"astring"
14
+
"brr" {>= "0.0.4"}
15
+
"js_top_worker" {= version}
16
+
"js_top_worker-rpc" {= version}
17
+
]
18
+
build : [
19
+
["dune" "subst"] {pinned}
20
+
["dune" "build" "-p" name "-j" jobs]
21
+
]
22
+
synopsis: "JS Toplevel worker client"
23
+
description: """
24
+
An OCaml toplevel designed to run as a web worker
25
+
"""
js_top_worker-web.opam
js_top_worker-web.opam
This is a binary file and will not be displayed.
+19
-15
lib/dune
+19
-15
lib/dune
···
1
1
; Worker library
2
2
3
-
(rule
4
-
(targets worker.ml)
5
-
(deps
6
-
(:x worker.cppo.ml))
7
-
(action
8
-
(chdir
9
-
%{workspace_root}
10
-
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets}))))
11
-
12
3
(library
13
4
(public_name js_top_worker)
14
-
(modules worker uTop_complete uTop_lexer uTop_token uTop)
5
+
(modules uTop_complete uTop_lexer uTop_token uTop impl)
15
6
(libraries
7
+
logs
16
8
js_top_worker-rpc
17
-
js_of_ocaml-toplevel
18
9
js_of_ocaml-compiler
19
10
astring
20
-
mime_printer)
11
+
mime_printer
12
+
compiler-libs.common
13
+
compiler-libs.toplevel
14
+
merlin-lib.kernel
15
+
merlin-lib.utils
16
+
merlin-lib.query_protocol
17
+
merlin-lib.query_commands
18
+
merlin-lib.ocaml_parsing)
21
19
(preprocess
22
20
(per_module
23
21
((action
24
22
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))
25
23
uTop_complete
26
-
uTop)
27
-
((pps js_of_ocaml-ppx)
28
-
worker))))
24
+
uTop))))
25
+
26
+
(library
27
+
(public_name js_top_worker-web)
28
+
(name js_top_worker_web)
29
+
(modules worker)
30
+
(preprocess
31
+
(pps js_of_ocaml-ppx))
32
+
(libraries js_top_worker js_of_ocaml-toplevel logs.browser))
29
33
30
34
(ocamllex uTop_lexer)
+584
lib/impl.ml
+584
lib/impl.ml
···
1
+
(* Implementation *)
2
+
open Js_top_worker_rpc
3
+
module M = Idl.IdM (* Server is synchronous *)
4
+
module IdlM = Idl.Make (M)
5
+
6
+
type captured = { stdout : string; stderr : string }
7
+
8
+
module type S = sig
9
+
val capture : (unit -> 'a) -> unit -> captured * 'a
10
+
val create_file : name:string -> content:string -> unit
11
+
val sync_get : string -> string option
12
+
end
13
+
14
+
module Make (S : S) = struct
15
+
let functions : (unit -> unit) list option ref = ref None
16
+
let path : string option ref = ref None
17
+
18
+
let refill_lexbuf s p ppf buffer len =
19
+
if !p = String.length s then 0
20
+
else
21
+
let len', nl =
22
+
try (String.index_from s !p '\n' - !p + 1, false)
23
+
with _ -> (String.length s - !p, true)
24
+
in
25
+
let len'' = min len len' in
26
+
String.blit s !p buffer 0 len'';
27
+
(match ppf with
28
+
| Some ppf ->
29
+
Format.fprintf ppf "%s" (Bytes.sub_string buffer 0 len'');
30
+
if nl then Format.pp_print_newline ppf ();
31
+
Format.pp_print_flush ppf ()
32
+
| None -> ());
33
+
p := !p + len'';
34
+
len''
35
+
36
+
(* RPC function implementations *)
37
+
38
+
(* These are all required to return the appropriate value for the API within the
39
+
[IdlM.T] monad. The simplest way to do this is to use [IdlM.ErrM.return] for
40
+
the success case and [IdlM.ErrM.return_err] for the failure case *)
41
+
42
+
let exec' s =
43
+
S.capture
44
+
(fun () ->
45
+
let res : bool = Toploop.use_silently Format.std_formatter (String s) in
46
+
if not res then Format.eprintf "error while evaluating %s@." s)
47
+
()
48
+
49
+
let setup functions () =
50
+
let stdout_buff = Buffer.create 100 in
51
+
let stderr_buff = Buffer.create 100 in
52
+
53
+
let combine o =
54
+
Buffer.add_string stdout_buff o.stdout;
55
+
Buffer.add_string stderr_buff o.stderr
56
+
in
57
+
58
+
let exec' s =
59
+
let o, () = exec' s in
60
+
combine o
61
+
in
62
+
Logs.info (fun m -> m "Setting up toplevel");
63
+
Sys.interactive := false;
64
+
Logs.info (fun m -> m "Finished this bit 1");
65
+
66
+
Toploop.input_name := "//toplevel//";
67
+
Logs.info (fun m -> m "Finished this bit 2");
68
+
let path =
69
+
match !path with Some p -> p | None -> failwith "Path not set"
70
+
in
71
+
72
+
Topdirs.dir_directory path;
73
+
74
+
List.iter Topdirs.dir_directory [
75
+
"/Users/jonathanludlam/devel/learno/_opam/lib/note";
76
+
"/Users/jonathanludlam/devel/learno/_opam/lib/js_of_ocaml-compiler/runtime";
77
+
"/Users/jonathanludlam/devel/learno/_opam/lib/brr";
78
+
"/Users/jonathanludlam/devel/learno/_opam/lib/note/brr";
79
+
"/Users/jonathanludlam/devel/learno/codemirror3/odoc_notebook/_build/default/mime_printer/.mime_printer.objs/byte"
80
+
];
81
+
82
+
Logs.info (fun m -> m "Finished this bit 3");
83
+
Toploop.initialize_toplevel_env ();
84
+
Logs.info (fun m -> m "Finished this bit 4");
85
+
86
+
List.iter (fun f -> f ()) functions;
87
+
exec' "open Stdlib";
88
+
let header1 = Printf.sprintf " %s version %%s" "OCaml" in
89
+
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
90
+
exec' "#enable \"pretty\";;";
91
+
exec' "#disable \"shortvar\";;";
92
+
Sys.interactive := true;
93
+
Logs.info (fun m -> m "Setup complete");
94
+
{
95
+
stdout = Buffer.contents stdout_buff;
96
+
stderr = Buffer.contents stderr_buff;
97
+
}
98
+
99
+
let stdout_buff = Buffer.create 100
100
+
let stderr_buff = Buffer.create 100
101
+
102
+
let buff_opt b =
103
+
match String.trim (Buffer.contents b) with "" -> None | s -> Some s
104
+
105
+
let string_opt s = match String.trim s with "" -> None | s -> Some s
106
+
107
+
let loc = function
108
+
| Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
109
+
| Lexer.Error (_, loc)
110
+
| Typecore.Error (loc, _, _)
111
+
| Typetexp.Error (loc, _, _)
112
+
| Typeclass.Error (loc, _, _)
113
+
| Typemod.Error (loc, _, _)
114
+
| Typedecl.Error (loc, _)
115
+
| Translcore.Error (loc, _)
116
+
| Translclass.Error (loc, _)
117
+
| Translmod.Error (loc, _) ->
118
+
Some loc
119
+
| _ -> None
120
+
121
+
let execute printval ?pp_code ?highlight_location pp_answer s =
122
+
let lb = Lexing.from_function (refill_lexbuf s (ref 0) pp_code) in
123
+
(try
124
+
while true do
125
+
try
126
+
let phr = !Toploop.parse_toplevel_phrase lb in
127
+
ignore (Toploop.execute_phrase printval pp_answer phr : bool)
128
+
with
129
+
| End_of_file -> raise End_of_file
130
+
| x ->
131
+
(match highlight_location with
132
+
| None -> ()
133
+
| Some f -> ( match loc x with None -> () | Some loc -> f loc));
134
+
Errors.report_error Format.err_formatter x
135
+
done
136
+
with End_of_file -> ());
137
+
flush_all ()
138
+
139
+
let execute :
140
+
string ->
141
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) IdlM.T.resultb =
142
+
let code_buff = Buffer.create 100 in
143
+
let res_buff = Buffer.create 100 in
144
+
let pp_code = Format.formatter_of_buffer code_buff in
145
+
let pp_result = Format.formatter_of_buffer res_buff in
146
+
let highlighted = ref None in
147
+
let highlight_location loc =
148
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
149
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
150
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
151
+
in
152
+
fun phrase ->
153
+
Buffer.clear code_buff;
154
+
Buffer.clear code_buff;
155
+
Buffer.clear res_buff;
156
+
Buffer.clear stderr_buff;
157
+
Buffer.clear stdout_buff;
158
+
let o, () =
159
+
S.capture
160
+
(fun () -> execute true ~pp_code ~highlight_location pp_result phrase)
161
+
()
162
+
in
163
+
let mime_vals = Mime_printer.get () in
164
+
Format.pp_print_flush pp_code ();
165
+
Format.pp_print_flush pp_result ();
166
+
IdlM.ErrM.return
167
+
Toplevel_api_gen.
168
+
{
169
+
stdout = string_opt o.stdout;
170
+
stderr = string_opt o.stderr;
171
+
sharp_ppf = buff_opt code_buff;
172
+
caml_ppf = buff_opt res_buff;
173
+
highlight = !highlighted;
174
+
mime_vals;
175
+
}
176
+
177
+
let filename_of_module unit_name =
178
+
Printf.sprintf "%s.cmi" (String.uncapitalize_ascii unit_name)
179
+
180
+
let reset_dirs () =
181
+
Ocaml_utils.Directory_content_cache.clear ();
182
+
let open Ocaml_utils.Load_path in
183
+
let dirs = get_paths () in
184
+
reset ();
185
+
List.iter (fun p -> prepend_dir (Dir.create p)) dirs
186
+
187
+
let add_dynamic_cmis dcs =
188
+
let open Ocaml_typing.Persistent_env.Persistent_signature in
189
+
let old_loader = !load in
190
+
191
+
let fetch filename =
192
+
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
193
+
S.sync_get url
194
+
in
195
+
let path =
196
+
match !path with Some p -> p | None -> failwith "Path not set"
197
+
in
198
+
199
+
List.iter
200
+
(fun name ->
201
+
let filename = filename_of_module name in
202
+
match fetch (filename_of_module name) with
203
+
| Some content ->
204
+
let name = Filename.(concat path filename) in
205
+
S.create_file ~name ~content
206
+
| None -> ())
207
+
dcs.dcs_toplevel_modules;
208
+
209
+
let new_load ~unit_name =
210
+
let filename = filename_of_module unit_name in
211
+
212
+
let fs_name = Filename.(concat path filename) in
213
+
(* Check if it's already been downloaded. This will be the
214
+
case for all toplevel cmis. Also check whether we're supposed
215
+
to handle this cmi *)
216
+
(if
217
+
(not (Sys.file_exists fs_name))
218
+
&& List.exists
219
+
(fun prefix -> String.starts_with ~prefix filename)
220
+
dcs.dcs_file_prefixes
221
+
then
222
+
match fetch filename with
223
+
| Some x ->
224
+
S.create_file ~name:fs_name ~content:x;
225
+
(* At this point we need to tell merlin that the dir contents
226
+
have changed *)
227
+
reset_dirs ()
228
+
| None ->
229
+
Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
230
+
(Filename.concat dcs.Toplevel_api_gen.dcs_url filename));
231
+
old_loader ~unit_name
232
+
in
233
+
load := new_load
234
+
235
+
let init (init_libs : Toplevel_api_gen.init_libs) =
236
+
try
237
+
Logs.info (fun m -> m "init()");
238
+
path := Some init_libs.path;
239
+
240
+
Clflags.no_check_prims := true;
241
+
List.iter
242
+
(fun { Toplevel_api_gen.sc_name; sc_content } ->
243
+
let filename =
244
+
Printf.sprintf "%s.cmi" (String.uncapitalize_ascii sc_name)
245
+
in
246
+
let name = Filename.(concat init_libs.path filename) in
247
+
S.create_file ~name ~content:sc_content)
248
+
init_libs.cmis.static_cmis;
249
+
Option.iter add_dynamic_cmis init_libs.cmis.dynamic_cmis;
250
+
251
+
(*import_scripts
252
+
(List.map (fun cma -> cma.Toplevel_api_gen.url) init_libs.cmas);
253
+
functions :=
254
+
Some
255
+
(List.map
256
+
(fun func_name ->
257
+
Logs.info (fun m -> m "Function: %s" func_name);
258
+
let func = Js.Unsafe.js_expr func_name in
259
+
fun () ->
260
+
Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |])
261
+
(List.map (fun cma -> cma.Toplevel_api_gen.fn) init_libs.cmas)); *)
262
+
functions := Some [];
263
+
Logs.info (fun m -> m "init() finished");
264
+
265
+
IdlM.ErrM.return ()
266
+
with e ->
267
+
IdlM.ErrM.return_err
268
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
269
+
270
+
let setup () =
271
+
try
272
+
Logs.info (fun m -> m "setup()");
273
+
274
+
let o =
275
+
match !functions with
276
+
| Some l -> setup l ()
277
+
| None -> failwith "Error: toplevel has not been initialised"
278
+
in
279
+
IdlM.ErrM.return
280
+
Toplevel_api_gen.
281
+
{
282
+
stdout = string_opt o.stdout;
283
+
stderr = string_opt o.stderr;
284
+
sharp_ppf = None;
285
+
caml_ppf = None;
286
+
highlight = None;
287
+
mime_vals = [];
288
+
}
289
+
with e ->
290
+
IdlM.ErrM.return_err
291
+
(Toplevel_api_gen.InternalError (Printexc.to_string e))
292
+
293
+
let complete _phrase = failwith "Not implemented"
294
+
295
+
let typecheck_phrase :
296
+
string ->
297
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) IdlM.T.resultb =
298
+
let res_buff = Buffer.create 100 in
299
+
let pp_result = Format.formatter_of_buffer res_buff in
300
+
let highlighted = ref None in
301
+
let highlight_location loc =
302
+
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
303
+
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
304
+
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
305
+
in
306
+
fun phr ->
307
+
Buffer.clear res_buff;
308
+
Buffer.clear stderr_buff;
309
+
Buffer.clear stdout_buff;
310
+
try
311
+
let lb = Lexing.from_function (refill_lexbuf phr (ref 0) None) in
312
+
let phr = !Toploop.parse_toplevel_phrase lb in
313
+
let phr = Toploop.preprocess_phrase pp_result phr in
314
+
match phr with
315
+
| Parsetree.Ptop_def sstr ->
316
+
let oldenv = !Toploop.toplevel_env in
317
+
Typecore.reset_delayed_checks ();
318
+
let str, sg, sn, _, newenv =
319
+
Typemod.type_toplevel_phrase oldenv sstr
320
+
in
321
+
let sg' = Typemod.Signature_names.simplify newenv sn sg in
322
+
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
323
+
Typecore.force_delayed_checks ();
324
+
Printtyped.implementation pp_result str;
325
+
Format.pp_print_flush pp_result ();
326
+
Warnings.check_fatal ();
327
+
flush_all ();
328
+
IdlM.ErrM.return
329
+
Toplevel_api_gen.
330
+
{
331
+
stdout = buff_opt stdout_buff;
332
+
stderr = buff_opt stderr_buff;
333
+
sharp_ppf = None;
334
+
caml_ppf = buff_opt res_buff;
335
+
highlight = !highlighted;
336
+
mime_vals = [];
337
+
}
338
+
| _ -> failwith "Typechecking"
339
+
with x ->
340
+
(match loc x with None -> () | Some loc -> highlight_location loc);
341
+
Errors.report_error Format.err_formatter x;
342
+
IdlM.ErrM.return
343
+
Toplevel_api_gen.
344
+
{
345
+
stdout = buff_opt stdout_buff;
346
+
stderr = buff_opt stderr_buff;
347
+
sharp_ppf = None;
348
+
caml_ppf = buff_opt res_buff;
349
+
highlight = !highlighted;
350
+
mime_vals = [];
351
+
}
352
+
353
+
let split_primitives p =
354
+
let len = String.length p in
355
+
let rec split beg cur =
356
+
if cur >= len then []
357
+
else if Char.equal p.[cur] '\000' then
358
+
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
359
+
else split beg (cur + 1)
360
+
in
361
+
Array.of_list (split 0 0)
362
+
363
+
let compile_js id prog =
364
+
let open Js_of_ocaml_compiler in
365
+
let open Js_of_ocaml_compiler.Stdlib in
366
+
try
367
+
let str = Printf.sprintf "let _ = Mime_printer.id := \"%s\"\n%s" id prog in
368
+
let l = Lexing.from_string str in
369
+
let phr = Parse.toplevel_phrase l in
370
+
Typecore.reset_delayed_checks ();
371
+
Env.reset_cache_toplevel ();
372
+
let oldenv = !Toploop.toplevel_env in
373
+
(* let oldenv = Compmisc.initial_env() in *)
374
+
match phr with
375
+
| Ptop_def sstr ->
376
+
let str, sg, sn, _shape, newenv =
377
+
try Typemod.type_toplevel_phrase oldenv sstr
378
+
with Env.Error e ->
379
+
Env.report_error Format.err_formatter e;
380
+
exit 1
381
+
in
382
+
let sg' = Typemod.Signature_names.simplify newenv sn sg in
383
+
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
384
+
Typecore.force_delayed_checks ();
385
+
let lam = Translmod.transl_toplevel_definition str in
386
+
let slam = Simplif.simplify_lambda lam in
387
+
let init_code, fun_code = Bytegen.compile_phrase slam in
388
+
let code, reloc, _events = Emitcode.to_memory init_code fun_code in
389
+
Toploop.toplevel_env := newenv;
390
+
(* let prims = split_primitives (Symtable.data_primitive_names ()) in *)
391
+
let b = Buffer.create 100 in
392
+
let cmo =
393
+
Cmo_format.
394
+
{
395
+
cu_name = "test";
396
+
cu_pos = 0;
397
+
cu_codesize = Misc.LongString.length code;
398
+
cu_reloc = reloc;
399
+
cu_imports = [];
400
+
cu_required_globals = [];
401
+
cu_primitives = [];
402
+
cu_force_link = false;
403
+
cu_debug = 0;
404
+
cu_debugsize = 0;
405
+
}
406
+
in
407
+
let fmt = Pretty_print.to_buffer b in
408
+
(* Symtable.patch_object code reloc;
409
+
Symtable.check_global_initialized reloc;
410
+
Symtable.update_global_table(); *)
411
+
let oc = open_out "/tmp/test.cmo" in
412
+
Misc.LongString.output oc code 0 (Misc.LongString.length code);
413
+
414
+
(* let code = String.init (Misc.LongString.length code) ~f:(fun i -> Misc.LongString.get code i) in *)
415
+
close_out oc;
416
+
Driver.configure fmt;
417
+
let ic = open_in "/tmp/test.cmo" in
418
+
let p = Parse_bytecode.from_cmo cmo ic in
419
+
Driver.f' ~standalone:false ~wrap_with_fun:(`Named id) ~linkall:false
420
+
fmt p.debug p.code;
421
+
Format.(pp_print_flush std_formatter ());
422
+
Format.(pp_print_flush err_formatter ());
423
+
flush stdout;
424
+
flush stderr;
425
+
let js = Buffer.contents b in
426
+
IdlM.ErrM.return js
427
+
| _ -> IdlM.ErrM.return_err (Toplevel_api_gen.InternalError "Parse error")
428
+
with e -> IdlM.ErrM.return ("Exception: %s" ^ Printexc.to_string e)
429
+
430
+
let config () =
431
+
let path =
432
+
match !path with Some p -> p | None -> failwith "Path not set"
433
+
in
434
+
let initial = Merlin_kernel.Mconfig.initial in
435
+
{ initial with merlin = { initial.merlin with stdlib = Some path } }
436
+
437
+
let make_pipeline source = Merlin_kernel.Mpipeline.make (config ()) source
438
+
439
+
let wdispatch source query =
440
+
let pipeline = make_pipeline source in
441
+
Merlin_kernel.Mpipeline.with_pipeline pipeline @@ fun () ->
442
+
Query_commands.dispatch pipeline query
443
+
444
+
module Completion = struct
445
+
open Merlin_utils
446
+
open Std
447
+
open Merlin_kernel
448
+
449
+
(* Prefixing code from ocaml-lsp-server *)
450
+
let rfindi =
451
+
let rec loop s ~f i =
452
+
if i < 0 then None
453
+
else if f (String.unsafe_get s i) then Some i
454
+
else loop s ~f (i - 1)
455
+
in
456
+
fun ?from s ~f ->
457
+
let from =
458
+
let len = String.length s in
459
+
match from with
460
+
| None -> len - 1
461
+
| Some i ->
462
+
if i > len - 1 then
463
+
raise @@ Invalid_argument "rfindi: invalid from"
464
+
else i
465
+
in
466
+
loop s ~f from
467
+
468
+
let lsplit2 s ~on =
469
+
match String.index_opt s on with
470
+
| None -> None
471
+
| Some i ->
472
+
let open StdLabels.String in
473
+
Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
474
+
475
+
(** @see <https://ocaml.org/manual/lex.html> reference *)
476
+
let prefix_of_position ?(short_path = false) source position =
477
+
match Msource.text source with
478
+
| "" -> ""
479
+
| text ->
480
+
let from =
481
+
let (`Offset index) = Msource.get_offset source position in
482
+
min (String.length text - 1) (index - 1)
483
+
in
484
+
let pos =
485
+
let should_terminate = ref false in
486
+
let has_seen_dot = ref false in
487
+
let is_prefix_char c =
488
+
if !should_terminate then false
489
+
else
490
+
match c with
491
+
| 'a' .. 'z'
492
+
| 'A' .. 'Z'
493
+
| '0' .. '9'
494
+
| '\'' | '_'
495
+
(* Infix function characters *)
496
+
| '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>' | '@' | '^'
497
+
| '!' | '?' | '%' | '<' | ':' | '~' | '#' ->
498
+
true
499
+
| '`' ->
500
+
if !has_seen_dot then false
501
+
else (
502
+
should_terminate := true;
503
+
true)
504
+
| '.' ->
505
+
has_seen_dot := true;
506
+
not short_path
507
+
| _ -> false
508
+
in
509
+
rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
510
+
in
511
+
let pos = match pos with None -> 0 | Some pos -> pos + 1 in
512
+
let len = from - pos + 1 in
513
+
let reconstructed_prefix = StdLabels.String.sub text ~pos ~len in
514
+
(* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
515
+
[ignore], so: *)
516
+
if
517
+
String.is_prefixed ~by:"~" reconstructed_prefix
518
+
|| String.is_prefixed ~by:"?" reconstructed_prefix
519
+
then
520
+
match lsplit2 reconstructed_prefix ~on:':' with
521
+
| Some (_, s) -> s
522
+
| None -> reconstructed_prefix
523
+
else reconstructed_prefix
524
+
525
+
let at_pos source position =
526
+
let prefix = prefix_of_position source position in
527
+
let (`Offset to_) = Msource.get_offset source position in
528
+
let from =
529
+
to_
530
+
- String.length (prefix_of_position ~short_path:true source position)
531
+
in
532
+
if prefix = "" then None
533
+
else
534
+
let query =
535
+
Query_protocol.Complete_prefix (prefix, position, [], true, true)
536
+
in
537
+
Some (from, to_, wdispatch source query)
538
+
end
539
+
540
+
let complete_prefix source position =
541
+
let source = Merlin_kernel.Msource.make source in
542
+
match Completion.at_pos source position with
543
+
| Some (from, to_, compl) ->
544
+
let entries = compl.entries in
545
+
IdlM.ErrM.return { Toplevel_api_gen.from; to_; entries }
546
+
| None ->
547
+
IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
548
+
549
+
let query_errors source =
550
+
let source = Merlin_kernel.Msource.make source in
551
+
let query =
552
+
Query_protocol.Errors { lexing = true; parsing = true; typing = true }
553
+
in
554
+
let errors =
555
+
wdispatch source query
556
+
|> StdLabels.List.map
557
+
~f:(fun
558
+
(Ocaml_parsing.Location.{ kind; main = _; sub; source } as error)
559
+
->
560
+
let of_sub sub =
561
+
Ocaml_parsing.Location.print_sub_msg Format.str_formatter sub;
562
+
String.trim (Format.flush_str_formatter ())
563
+
in
564
+
let loc = Ocaml_parsing.Location.loc_of_report error in
565
+
let main =
566
+
Format.asprintf "@[%a@]" Ocaml_parsing.Location.print_main error
567
+
|> String.trim
568
+
in
569
+
{
570
+
Toplevel_api_gen.kind;
571
+
loc;
572
+
main;
573
+
sub = StdLabels.List.map ~f:of_sub sub;
574
+
source;
575
+
})
576
+
in
577
+
IdlM.ErrM.return errors
578
+
579
+
let type_enclosing source position =
580
+
let source = Merlin_kernel.Msource.make source in
581
+
let query = Query_protocol.Type_enclosing (None, position, None) in
582
+
let enclosing = wdispatch source query in
583
+
IdlM.ErrM.return enclosing
584
+
end
+9
-10
lib/uTop.mli
+9
-10
lib/uTop.mli
···
21
21
(** {6 Parsing} *)
22
22
23
23
type location = int * int
24
-
(** Type of a string-location. It is composed of a start and stop
24
+
(** Type of a string-location. It is composed of a start and stop
25
25
offsets (in bytes). *)
26
26
27
-
type lines = {
28
-
start: int;
29
-
stop: int;
30
-
}
31
-
(** Type for a range of lines in a buffer from start to stop. *)
27
+
type lines = { start : int; stop : int }
28
+
(** Type for a range of lines in a buffer from start to stop. *)
32
29
33
30
(** Result of a function processing a programx. *)
34
31
type 'a result =
···
80
77
(** [get_message printer x] applies [printer] on [x] and returns everything it
81
78
prints as a string. *)
82
79
83
-
val get_ocaml_error_message : exn -> location * string * (lines option)
84
-
(** [get_ocaml_error_message exn] returns the location and error
80
+
val get_ocaml_error_message : exn -> location * string * lines option
81
+
(** [get_ocaml_error_message exn] returns the location and error
85
82
message for the exception [exn] which must be an exception from
86
83
the compiler. *)
87
84
88
-
val check_phrase : Parsetree.toplevel_phrase -> (location list * string * lines option list) option
89
-
(** [check_phrase phrase] checks that [phrase] can be executed
85
+
val check_phrase :
86
+
Parsetree.toplevel_phrase ->
87
+
(location list * string * lines option list) option
88
+
(** [check_phrase phrase] checks that [phrase] can be executed
90
89
without typing or compilation errors. It returns [None] if
91
90
[phrase] is OK and an error message otherwise.
92
91
If the result is [None] it is guaranteed that
-397
lib/worker.cppo.ml
-397
lib/worker.cppo.ml
···
1
-
open Js_of_ocaml_toplevel
2
-
open Js_top_worker_rpc
3
-
4
-
let optbind : 'a option -> ('a -> 'b option) -> 'b option = fun x fn -> match x with | None -> None | Some a -> fn a
5
-
6
-
let log fmt =
7
-
Format.kasprintf
8
-
(fun s -> Js_of_ocaml.(Firebug.console##log (Js.string s)))
9
-
fmt
10
-
11
-
(* OCamlorg toplevel in a web worker
12
-
13
-
This communicates with the toplevel code via the API defined in
14
-
{!Toplevel_api}. This allows the OCaml execution to not block the "main
15
-
thread" keeping the page responsive. *)
16
-
17
-
module Version = struct
18
-
type t = int list
19
-
20
-
let split_char ~sep p =
21
-
let len = String.length p in
22
-
let rec split beg cur =
23
-
if cur >= len then
24
-
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
25
-
else if sep p.[cur] then
26
-
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
27
-
else split beg (cur + 1)
28
-
in
29
-
split 0 0
30
-
31
-
let split v =
32
-
match
33
-
split_char ~sep:(function '+' | '-' | '~' -> true | _ -> false) v
34
-
with
35
-
| [] -> assert false
36
-
| x :: _ ->
37
-
List.map int_of_string
38
-
(split_char ~sep:(function '.' -> true | _ -> false) x)
39
-
40
-
let current = split Sys.ocaml_version
41
-
let compint (a : int) b = compare a b
42
-
43
-
let rec compare v v' =
44
-
match (v, v') with
45
-
| [ x ], [ y ] -> compint x y
46
-
| [], [] -> 0
47
-
| [], y :: _ -> compint 0 y
48
-
| x :: _, [] -> compint x 0
49
-
| x :: xs, y :: ys -> (
50
-
match compint x y with 0 -> compare xs ys | n -> n)
51
-
end
52
-
53
-
let exec' s =
54
-
let res : bool = JsooTop.use Format.std_formatter s in
55
-
if not res then Format.eprintf "error while evaluating %s@." s
56
-
57
-
let setup functions () =
58
-
JsooTop.initialize ();
59
-
List.iter (fun f -> f ()) functions;
60
-
Sys.interactive := false;
61
-
if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
62
-
let header1 = Printf.sprintf " %s version %%s" "OCaml" in
63
-
let header2 =
64
-
Printf.sprintf " Compiled with Js_of_ocaml version %s"
65
-
Js_of_ocaml.Sys_js.js_of_ocaml_version
66
-
in
67
-
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
68
-
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
69
-
exec' "#enable \"pretty\";;";
70
-
exec' "#disable \"shortvar\";;";
71
-
Toploop.add_directive "load_js"
72
-
(Toploop.Directive_string
73
-
(fun name -> Js_of_ocaml.Js.Unsafe.global##load_script_ name))
74
-
Toploop.{ section = ""; doc = "Load a javascript script" };
75
-
Sys.interactive := true;
76
-
()
77
-
78
-
let setup_printers () =
79
-
exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
80
-
Topdirs.dir_install_printer Format.std_formatter
81
-
Longident.(Lident "_print_unit")
82
-
83
-
let stdout_buff = Buffer.create 100
84
-
let stderr_buff = Buffer.create 100
85
-
86
-
(* RPC function implementations *)
87
-
88
-
module M = Idl.IdM (* Server is synchronous *)
89
-
90
-
module IdlM = Idl.Make (M)
91
-
module Server = Toplevel_api_gen.Make (IdlM.GenServer ())
92
-
93
-
(* These are all required to return the appropriate value for the API within the
94
-
[IdlM.T] monad. The simplest way to do this is to use [IdlM.ErrM.return] for
95
-
the success case and [IdlM.ErrM.return_err] for the failure case *)
96
-
97
-
let buff_opt b = match Buffer.contents b with "" -> None | s -> Some s
98
-
99
-
let execute =
100
-
let code_buff = Buffer.create 100 in
101
-
let res_buff = Buffer.create 100 in
102
-
let pp_code = Format.formatter_of_buffer code_buff in
103
-
let pp_result = Format.formatter_of_buffer res_buff in
104
-
let highlighted = ref None in
105
-
let highlight_location loc =
106
-
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
107
-
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
108
-
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
109
-
in
110
-
fun phrase ->
111
-
Buffer.clear code_buff;
112
-
Buffer.clear res_buff;
113
-
Buffer.clear stderr_buff;
114
-
Buffer.clear stdout_buff;
115
-
JsooTop.execute true ~pp_code ~highlight_location pp_result phrase;
116
-
let mime_vals = Mime_printer.get () in
117
-
Format.pp_print_flush pp_code ();
118
-
Format.pp_print_flush pp_result ();
119
-
IdlM.ErrM.return
120
-
Toplevel_api_gen.
121
-
{
122
-
stdout = buff_opt stdout_buff;
123
-
stderr = buff_opt stderr_buff;
124
-
sharp_ppf = buff_opt code_buff;
125
-
caml_ppf = buff_opt res_buff;
126
-
highlight = !highlighted;
127
-
mime_vals;
128
-
}
129
-
130
-
let sync_get url =
131
-
let open Js_of_ocaml in
132
-
let x = XmlHttpRequest.create () in
133
-
x##.responseType := Js.string "arraybuffer";
134
-
x##_open (Js.string "GET") (Js.string url) Js._false;
135
-
x##send Js.null;
136
-
match x##.status with
137
-
| 200 ->
138
-
Js.Opt.case
139
-
(File.CoerceTo.arrayBuffer x##.response)
140
-
(fun () ->
141
-
Firebug.console##log (Js.string "Failed to receive file");
142
-
None)
143
-
(fun b -> Some (Typed_array.String.of_arrayBuffer b))
144
-
| _ -> None
145
-
146
-
type signature = Types.signature_item list
147
-
type flags = Cmi_format.pers_flags list
148
-
type header = string * signature
149
-
type crcs = (string * Digest.t option) list
150
-
151
-
(** The following two functions are taken from cmi_format.ml in
152
-
the compiler, but changed to work on bytes rather than input
153
-
channels *)
154
-
let input_cmi str =
155
-
let offset = 0 in
156
-
let (name, sign) = (Marshal.from_bytes str offset : header) in
157
-
let offset = offset + Marshal.total_size str offset in
158
-
let crcs = (Marshal.from_bytes str offset : crcs) in
159
-
let offset = offset + Marshal.total_size str offset in
160
-
let flags = (Marshal.from_bytes str offset : flags) in
161
-
{
162
-
Cmi_format.cmi_name = name;
163
-
cmi_sign = sign;
164
-
cmi_crcs = crcs;
165
-
cmi_flags = flags;
166
-
}
167
-
168
-
let read_cmi filename str =
169
-
let magic_len = String.length Config.cmi_magic_number in
170
-
let buffer = Bytes.sub str 0 magic_len in
171
-
(if buffer <> Bytes.of_string Config.cmi_magic_number then
172
-
let pre_len = String.length Config.cmi_magic_number - 3 in
173
-
if
174
-
Bytes.sub buffer 0 pre_len
175
-
= Bytes.of_string @@ String.sub Config.cmi_magic_number 0 pre_len
176
-
then
177
-
let msg =
178
-
if buffer < Bytes.of_string Config.cmi_magic_number then "an older"
179
-
else "a newer"
180
-
in
181
-
raise (Cmi_format.Error (Wrong_version_interface (filename, msg)))
182
-
else raise (Cmi_format.Error (Not_an_interface filename)));
183
-
input_cmi (Bytes.sub str magic_len (Bytes.length str - magic_len))
184
-
185
-
let functions : (unit -> unit) list option ref = ref None
186
-
187
-
let init (init_libs : Toplevel_api_gen.init_libs) =
188
-
let open Js_of_ocaml in
189
-
try
190
-
Clflags.no_check_prims := true;
191
-
let cmi_files =
192
-
List.map
193
-
(fun cmi -> (Filename.basename cmi |> Filename.chop_extension, cmi))
194
-
init_libs.cmi_urls
195
-
in
196
-
#if OCAML_VERSION < (4,9,0)
197
-
let open Env.Persistent_signature in
198
-
#else
199
-
let open Persistent_env.Persistent_signature in
200
-
#endif
201
-
let old_loader = !load in
202
-
(load :=
203
-
fun ~unit_name ->
204
-
let result =
205
-
optbind
206
-
(try Some (List.assoc (String.uncapitalize_ascii unit_name) cmi_files) with _ -> None)
207
-
sync_get
208
-
in
209
-
match result with
210
-
| Some x ->
211
-
Some
212
-
{
213
-
filename =
214
-
Sys.executable_name;
215
-
cmi = read_cmi unit_name (Bytes.of_string x);
216
-
}
217
-
| _ -> old_loader ~unit_name);
218
-
Js_of_ocaml.Worker.import_scripts
219
-
(List.map (fun cma -> cma.Toplevel_api_gen.url) init_libs.cmas);
220
-
functions :=
221
-
Some
222
-
(List.map
223
-
(fun func_name ->
224
-
Firebug.console##log (Js.string ("Function: " ^ func_name));
225
-
let func = Js.Unsafe.js_expr func_name in
226
-
fun () ->
227
-
Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |])
228
-
(List.map (fun cma -> cma.Toplevel_api_gen.fn) init_libs.cmas));
229
-
IdlM.ErrM.return ()
230
-
with e ->
231
-
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))
232
-
233
-
let setup () =
234
-
let open Js_of_ocaml in
235
-
try
236
-
Sys_js.set_channel_flusher stdout (Buffer.add_string stdout_buff);
237
-
Sys_js.set_channel_flusher stderr (Buffer.add_string stderr_buff);
238
-
(match !functions with
239
-
| Some l -> setup l ()
240
-
| None -> failwith "Error: toplevel has not been initialised");
241
-
setup_printers ();
242
-
IdlM.ErrM.return
243
-
Toplevel_api_gen.
244
-
{
245
-
stdout = buff_opt stdout_buff;
246
-
stderr = buff_opt stderr_buff;
247
-
sharp_ppf = None;
248
-
caml_ppf = None;
249
-
highlight = None;
250
-
mime_vals = [];
251
-
}
252
-
with e ->
253
-
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))
254
-
255
-
let complete phrase =
256
-
let contains_double_underscore s =
257
-
let len = String.length s in
258
-
let rec aux i =
259
-
if i > len - 2 then false
260
-
else if s.[i] = '_' && s.[i + 1] = '_' then true
261
-
else aux (i + 1)
262
-
in
263
-
aux 0
264
-
in
265
-
let n, res = UTop_complete.complete ~phrase_terminator:";;" ~input:phrase in
266
-
let res =
267
-
List.filter (fun (l, _) -> not (contains_double_underscore l)) res
268
-
in
269
-
let completions = List.map fst res in
270
-
IdlM.ErrM.return Toplevel_api_gen.{ n; completions }
271
-
272
-
let server process e =
273
-
log "Worker received: %s" e;
274
-
let (_, id, call) = Jsonrpc.version_id_and_call_of_string e in
275
-
M.bind (process call) (fun 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);
279
-
()
280
-
281
-
let loc = function
282
-
| Syntaxerr.Error x ->
283
-
Some (Syntaxerr.location_of_error x)
284
-
| Lexer.Error (_, loc)
285
-
| Typecore.Error (loc, _, _)
286
-
| Typetexp.Error (loc, _, _)
287
-
| Typeclass.Error (loc, _, _)
288
-
| Typemod.Error (loc, _, _)
289
-
| Typedecl.Error (loc, _)
290
-
| Translcore.Error (loc, _)
291
-
| Translclass.Error (loc, _)
292
-
| Translmod.Error (loc, _) ->
293
-
Some loc
294
-
| _ ->
295
-
None
296
-
297
-
let refill_lexbuf s p ppf buffer len =
298
-
if !p = String.length s then
299
-
0
300
-
else
301
-
let len', nl =
302
-
try String.index_from s !p '\n' - !p + 1, false with
303
-
| _ ->
304
-
String.length s - !p, true
305
-
in
306
-
let len'' = min len len' in
307
-
String.blit s !p buffer 0 len'';
308
-
(match ppf with
309
-
| Some ppf ->
310
-
Format.fprintf ppf "%s" (Bytes.sub_string buffer 0 len'');
311
-
if nl then Format.pp_print_newline ppf ();
312
-
Format.pp_print_flush ppf ()
313
-
| None ->
314
-
());
315
-
p := !p + len'';
316
-
len''
317
-
318
-
let typecheck_phrase =
319
-
let res_buff = Buffer.create 100 in
320
-
let pp_result = Format.formatter_of_buffer res_buff in
321
-
let highlighted = ref None in
322
-
let highlight_location loc =
323
-
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
324
-
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
325
-
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
326
-
in
327
-
fun phr ->
328
-
Buffer.clear res_buff;
329
-
Buffer.clear stderr_buff;
330
-
Buffer.clear stdout_buff;
331
-
try
332
-
let lb = Lexing.from_function (refill_lexbuf phr (ref 0) None) in
333
-
let phr = !Toploop.parse_toplevel_phrase lb in
334
-
let phr = Toploop.preprocess_phrase pp_result phr in
335
-
match phr with
336
-
| Parsetree.Ptop_def sstr ->
337
-
let oldenv = !Toploop.toplevel_env in
338
-
Typecore.reset_delayed_checks ();
339
-
#if OCAML_VERSION >= (4,8,0) && OCAML_VERSION < (4,14,0)
340
-
let str, sg, sn, newenv = Typemod.type_toplevel_phrase oldenv sstr in
341
-
let sg' = Typemod.Signature_names.simplify newenv sn sg in
342
-
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
343
-
#elif OCAML_VERSION >= (4,14,0)
344
-
let str, sg, sn, _, newenv = Typemod.type_toplevel_phrase oldenv sstr in
345
-
let sg' = Typemod.Signature_names.simplify newenv sn sg in
346
-
ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg');
347
-
#else
348
-
let str, sg, newenv = Typemod.type_toplevel_phrase oldenv sstr in
349
-
let sg' = Typemod.simplify_signature sg in
350
-
ignore (Includemod.signatures oldenv sg sg');
351
-
#endif
352
-
Typecore.force_delayed_checks ();
353
-
Printtyped.implementation pp_result str;
354
-
Format.pp_print_flush pp_result ();
355
-
Warnings.check_fatal ();
356
-
flush_all ();
357
-
IdlM.ErrM.return
358
-
Toplevel_api_gen.
359
-
{ stdout = buff_opt stdout_buff
360
-
; stderr = buff_opt stderr_buff
361
-
; sharp_ppf = None
362
-
; caml_ppf = buff_opt res_buff
363
-
; highlight = !highlighted
364
-
; mime_vals = []
365
-
}
366
-
| _ ->
367
-
failwith "Typechecking"
368
-
with
369
-
| x ->
370
-
(match loc x with None -> () | Some loc -> highlight_location loc);
371
-
Errors.report_error Format.err_formatter x;
372
-
IdlM.ErrM.return
373
-
Toplevel_api_gen.
374
-
{ stdout = buff_opt stdout_buff
375
-
; stderr = buff_opt stderr_buff
376
-
; sharp_ppf = None
377
-
; caml_ppf = buff_opt res_buff
378
-
; highlight = !highlighted
379
-
; mime_vals = []
380
-
}
381
-
382
-
let run () =
383
-
(* Here we bind the server stub functions to the implementations *)
384
-
let open Js_of_ocaml in
385
-
try
386
-
(Js_top_worker_rpc.Idl.logfn :=
387
-
fun s -> Js_of_ocaml.(Firebug.console##log s));
388
-
Server.complete complete;
389
-
Server.exec execute;
390
-
Server.setup setup;
391
-
Server.init init;
392
-
Server.typecheck typecheck_phrase;
393
-
let rpc_fn = IdlM.server Server.implementation in
394
-
Js_of_ocaml.Worker.set_onmessage (server rpc_fn);
395
-
Firebug.console##log (Js.string "All finished")
396
-
with e ->
397
-
Firebug.console##log (Js.string ("Exception: " ^ Printexc.to_string e))
+104
lib/worker.ml
+104
lib/worker.ml
···
1
+
open Js_top_worker_rpc
2
+
open Js_top_worker
3
+
4
+
let optbind : 'a option -> ('a -> 'b option) -> 'b option =
5
+
fun x fn -> match x with None -> None | Some a -> fn a
6
+
7
+
let log fmt =
8
+
Format.kasprintf
9
+
(fun s -> Js_of_ocaml.(Firebug.console##log (Js.string s)))
10
+
fmt
11
+
12
+
let sync_get url =
13
+
let open Js_of_ocaml in
14
+
let x = XmlHttpRequest.create () in
15
+
x##.responseType := Js.string "arraybuffer";
16
+
x##_open (Js.string "GET") (Js.string url) Js._false;
17
+
x##send Js.null;
18
+
match x##.status with
19
+
| 200 ->
20
+
Js.Opt.case
21
+
(File.CoerceTo.arrayBuffer x##.response)
22
+
(fun () ->
23
+
Firebug.console##log (Js.string "Failed to receive file");
24
+
None)
25
+
(fun b -> Some (Typed_array.String.of_arrayBuffer b))
26
+
| _ -> None
27
+
28
+
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
29
+
30
+
(* OCamlorg toplevel in a web worker
31
+
32
+
This communicates with the toplevel code via the API defined in
33
+
{!Toplevel_api}. This allows the OCaml execution to not block the "main
34
+
thread" keeping the page responsive. *)
35
+
36
+
let server process e =
37
+
log "Worker received: %s" e;
38
+
let _, id, call = Jsonrpc.version_id_and_call_of_string e in
39
+
Impl.M.bind (process call) (fun response ->
40
+
let rtxt = Jsonrpc.string_of_response ~id response in
41
+
log "Worker sending: %s" rtxt;
42
+
Js_of_ocaml.Worker.post_message rtxt;
43
+
Impl.M.return ())
44
+
45
+
let loc = function
46
+
| Syntaxerr.Error x -> Some (Syntaxerr.location_of_error x)
47
+
| Lexer.Error (_, loc)
48
+
| Typecore.Error (loc, _, _)
49
+
| Typetexp.Error (loc, _, _)
50
+
| Typeclass.Error (loc, _, _)
51
+
| Typemod.Error (loc, _, _)
52
+
| Typedecl.Error (loc, _)
53
+
| Translcore.Error (loc, _)
54
+
| Translclass.Error (loc, _)
55
+
| Translmod.Error (loc, _) ->
56
+
Some loc
57
+
| _ -> None
58
+
59
+
module S : Impl.S = struct
60
+
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
61
+
fun f () ->
62
+
let stdout_buff = Buffer.create 1024 in
63
+
let stderr_buff = Buffer.create 1024 in
64
+
Js_of_ocaml.Sys_js.set_channel_flusher stdout
65
+
(Buffer.add_string stdout_buff);
66
+
Js_of_ocaml.Sys_js.set_channel_flusher stderr
67
+
(Buffer.add_string stderr_buff);
68
+
let x = f () in
69
+
let captured =
70
+
{
71
+
Impl.stdout = Buffer.contents stdout_buff;
72
+
stderr = Buffer.contents stderr_buff;
73
+
}
74
+
in
75
+
(captured, x)
76
+
77
+
let sync_get = sync_get
78
+
let create_file = Js_of_ocaml.Sys_js.create_file
79
+
end
80
+
81
+
module M = Impl.Make (S)
82
+
83
+
let run () =
84
+
(* Here we bind the server stub functions to the implementations *)
85
+
let open Js_of_ocaml in
86
+
let open M in
87
+
try
88
+
Firebug.console##log (Js.string "Starting worker...");
89
+
90
+
Logs.set_reporter (Logs_browser.console_reporter ());
91
+
Logs.set_level (Some Logs.Info);
92
+
Server.exec execute;
93
+
Server.setup setup;
94
+
Server.init init;
95
+
Server.typecheck typecheck_phrase;
96
+
Server.complete_prefix complete_prefix;
97
+
Server.query_errors query_errors;
98
+
Server.type_enclosing type_enclosing;
99
+
Server.compile_js compile_js;
100
+
let rpc_fn = Impl.IdlM.server Server.implementation in
101
+
Js_of_ocaml.Worker.set_onmessage (fun x -> ignore (server rpc_fn x));
102
+
Firebug.console##log (Js.string "All finished")
103
+
with e ->
104
+
Firebug.console##log (Js.string ("Exception: " ^ Printexc.to_string e))