jon.recoil.org
this repo has no description
js_top_worker: remove RPC layer, use plain message protocol
The project migrated from rpclib/ppx_deriving_rpc JSON-RPC to a simple
message-passing protocol but the old RPC infrastructure remained wired
in. This removes it entirely (~5400 lines deleted):
- Move API types from Toplevel_api_gen into Impl, replace Rpc_lwt.ErrM
with plain Lwt + result
- Replace Jsonrpc/Rpcmarshal JSON serialization with Yojson.Safe
- Rewrite all tests to call Impl.Make(S) directly instead of via RPC
server/client roundtrip
- Rewrite examples and browser tests to use message protocol client
- Delete RPC source files, _old/ directory, and dead opam packages
- Remove rpclib dependencies from all dune and opam files
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+4
-5
CLAUDE.md
+4
-5
CLAUDE.md
···
39
39
40
40
- **js_top_worker**: Core library implementing the OCaml toplevel functionality
41
41
- **js_top_worker-web**: Web-specific worker implementation with browser integration
42
-
- **js_top_worker-client**: Client library for communicating with the worker (Lwt-based)
43
-
- **js_top_worker-client_fut**: Alternative client library using Fut for concurrency
44
-
- **js_top_worker-rpc**: RPC definitions and communication layer
42
+
- **js_top_worker-rpc.message**: Message protocol definitions for worker communication
43
+
- **js_top_worker-client.msg**: Client library for communicating with the worker (Lwt-based, message protocol)
45
44
- **js_top_worker-unix**: Unix implementation for testing outside the browser
46
45
- **js_top_worker-bin**: Command-line tools including `jtw` for package management
47
46
48
47
Key directories:
49
48
- `lib/`: Core toplevel implementation with OCaml compiler integration
50
-
- `idl/`: RPC interface definitions using `ppx_deriving_rpc`
49
+
- `idl/`: Message protocol definitions and client library
51
50
- `example/`: Example applications demonstrating worker usage
52
51
- `bin/`: Command-line tools, notably `jtw` for OPAM package handling
53
52
54
-
The system uses RPC (via `rpclib`) for communication between the client and worker, with support for both browser WebWorkers and Unix sockets for testing.
53
+
The system uses a simple JSON message protocol for communication between the client and worker, with support for both browser WebWorkers and Node.js for testing.
55
54
56
55
## Technical Q&A Log
57
56
+2
-2
bin/dune
+2
-2
bin/dune
+11
-6
bin/jtw.ml
+11
-6
bin/jtw.ml
···
1
+
let dynamic_cmis_to_json (dcs : Js_top_worker.Impl.dynamic_cmis) =
2
+
`Assoc [
3
+
("dcs_url", `String dcs.dcs_url);
4
+
("dcs_toplevel_modules", `List (List.map (fun s -> `String s) dcs.dcs_toplevel_modules));
5
+
("dcs_file_prefixes", `List (List.map (fun s -> `String s) dcs.dcs_file_prefixes));
6
+
]
7
+
1
8
(** Try to relativize a path against findlib_dir. If the result contains
2
9
".." (indicating the path is in a different tree), fall back to extracting
3
10
the path components after "lib" directory. *)
···
53
60
in
54
61
let dcs =
55
62
{
56
-
Js_top_worker_rpc.Toplevel_api_gen.dcs_url = Fpath.to_string dcs_url_path;
63
+
Js_top_worker.Impl.dcs_url = Fpath.to_string dcs_url_path;
57
64
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
58
65
dcs_file_prefixes = prefixes;
59
66
}
60
67
in
61
68
( dir,
62
-
Jsonrpc.to_string
63
-
(Rpcmarshal.marshal
64
-
Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis dcs) )
69
+
Yojson.Safe.to_string (dynamic_cmis_to_json dcs) )
65
70
in
66
71
List.map gen_one cmis
67
72
···
396
401
let d = relativize_or_fallback ~findlib_dir dir in
397
402
(* Include pkg_path in dcs_url so it's correct relative to the HTTP root *)
398
403
let dcs = {
399
-
Js_top_worker_rpc.Toplevel_api_gen.dcs_url = Fpath.(v pkg_path / "lib" // d |> to_string);
404
+
Js_top_worker.Impl.dcs_url = Fpath.(v pkg_path / "lib" // d |> to_string);
400
405
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
401
406
dcs_file_prefixes = prefixes;
402
407
} in
403
-
let dcs_json = Jsonrpc.to_string (Rpcmarshal.marshal Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis dcs) in
408
+
let dcs_json = Yojson.Safe.to_string (dynamic_cmis_to_json dcs) in
404
409
let dcs_dir = Fpath.(pkg_output_dir / "lib" // d) in
405
410
let _ = Bos.OS.Dir.create ~path:true dcs_dir in
406
411
let oc = open_out Fpath.(dcs_dir / "dynamic_cmis.json" |> to_string) in
+4
-39
example/dune
+4
-39
example/dune
···
4
4
(pps js_of_ocaml-ppx))
5
5
(modes js)
6
6
(modules example)
7
-
(libraries js_top_worker_client lwt js_of_ocaml))
7
+
(libraries js_top_worker_client_msg lwt js_of_ocaml))
8
8
9
9
(executable
10
10
(name example2)
···
12
12
(pps js_of_ocaml-ppx))
13
13
(modes js)
14
14
(modules example2)
15
-
(libraries js_top_worker_client lwt js_of_ocaml))
15
+
(libraries js_top_worker_client_msg lwt js_of_ocaml))
16
16
17
17
(executable
18
18
(name example3)
···
20
20
(pps js_of_ocaml-ppx))
21
21
(modes js)
22
22
(modules example3)
23
-
(libraries js_top_worker_client lwt js_of_ocaml))
23
+
(libraries js_top_worker_client_msg lwt js_of_ocaml))
24
24
25
25
(executable
26
26
(name example4)
···
28
28
(pps js_of_ocaml-ppx))
29
29
(modes js)
30
30
(modules example4)
31
-
(libraries js_top_worker_client lwt js_of_ocaml))
31
+
(libraries js_top_worker_client_msg lwt js_of_ocaml))
32
32
33
33
(executable
34
34
(name worker)
···
39
39
(javascript_files ../lib/stubs.js)
40
40
(flags --effects=disabled --toplevel --opt 3 +toplevel.js +dynlink.js))
41
41
(libraries js_top_worker-web logs.browser mime_printer tyxml))
42
-
43
-
(executable
44
-
(name rpc_worker)
45
-
(modes js)
46
-
(modules rpc_worker)
47
-
(link_flags (-linkall))
48
-
(preprocess (pps js_of_ocaml-ppx))
49
-
(js_of_ocaml
50
-
(javascript_files ../lib/stubs.js)
51
-
(flags --effects=disabled --toplevel --opt 3 +toplevel.js +dynlink.js))
52
-
(libraries js_top_worker js_top_worker-web js_top_worker-rpc logs.browser mime_printer tyxml))
53
-
54
-
(executable
55
-
(name unix_worker)
56
-
(public_name unix_worker)
57
-
(modes byte)
58
-
(package js_top_worker-unix)
59
-
(modules unix_worker)
60
-
(link_flags (-linkall))
61
-
(libraries
62
-
unix
63
-
js_top_worker
64
-
logs
65
-
logs.fmt
66
-
rpclib.core
67
-
rpclib.json
68
-
findlib.top
69
-
lwt.unix))
70
-
71
-
(executable
72
-
(name unix_client)
73
-
(public_name unix_client)
74
-
(package js_top_worker-unix)
75
-
(modules unix_client)
76
-
(libraries js_top_worker_client rpclib.cmdliner))
77
42
78
43
(rule
79
44
(targets
+14
-40
example/example.ml
+14
-40
example/example.ml
···
1
1
(* Simplest example *)
2
2
open Js_of_ocaml
3
-
open Js_top_worker_rpc
4
-
module W = Js_top_worker_client.W
3
+
module C = Js_top_worker_client_msg
4
+
module Msg = Js_top_worker_message.Message
5
5
6
6
let log s = Console.console##log (Js.string s)
7
7
8
-
let initialise s callback =
9
-
let ( let* ) = Lwt_result.bind in
10
-
let rpc = Js_top_worker_client.start s 100000 callback in
11
-
let* () =
12
-
W.init rpc
13
-
Toplevel_api_gen.
14
-
{
15
-
stdlib_dcs = None;
16
-
findlib_requires = [ "stringext" ];
17
-
findlib_index = None;
18
-
execute = true;
19
-
}
20
-
in
21
-
Lwt.return (Ok rpc)
22
-
23
-
let log_output (o : Toplevel_api_gen.exec_result) =
24
-
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
25
-
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
26
-
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
27
-
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
28
-
let strloc (line, col) =
29
-
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
30
-
in
31
-
Option.iter
32
-
(fun h ->
33
-
let open Toplevel_api_gen in
34
-
log
35
-
("highlight "
36
-
^ strloc (h.line1, h.col1)
37
-
^ " to "
38
-
^ strloc (h.line2, h.col2)))
39
-
o.highlight
8
+
let log_output (o : C.output) =
9
+
log ("stdout: " ^ o.stdout);
10
+
log ("stderr: " ^ o.stderr);
11
+
log ("caml_ppf: " ^ o.caml_ppf)
40
12
41
13
let _ =
42
-
let ( let* ) = Lwt_result.bind in
43
-
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
44
-
let* o = W.setup rpc "" in
14
+
let open Lwt.Infix in
15
+
let t = C.create ~timeout:100000 "_opam/worker.js" in
16
+
let config : Msg.init_config =
17
+
{ findlib_requires = [ "stringext" ]; stdlib_dcs = None; findlib_index = None }
18
+
in
19
+
C.init t config >>= fun () ->
20
+
C.eval t ~env_id:"default" "Stringext.of_list ['a';'b';'c'];;" >>= fun o ->
45
21
log_output o;
46
-
let* o = W.exec rpc "" "Stringext.of_list ['a';'b';'c'];;" in
47
-
log_output o;
48
-
Lwt.return (Ok ())
22
+
Lwt.return ()
+14
-35
example/example2.ml
+14
-35
example/example2.ml
···
1
1
(* Simplest example *)
2
2
open Js_of_ocaml
3
-
open Js_top_worker_rpc
4
-
module W = Js_top_worker_client.W
3
+
module C = Js_top_worker_client_msg
4
+
module Msg = Js_top_worker_message.Message
5
5
6
6
let log s = Console.console##log (Js.string s)
7
7
8
-
let initialise s callback =
9
-
let ( let* ) = Lwt_result.bind in
10
-
let rpc = Js_top_worker_client.start s 100000 callback in
11
-
let* () =
12
-
W.init rpc
13
-
Toplevel_api_gen.
14
-
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
-
in
16
-
Lwt.return (Ok rpc)
8
+
let log_output (o : C.output) =
9
+
log ("stdout: " ^ o.stdout);
10
+
log ("stderr: " ^ o.stderr);
11
+
log ("caml_ppf: " ^ o.caml_ppf)
17
12
18
-
let log_output (o : Toplevel_api_gen.exec_result) =
19
-
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
-
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
-
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
-
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
-
let strloc (line, col) =
24
-
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
13
+
let _ =
14
+
let open Lwt.Infix in
15
+
let t = C.create ~timeout:100000 "_opam/worker.js" in
16
+
let config : Msg.init_config =
17
+
{ findlib_requires = []; stdlib_dcs = None; findlib_index = None }
25
18
in
26
-
Option.iter
27
-
(fun h ->
28
-
let open Toplevel_api_gen in
29
-
log
30
-
("highlight "
31
-
^ strloc (h.line1, h.col1)
32
-
^ " to "
33
-
^ strloc (h.line2, h.col2)))
34
-
o.highlight
35
-
36
-
let _ =
37
-
let ( let* ) = Lwt_result.bind in
38
-
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
-
let* o = W.setup rpc "" in
40
-
log_output o;
41
-
let* o = W.exec rpc "" "2*2;;" in
19
+
C.init t config >>= fun () ->
20
+
C.eval t ~env_id:"default" "2*2;;" >>= fun o ->
42
21
log_output o;
43
-
Lwt.return (Ok ())
22
+
Lwt.return ()
+10
-39
example/example3.ml
+10
-39
example/example3.ml
···
1
1
(* Simplest example *)
2
2
open Js_of_ocaml
3
-
open Js_top_worker_rpc
4
-
module W = Js_top_worker_client.W
3
+
module C = Js_top_worker_client_msg
4
+
module Msg = Js_top_worker_message.Message
5
5
6
6
let log s = Console.console##log (Js.string s)
7
7
8
-
let initialise s callback =
9
-
let ( let* ) = Lwt_result.bind in
10
-
let rpc = Js_top_worker_client.start s 10000000 callback in
11
-
let* () =
12
-
W.init rpc
13
-
Toplevel_api_gen.
14
-
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
-
in
16
-
Lwt.return (Ok rpc)
17
-
18
-
let log_output (o : Toplevel_api_gen.exec_result) =
19
-
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
-
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
-
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
-
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
-
let strloc (line, col) =
24
-
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
25
-
in
26
-
Option.iter
27
-
(fun h ->
28
-
let open Toplevel_api_gen in
29
-
log
30
-
("highlight "
31
-
^ strloc (h.line1, h.col1)
32
-
^ " to "
33
-
^ strloc (h.line2, h.col2)))
34
-
o.highlight
35
-
36
8
let _ =
37
-
let ( let* ) = Lwt_result.bind in
38
-
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
-
let* o = W.setup rpc "" in
40
-
log_output o;
41
-
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
42
-
let* _o2 =
43
-
W.query_errors rpc "" (Some "c2") [ "c1" ] true
44
-
"# type yyy = xxx;;\n type yyy = xxx\n"
9
+
let open Lwt.Infix in
10
+
let t = C.create ~timeout:10000000 "_opam/worker.js" in
11
+
let config : Msg.init_config =
12
+
{ findlib_requires = []; stdlib_dcs = None; findlib_index = None }
45
13
in
46
-
Lwt.return (Ok ())
14
+
C.init t config >>= fun () ->
15
+
C.errors t ~env_id:"default" "type xxx = int;;\n" >>= fun _o ->
16
+
C.errors t ~env_id:"default" "type yyy = xxx;;\n" >>= fun _o2 ->
17
+
Lwt.return ()
+12
-45
example/example4.ml
+12
-45
example/example4.ml
···
1
1
(* Simplest example *)
2
2
open Js_of_ocaml
3
-
open Js_top_worker_rpc
4
-
module W = Js_top_worker_client.W
3
+
module C = Js_top_worker_client_msg
4
+
module Msg = Js_top_worker_message.Message
5
5
6
6
let log s = Console.console##log (Js.string s)
7
7
8
-
let initialise s callback =
9
-
let ( let* ) = Lwt_result.bind in
10
-
let rpc = Js_top_worker_client.start s 10000000 callback in
11
-
let* () =
12
-
W.init rpc
13
-
Toplevel_api_gen.
14
-
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
15
-
in
16
-
Lwt.return (Ok rpc)
17
-
18
-
let log_output (o : Toplevel_api_gen.exec_result) =
19
-
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
20
-
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
21
-
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
22
-
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf;
23
-
let strloc (line, col) =
24
-
"(" ^ string_of_int line ^ "," ^ string_of_int col ^ ")"
25
-
in
26
-
Option.iter
27
-
(fun h ->
28
-
let open Toplevel_api_gen in
29
-
log
30
-
("highlight "
31
-
^ strloc (h.line1, h.col1)
32
-
^ " to "
33
-
^ strloc (h.line2, h.col2)))
34
-
o.highlight
35
-
36
8
let _ =
37
-
let ( let* ) = Lwt_result.bind in
38
-
let* rpc = initialise "_opam/worker.js" (fun _ -> log "Timeout") in
39
-
let* o = W.setup rpc "" in
40
-
log_output o;
41
-
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxxx = int;;\n" in
42
-
let* _o2 =
43
-
W.query_errors rpc "" (Some "c2") [ "c1" ] true
44
-
"# type yyy = xxx;;\n type yyy = xxx\n"
45
-
in
46
-
let* _o = W.query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
47
-
let* _o2 =
48
-
W.query_errors rpc "" (Some "c2") [ "c1" ] true
49
-
"# type yyy = xxx (* With a comment *);;\n type yyy = xxx\n"
9
+
let open Lwt.Infix in
10
+
let t = C.create ~timeout:10000000 "_opam/worker.js" in
11
+
let config : Msg.init_config =
12
+
{ findlib_requires = []; stdlib_dcs = None; findlib_index = None }
50
13
in
51
-
52
-
Lwt.return (Ok ())
14
+
C.init t config >>= fun () ->
15
+
C.errors t ~env_id:"default" "type xxxx = int;;\n" >>= fun _o ->
16
+
C.errors t ~env_id:"default" "type yyy = xxx;;\n" >>= fun _o2 ->
17
+
C.errors t ~env_id:"default" "type xxx = int;;\n" >>= fun _o ->
18
+
C.errors t ~env_id:"default" "type yyy = xxx (* With a comment *);;\n" >>= fun _o2 ->
19
+
Lwt.return ()
-92
example/rpc_worker.ml
-92
example/rpc_worker.ml
···
1
-
(** Full-featured JSON-RPC worker for x-ocaml integration.
2
-
3
-
Uses the same full S module as worker.ml (with Findlibish, sync/async
4
-
get, etc.) but speaks JSON-RPC instead of the message protocol. *)
5
-
6
-
open Js_top_worker_rpc
7
-
open Js_top_worker
8
-
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
9
-
10
-
let server process e =
11
-
let _, id, call = Jsonrpc.version_id_and_call_of_string e in
12
-
Lwt.bind (process call) (fun response ->
13
-
let rtxt = Jsonrpc.string_of_response ~id response in
14
-
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string rtxt);
15
-
Lwt.return ())
16
-
17
-
module S : Impl.S = struct
18
-
type findlib_t = Js_top_worker_web.Findlibish.t
19
-
20
-
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
21
-
fun f () ->
22
-
let stdout_buff = Buffer.create 1024 in
23
-
let stderr_buff = Buffer.create 1024 in
24
-
Js_of_ocaml.Sys_js.set_channel_flusher stdout
25
-
(Buffer.add_string stdout_buff);
26
-
Js_of_ocaml.Sys_js.set_channel_flusher stderr
27
-
(Buffer.add_string stderr_buff);
28
-
let x = f () in
29
-
let captured =
30
-
{
31
-
Impl.stdout = Buffer.contents stdout_buff;
32
-
stderr = Buffer.contents stderr_buff;
33
-
}
34
-
in
35
-
(captured, x)
36
-
37
-
let sync_get = Js_top_worker_web.Jslib.sync_get
38
-
let async_get = Js_top_worker_web.Jslib.async_get
39
-
40
-
let create_file ~name ~content =
41
-
try Js_of_ocaml.Sys_js.create_file ~name ~content
42
-
with Sys_error _ -> ()
43
-
44
-
let get_stdlib_dcs uri =
45
-
Js_top_worker_web.Findlibish.fetch_dynamic_cmis sync_get uri
46
-
|> Result.to_list
47
-
48
-
let import_scripts urls =
49
-
let absolute_urls = List.map Js_top_worker_web.Jslib.map_url urls in
50
-
Js_of_ocaml.Worker.import_scripts absolute_urls
51
-
52
-
let findlib_init = Js_top_worker_web.Findlibish.init async_get
53
-
54
-
let require b v = function
55
-
| [] -> []
56
-
| packages ->
57
-
Js_top_worker_web.Findlibish.require ~import_scripts sync_get b v
58
-
packages
59
-
60
-
let init_function func_name =
61
-
let open Js_of_ocaml in
62
-
let func = Js.Unsafe.js_expr func_name in
63
-
fun () -> Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |]
64
-
65
-
let path = "/static/cmis"
66
-
end
67
-
68
-
module M = Impl.Make (S)
69
-
70
-
let run () =
71
-
let open Js_of_ocaml in
72
-
let open M in
73
-
Console.console##log (Js.string "RPC worker starting...");
74
-
Logs.set_reporter (Logs_browser.console_reporter ());
75
-
Logs.set_level (Some Logs.Debug);
76
-
Server.init (Impl.IdlM.T.lift init);
77
-
Server.create_env (Impl.IdlM.T.lift create_env);
78
-
Server.destroy_env (Impl.IdlM.T.lift destroy_env);
79
-
Server.list_envs (Impl.IdlM.T.lift list_envs);
80
-
Server.setup (Impl.IdlM.T.lift setup);
81
-
Server.exec execute;
82
-
Server.complete_prefix complete_prefix;
83
-
Server.query_errors query_errors;
84
-
Server.type_enclosing type_enclosing;
85
-
Server.exec_toplevel exec_toplevel;
86
-
let rpc_fn = Impl.IdlM.server Server.implementation in
87
-
Worker.set_onmessage (fun x ->
88
-
let s = Js.to_string x in
89
-
ignore (server rpc_fn s));
90
-
Console.console##log (Js.string "RPC worker ready")
91
-
92
-
let () = run ()
-45
example/unix_client.ml
-45
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 = Transport.Json.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
-
Transport.Json.response_of_string (Bytes.unsafe_to_string msg_buf)
26
-
in
27
-
response
28
-
29
-
let cli () =
30
-
let default =
31
-
Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ()))
32
-
in
33
-
let info = Cmdliner.Cmd.info "cli" ~version:"1.6.1" ~doc:"a cli for an API" in
34
-
let rpc = binary_rpc Toplevel_api_gen.sockpath in
35
-
let cmds =
36
-
List.map
37
-
(fun t ->
38
-
let term, info = t rpc in
39
-
Cmdliner.(Cmd.v info Term.(term $ const ())))
40
-
(Cmds.implementation ())
41
-
in
42
-
let cmd = Cmdliner.Cmd.group ~default info cmds in
43
-
exit (Cmdliner.Cmd.eval cmd)
44
-
45
-
let () = cli ()
-213
example/unix_worker.ml
-213
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 ( let* ) = Lwt.bind
54
-
55
-
let rec read_exact s buf off len =
56
-
if len <= 0 then Lwt.return ()
57
-
else
58
-
let* n = Lwt_unix.read s buf off len in
59
-
if n = 0 then Lwt.fail End_of_file
60
-
else read_exact s buf (off + n) (len - n)
61
-
62
-
let binary_handler process s =
63
-
(* Read a 16 byte length encoded as a string *)
64
-
let len_buf = Bytes.make 16 '\000' in
65
-
let* () = read_exact s len_buf 0 16 in
66
-
let len = int_of_string (Bytes.unsafe_to_string len_buf) in
67
-
let msg_buf = Bytes.make len '\000' in
68
-
let* () = read_exact s msg_buf 0 len in
69
-
let* result = process msg_buf in
70
-
let len_buf = Printf.sprintf "%016d" (String.length result) in
71
-
let* _ = Lwt_unix.write s (Bytes.of_string len_buf) 0 16 in
72
-
let* _ = Lwt_unix.write s (Bytes.of_string result) 0 (String.length result) in
73
-
Lwt.return ()
74
-
75
-
let mkdir_rec dir perm =
76
-
let rec p_mkdir dir =
77
-
let p_name = Filename.dirname dir in
78
-
if p_name <> "/" && p_name <> "." then p_mkdir p_name;
79
-
try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
80
-
in
81
-
p_mkdir dir
82
-
83
-
let serve_requests rpcfn path ~ready_fd =
84
-
let ( let* ) = Lwt.bind in
85
-
(try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ());
86
-
mkdir_rec (Filename.dirname path) 0o0755;
87
-
let sock = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
88
-
let* () = Lwt_unix.bind sock (Unix.ADDR_UNIX path) in
89
-
Lwt_unix.listen sock 5;
90
-
(* Signal readiness via pipe to parent process *)
91
-
(match ready_fd with
92
-
| Some fd ->
93
-
ignore (Unix.write fd (Bytes.of_string "R") 0 1);
94
-
Unix.close fd
95
-
| None -> ());
96
-
let rec loop () =
97
-
let* this_connection, _ = Lwt_unix.accept sock in
98
-
let* () =
99
-
Lwt.finalize
100
-
(fun () ->
101
-
(* Here I am calling M.run to make sure that I am running the process,
102
-
this is not much of a problem with IdM or ExnM, but in general you
103
-
should ensure that the computation is started by a runner. *)
104
-
binary_handler rpcfn this_connection)
105
-
(fun () -> Lwt_unix.close this_connection)
106
-
in
107
-
loop ()
108
-
in
109
-
loop ()
110
-
111
-
let handle_findlib_error = function
112
-
| Failure msg -> Printf.fprintf stderr "%s" msg
113
-
| Fl_package_base.No_such_package (pkg, reason) ->
114
-
Printf.fprintf stderr "No such package: %s%s\n" pkg
115
-
(if reason <> "" then " - " ^ reason else "")
116
-
| Fl_package_base.Package_loop pkg ->
117
-
Printf.fprintf stderr "Package requires itself: %s\n" pkg
118
-
| exn -> raise exn
119
-
120
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
121
-
122
-
module S : Impl.S = struct
123
-
type findlib_t = unit
124
-
125
-
let capture = capture
126
-
let sync_get _ = None
127
-
let async_get _ = Lwt.return (Error (`Msg "Not implemented"))
128
-
let create_file ~name:_ ~content:_ = failwith "Not implemented"
129
-
130
-
let import_scripts urls =
131
-
if List.length urls > 0 then failwith "Not implemented" else ()
132
-
133
-
let init_function _ () = failwith "Not implemented"
134
-
let findlib_init _ = Lwt.return ()
135
-
let get_stdlib_dcs _uri = []
136
-
137
-
let require _ () packages =
138
-
try
139
-
let eff_packages =
140
-
Findlib.package_deep_ancestors !Topfind.predicates packages
141
-
in
142
-
Topfind.load eff_packages;
143
-
[]
144
-
with exn ->
145
-
handle_findlib_error exn;
146
-
[]
147
-
148
-
let path = "/tmp"
149
-
end
150
-
151
-
module U = Impl.Make (S)
152
-
153
-
(* let test () =
154
-
let _x = Compmisc.initial_env in
155
-
let oc = open_out "/tmp/unix_worker.ml" in
156
-
Printf.fprintf oc "let x=1;;\n";
157
-
close_out oc;
158
-
let unit_info = Unit_info.make ~source_file:"/tmp/unix_worker.ml" "/tmp/unix_worker" in
159
-
try
160
-
let _ast = Pparse.parse_implementation ~tool_name:"worker" "/tmp/unix_worker.ml" in
161
-
let _ = Typemod.type_implementation unit_info (Compmisc.initial_env ()) _ast in
162
-
()
163
-
with exn ->
164
-
Printf.eprintf "error: %s\n%!" (Printexc.to_string exn);
165
-
let ppf = Format.err_formatter in
166
-
let _ = Location.report_exception ppf exn in
167
-
() *)
168
-
169
-
let start_server ~ready_fd =
170
-
let open U in
171
-
Logs.set_reporter (Logs_fmt.reporter ());
172
-
Logs.set_level (Some Logs.Warning);
173
-
Server.init (IdlM.T.lift init);
174
-
Server.create_env (IdlM.T.lift create_env);
175
-
Server.destroy_env (IdlM.T.lift destroy_env);
176
-
Server.list_envs (IdlM.T.lift list_envs);
177
-
Server.setup (IdlM.T.lift setup);
178
-
Server.exec execute;
179
-
Server.complete_prefix complete_prefix;
180
-
Server.query_errors query_errors;
181
-
Server.type_enclosing type_enclosing;
182
-
Server.exec_toplevel exec_toplevel;
183
-
let rpc_fn = IdlM.server Server.implementation in
184
-
let process x =
185
-
let open Lwt in
186
-
let _, call = Js_top_worker_rpc.Transport.Json.id_and_call_of_string (Bytes.unsafe_to_string x) in
187
-
rpc_fn call >>= fun response ->
188
-
Js_top_worker_rpc.Transport.Json.string_of_response ~id:(Rpc.Int 0L) response |> return
189
-
in
190
-
serve_requests process Js_top_worker_rpc.Toplevel_api_gen.sockpath ~ready_fd
191
-
192
-
let () =
193
-
(* Fork so parent only exits once child is ready to accept connections *)
194
-
let read_fd, write_fd = Unix.pipe ~cloexec:false () in
195
-
match Unix.fork () with
196
-
| 0 ->
197
-
(* Child: close read end and detach from terminal *)
198
-
Unix.close read_fd;
199
-
(* Redirect stdout/stderr to /dev/null so parent's $() can complete *)
200
-
let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0 in
201
-
Unix.dup2 dev_null Unix.stdout;
202
-
Unix.dup2 dev_null Unix.stderr;
203
-
Unix.close dev_null;
204
-
(* Run server, signal via write end *)
205
-
Lwt_main.run (start_server ~ready_fd:(Some write_fd))
206
-
| child_pid ->
207
-
(* Parent: close write end, wait for ready signal, print child PID, exit *)
208
-
Unix.close write_fd;
209
-
let buf = Bytes.create 1 in
210
-
ignore (Unix.read read_fd buf 0 1);
211
-
Unix.close read_fd;
212
-
Printf.printf "%d\n%!" child_pid
213
-
(* Parent exits here, child continues serving *)
-660
idl/_old/idl.ml
-660
idl/_old/idl.ml
···
1
-
let logfn = ref (fun (_ : string) -> ())
2
-
3
-
module Param = struct
4
-
type 'a t = {
5
-
name : string option;
6
-
description : string list;
7
-
typedef : 'a Rpc.Types.def;
8
-
version : Rpc.Version.t option;
9
-
}
10
-
11
-
type boxed = Boxed : 'a t -> boxed
12
-
13
-
let mk ?name ?description ?version typedef =
14
-
let description =
15
-
match description with
16
-
| Some d -> d
17
-
| None -> typedef.Rpc.Types.description
18
-
in
19
-
{ name; description; version; typedef }
20
-
end
21
-
22
-
module Error = struct
23
-
type 'a t = {
24
-
def : 'a Rpc.Types.def;
25
-
raiser : 'a -> exn;
26
-
matcher : exn -> 'a option;
27
-
}
28
-
29
-
module type ERROR = sig
30
-
type t
31
-
32
-
val t : t Rpc.Types.def
33
-
val internal_error_of : exn -> t option
34
-
end
35
-
36
-
module Make (T : ERROR) = struct
37
-
exception Exn of T.t
38
-
39
-
let () =
40
-
let printer = function
41
-
| Exn x ->
42
-
Some
43
-
(Printf.sprintf "IDL Error: %s"
44
-
(Rpcmarshal.marshal T.t.Rpc.Types.ty x |> Rpc.to_string))
45
-
| _ -> None
46
-
in
47
-
Printexc.register_printer printer
48
-
49
-
let error =
50
-
{
51
-
def = T.t;
52
-
raiser = (function e -> Exn e);
53
-
matcher = (function Exn e -> Some e | e -> T.internal_error_of e);
54
-
}
55
-
end
56
-
end
57
-
58
-
module Interface = struct
59
-
type description = {
60
-
name : string;
61
-
namespace : string option;
62
-
description : string list;
63
-
version : Rpc.Version.t;
64
-
}
65
-
end
66
-
67
-
module type RPC = sig
68
-
type implementation
69
-
type 'a res
70
-
type ('a, 'b) comp
71
-
type _ fn
72
-
73
-
val implement : Interface.description -> implementation
74
-
val ( @-> ) : 'a Param.t -> 'b fn -> ('a -> 'b) fn
75
-
val returning : 'a Param.t -> 'b Error.t -> ('a, 'b) comp fn
76
-
val declare : string -> string list -> 'a fn -> 'a res
77
-
val declare_notification : string -> string list -> 'a fn -> 'a res
78
-
end
79
-
80
-
module type MONAD = sig
81
-
type 'a t
82
-
83
-
val return : 'a -> 'a t
84
-
val bind : 'a t -> ('a -> 'b t) -> 'b t
85
-
val fail : exn -> 'a t
86
-
end
87
-
88
-
exception MarshalError of string
89
-
exception UnknownMethod of string
90
-
exception UnboundImplementation of string list
91
-
exception NoDescription
92
-
93
-
let get_wire_name description name =
94
-
match description with
95
-
| None -> name
96
-
| Some d -> (
97
-
match d.Interface.namespace with
98
-
| Some ns -> Printf.sprintf "%s.%s" ns name
99
-
| None -> name)
100
-
101
-
let get_arg call has_named name is_opt =
102
-
match (has_named, name, call.Rpc.params) with
103
-
| true, Some n, Rpc.Dict named :: unnamed -> (
104
-
match List.partition (fun (x, _) -> x = n) named with
105
-
| (_, arg) :: dups, others when is_opt ->
106
-
Ok
107
-
( Rpc.Enum [ arg ],
108
-
{ call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed } )
109
-
| (_, arg) :: dups, others ->
110
-
Ok
111
-
(arg, { call with Rpc.params = Rpc.Dict (dups @ others) :: unnamed })
112
-
| [], _others when is_opt -> Ok (Rpc.Enum [], call)
113
-
| _, _ -> Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)))
114
-
| true, None, Rpc.Dict named :: unnamed -> (
115
-
match unnamed with
116
-
| head :: tail ->
117
-
Ok (head, { call with Rpc.params = Rpc.Dict named :: tail })
118
-
| _ -> Error (`Msg "Incorrect number of arguments"))
119
-
| true, _, _ ->
120
-
Error
121
-
(`Msg
122
-
"Marshalling error: Expecting dict as first argument when named \
123
-
parameters exist")
124
-
| false, None, head :: tail -> Ok (head, { call with Rpc.params = tail })
125
-
| false, None, [] -> Error (`Msg "Incorrect number of arguments")
126
-
| false, Some _, _ -> failwith "Can't happen by construction"
127
-
128
-
module Make (M : MONAD) = struct
129
-
module type RPCTRANSFORMER = sig
130
-
type 'a box
131
-
type ('a, 'b) resultb = ('a, 'b) result box
132
-
type rpcfn = Rpc.call -> Rpc.response M.t
133
-
134
-
val lift : ('a -> 'b M.t) -> 'a -> 'b box
135
-
val bind : 'a box -> ('a -> 'b M.t) -> 'b box
136
-
val return : 'a -> 'a box
137
-
val get : 'a box -> 'a M.t
138
-
val ( !@ ) : 'a box -> 'a M.t
139
-
val put : 'a M.t -> 'a box
140
-
val ( ~@ ) : 'a M.t -> 'a box
141
-
end
142
-
143
-
module T = struct
144
-
type 'a box = { box : 'a M.t }
145
-
type ('a, 'b) resultb = ('a, 'b) result box
146
-
type rpcfn = Rpc.call -> Rpc.response M.t
147
-
148
-
let lift f x = { box = f x }
149
-
let bind { box = x } f = { box = M.bind x f }
150
-
let return x = { box = M.return x }
151
-
let get { box = x } = x
152
-
let ( !@ ) = get
153
-
let put x = { box = x }
154
-
let ( ~@ ) = put
155
-
end
156
-
157
-
type client_implementation = unit
158
-
type server_implementation = (string, T.rpcfn option) Hashtbl.t
159
-
160
-
module ErrM : sig
161
-
val return : 'a -> ('a, 'b) T.resultb
162
-
val return_err : 'b -> ('a, 'b) T.resultb
163
-
164
-
val checked_bind :
165
-
('a, 'b) T.resultb ->
166
-
('a -> ('c, 'd) T.resultb) ->
167
-
('b -> ('c, 'd) T.resultb) ->
168
-
('c, 'd) T.resultb
169
-
170
-
val bind :
171
-
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
172
-
173
-
val ( >>= ) :
174
-
('a, 'b) T.resultb -> ('a -> ('c, 'b) T.resultb) -> ('c, 'b) T.resultb
175
-
end = struct
176
-
let return x = T.put (M.return (Ok x))
177
-
let return_err e = T.put (M.return (Error e))
178
-
179
-
let checked_bind x f f1 =
180
-
T.bind x T.(function Ok x -> !@(f x) | Error x -> !@(f1 x))
181
-
182
-
let bind x f = checked_bind x f return_err
183
-
let ( >>= ) x f = bind x f
184
-
end
185
-
186
-
module GenClient () = struct
187
-
type implementation = client_implementation
188
-
type 'a res = T.rpcfn -> 'a
189
-
type ('a, 'b) comp = ('a, 'b) T.resultb
190
-
191
-
type _ fn =
192
-
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
193
-
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
194
-
195
-
let description = ref None
196
-
let strict = ref false
197
-
let make_strict () = strict := true
198
-
199
-
let implement x =
200
-
description := Some x;
201
-
()
202
-
203
-
let returning a err = Returning (a, err)
204
-
let ( @-> ) t f = Function (t, f)
205
-
206
-
let declare_ is_notification name _ ty (rpc : T.rpcfn) =
207
-
let rec inner :
208
-
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
209
-
fun (named, unnamed) -> function
210
-
| Function (t, f) -> (
211
-
let cur_named = match named with Some l -> l | None -> [] in
212
-
fun v ->
213
-
match t.Param.name with
214
-
| Some n -> (
215
-
match (t.Param.typedef.Rpc.Types.ty, v) with
216
-
| Rpc.Types.Option ty, Some v' ->
217
-
let marshalled = Rpcmarshal.marshal ty v' in
218
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f
219
-
| Rpc.Types.Option _ty, None ->
220
-
inner (Some cur_named, unnamed) f
221
-
| ty, v ->
222
-
let marshalled = Rpcmarshal.marshal ty v in
223
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
224
-
| None ->
225
-
let marshalled =
226
-
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
227
-
in
228
-
inner (named, marshalled :: unnamed) f)
229
-
| Returning (t, e) ->
230
-
let wire_name = get_wire_name !description name in
231
-
let args =
232
-
match named with
233
-
| None -> List.rev unnamed
234
-
| Some l -> Rpc.Dict l :: List.rev unnamed
235
-
in
236
-
let call' = Rpc.call wire_name args in
237
-
let call = { call' with is_notification } in
238
-
let rpc = T.put (rpc call) in
239
-
let res =
240
-
T.bind rpc (fun r ->
241
-
if r.Rpc.success then
242
-
match
243
-
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty
244
-
r.Rpc.contents
245
-
with
246
-
| Ok x -> M.return (Ok x)
247
-
| Error (`Msg x) -> M.fail (MarshalError x)
248
-
else
249
-
match
250
-
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty
251
-
r.Rpc.contents
252
-
with
253
-
| Ok x ->
254
-
if !strict then M.fail (e.Error.raiser x)
255
-
else M.return (Error x)
256
-
| Error (`Msg x) -> M.fail (MarshalError x))
257
-
in
258
-
res
259
-
in
260
-
inner (None, []) ty
261
-
262
-
let declare_notification name a ty (rpc : T.rpcfn) =
263
-
declare_ true name a ty rpc
264
-
265
-
let declare name a ty (rpc : T.rpcfn) = declare_ false name a ty rpc
266
-
end
267
-
268
-
let server hashtbl =
269
-
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
270
-
let unbound_impls =
271
-
Hashtbl.fold
272
-
(fun key fn acc ->
273
-
match fn with
274
-
| None -> key :: acc
275
-
| Some fn ->
276
-
Hashtbl.add impl key fn;
277
-
acc)
278
-
hashtbl []
279
-
in
280
-
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
281
-
fun call ->
282
-
let fn =
283
-
try Hashtbl.find impl call.Rpc.name
284
-
with Not_found ->
285
-
!logfn "1";
286
-
Hashtbl.iter
287
-
(fun key _ ->
288
-
!logfn ("method: " ^ key ^ (Hashtbl.hash key |> string_of_int));
289
-
!logfn key)
290
-
impl;
291
-
let _h = Hashtbl.hash call.Rpc.name in
292
-
293
-
!logfn
294
-
(Printf.sprintf "Unknown method: %s %d" call.Rpc.name
295
-
(Hashtbl.hash call.Rpc.name));
296
-
!logfn call.Rpc.name;
297
-
raise (UnknownMethod call.Rpc.name)
298
-
in
299
-
fn call
300
-
301
-
let combine hashtbls =
302
-
let result = Hashtbl.create 16 in
303
-
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
304
-
result
305
-
306
-
module GenServer () = struct
307
-
type implementation = server_implementation
308
-
type ('a, 'b) comp = ('a, 'b) T.resultb
309
-
type 'a res = 'a -> unit
310
-
311
-
type _ fn =
312
-
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
313
-
| Returning : ('a Param.t * 'b Error.t) -> ('a, 'b) comp fn
314
-
315
-
let funcs = Hashtbl.create 20
316
-
let description = ref None
317
-
318
-
let implement x =
319
-
description := Some x;
320
-
funcs
321
-
322
-
let returning a b = Returning (a, b)
323
-
let ( @-> ) t f = Function (t, f)
324
-
325
-
let rec has_named_args : type a. a fn -> bool = function
326
-
| Function (t, f) -> (
327
-
match t.Param.name with Some _ -> true | None -> has_named_args f)
328
-
| Returning (_, _) -> false
329
-
330
-
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
331
-
fun is_notification name _ ty ->
332
-
let ( >>= ) = M.bind in
333
-
(* We do not know the wire name yet as the description may still be unset *)
334
-
Hashtbl.add funcs name None;
335
-
fun impl ->
336
-
(* Sanity check: ensure the description has been set before we declare
337
-
any RPCs. Here we raise an exception immediately and let everything fail. *)
338
-
(match !description with Some _ -> () | None -> raise NoDescription);
339
-
let rpcfn =
340
-
let has_named = has_named_args ty in
341
-
let rec inner : type a. a fn -> a -> T.rpcfn =
342
-
fun f impl call ->
343
-
match f with
344
-
| Function (t, f) -> (
345
-
let is_opt =
346
-
match t.Param.typedef.Rpc.Types.ty with
347
-
| Rpc.Types.Option _ -> true
348
-
| _ -> false
349
-
in
350
-
(match get_arg call has_named t.Param.name is_opt with
351
-
| Ok (x, y) -> M.return (x, y)
352
-
| Error (`Msg m) -> M.fail (MarshalError m))
353
-
>>= fun (arg_rpc, call') ->
354
-
let z =
355
-
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
356
-
in
357
-
match z with
358
-
| Ok arg -> inner f (impl arg) call'
359
-
| Error (`Msg m) -> M.fail (MarshalError m))
360
-
| Returning (t, e) ->
361
-
T.bind impl (function
362
-
| Ok x ->
363
-
let res =
364
-
Rpc.success
365
-
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty x)
366
-
in
367
-
M.return { res with is_notification }
368
-
| Error y ->
369
-
let res =
370
-
Rpc.failure
371
-
(Rpcmarshal.marshal e.Error.def.Rpc.Types.ty y)
372
-
in
373
-
M.return { res with is_notification })
374
-
|> T.get
375
-
in
376
-
inner ty impl
377
-
in
378
-
Hashtbl.remove funcs name;
379
-
(* The wire name might be different from the name *)
380
-
let wire_name = get_wire_name !description name in
381
-
Hashtbl.add funcs wire_name (Some rpcfn)
382
-
383
-
let declare_notification name a ty = declare_ true name a ty
384
-
let declare name a ty = declare_ false name a ty
385
-
end
386
-
end
387
-
388
-
module ExnM = struct
389
-
type 'a t = V of 'a | E of exn
390
-
391
-
let return x = V x
392
-
let lift f x = match f x with y -> V y | exception e -> E e
393
-
let bind x (f : 'a -> 'b t) : 'b t = match x with V x -> f x | E e -> E e
394
-
let ( >>= ) = bind
395
-
let fail e = E e
396
-
let run = function V x -> x | E e -> raise e
397
-
end
398
-
399
-
module IdM = struct
400
-
type 'a t = T of 'a
401
-
402
-
let return x = T x
403
-
let lift f x = T (f x)
404
-
let bind (T x) f = f x
405
-
let ( >>= ) = bind
406
-
let fail e = raise e
407
-
let run (T x) = x
408
-
end
409
-
410
-
(* A default error variant as an example. In real code, this is more easily expressed by using the PPX:
411
-
type default_error = InternalError of string [@@deriving rpcty]
412
-
*)
413
-
module DefaultError = struct
414
-
type t = InternalError of string
415
-
416
-
exception InternalErrorExn of string
417
-
418
-
let internalerror : (string, t) Rpc.Types.tag =
419
-
let open Rpc.Types in
420
-
{
421
-
tname = "InternalError";
422
-
tdescription = [ "Internal Error" ];
423
-
tversion = Some (1, 0, 0);
424
-
tcontents = Basic String;
425
-
tpreview = (function InternalError s -> Some s);
426
-
treview = (fun s -> InternalError s);
427
-
}
428
-
429
-
(* And then we can create the 'variant' type *)
430
-
let t : t Rpc.Types.variant =
431
-
let open Rpc.Types in
432
-
{
433
-
vname = "t";
434
-
variants = [ BoxedTag internalerror ];
435
-
vversion = Some (1, 0, 0);
436
-
vdefault = Some (InternalError "Unknown error tag!");
437
-
vconstructor =
438
-
(fun s t ->
439
-
match s with
440
-
| "InternalError" -> (
441
-
match t.tget (Basic String) with
442
-
| Ok s -> Ok (internalerror.treview s)
443
-
| Error y -> Error y)
444
-
| s -> Error (`Msg (Printf.sprintf "Unknown tag '%s'" s)));
445
-
}
446
-
447
-
let def =
448
-
let open Rpc.Types in
449
-
{
450
-
name = "default_error";
451
-
description = [ "Errors declared as part of the interface" ];
452
-
ty = Variant t;
453
-
}
454
-
455
-
let err =
456
-
let open Error in
457
-
{
458
-
def;
459
-
raiser = (function InternalError s -> raise (InternalErrorExn s));
460
-
matcher =
461
-
(function InternalErrorExn s -> Some (InternalError s) | _ -> None);
462
-
}
463
-
end
464
-
465
-
module Exn = struct
466
-
type rpcfn = Rpc.call -> Rpc.response
467
-
type client_implementation = unit
468
-
type server_implementation = (string, rpcfn option) Hashtbl.t
469
-
470
-
module GenClient (R : sig
471
-
val rpc : rpcfn
472
-
end) =
473
-
struct
474
-
type implementation = client_implementation
475
-
type ('a, 'b) comp = 'a
476
-
type 'a res = 'a
477
-
478
-
type _ fn =
479
-
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
480
-
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
481
-
482
-
let description = ref None
483
-
484
-
let implement x =
485
-
description := Some x;
486
-
()
487
-
488
-
let returning a err = Returning (a, err)
489
-
let ( @-> ) t f = Function (t, f)
490
-
491
-
let declare_ is_notification name _ ty =
492
-
let rec inner :
493
-
type b. (string * Rpc.t) list option * Rpc.t list -> b fn -> b =
494
-
fun (named, unnamed) -> function
495
-
| Function (t, f) -> (
496
-
let cur_named = match named with Some l -> l | None -> [] in
497
-
fun v ->
498
-
match t.Param.name with
499
-
| Some n -> (
500
-
match (t.Param.typedef.Rpc.Types.ty, v) with
501
-
| Rpc.Types.Option ty, Some v' ->
502
-
let marshalled = Rpcmarshal.marshal ty v' in
503
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f
504
-
| Rpc.Types.Option _ty, None ->
505
-
inner (Some cur_named, unnamed) f
506
-
| ty, v ->
507
-
let marshalled = Rpcmarshal.marshal ty v in
508
-
inner (Some ((n, marshalled) :: cur_named), unnamed) f)
509
-
| None ->
510
-
let marshalled =
511
-
Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v
512
-
in
513
-
inner (named, marshalled :: unnamed) f)
514
-
| Returning (t, e) -> (
515
-
let wire_name = get_wire_name !description name in
516
-
let args =
517
-
match named with
518
-
| None -> List.rev unnamed
519
-
| Some l -> Rpc.Dict l :: List.rev unnamed
520
-
in
521
-
let call' = Rpc.call wire_name args in
522
-
let call = { call' with is_notification } in
523
-
let r = R.rpc call in
524
-
if r.Rpc.success then
525
-
match
526
-
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty r.Rpc.contents
527
-
with
528
-
| Ok x -> x
529
-
| Error (`Msg x) -> raise (MarshalError x)
530
-
else
531
-
match
532
-
Rpcmarshal.unmarshal e.Error.def.Rpc.Types.ty r.Rpc.contents
533
-
with
534
-
| Ok x -> raise (e.Error.raiser x)
535
-
| Error (`Msg x) -> raise (MarshalError x))
536
-
in
537
-
inner (None, []) ty
538
-
539
-
let declare name a ty = declare_ false name a ty
540
-
let declare_notification name a ty = declare_ true name a ty
541
-
end
542
-
543
-
let server hashtbl =
544
-
let impl = Hashtbl.create (Hashtbl.length hashtbl) in
545
-
let unbound_impls =
546
-
Hashtbl.fold
547
-
(fun key fn acc ->
548
-
match fn with
549
-
| None -> key :: acc
550
-
| Some fn ->
551
-
Hashtbl.add impl key fn;
552
-
acc)
553
-
hashtbl []
554
-
in
555
-
if unbound_impls <> [] then raise (UnboundImplementation unbound_impls);
556
-
fun call ->
557
-
let fn =
558
-
try Hashtbl.find impl call.Rpc.name
559
-
with Not_found ->
560
-
!logfn "2";
561
-
Hashtbl.iter (fun key _ -> !logfn ("method: " ^ key)) impl;
562
-
!logfn (Printf.sprintf "Unknown method: %s" call.Rpc.name);
563
-
raise (UnknownMethod call.Rpc.name)
564
-
in
565
-
fn call
566
-
567
-
let combine hashtbls =
568
-
let result = Hashtbl.create 16 in
569
-
List.iter (Hashtbl.iter (fun k v -> Hashtbl.add result k v)) hashtbls;
570
-
result
571
-
572
-
module GenServer () = struct
573
-
type implementation = server_implementation
574
-
type ('a, 'b) comp = 'a
575
-
type 'a res = 'a -> unit
576
-
577
-
type _ fn =
578
-
| Function : 'a Param.t * 'b fn -> ('a -> 'b) fn
579
-
| Returning : ('a Param.t * 'b Error.t) -> ('a, _) comp fn
580
-
581
-
let funcs = Hashtbl.create 20
582
-
let description = ref None
583
-
584
-
let implement x =
585
-
description := Some x;
586
-
funcs
587
-
588
-
let returning a b = Returning (a, b)
589
-
let ( @-> ) t f = Function (t, f)
590
-
591
-
type boxed_error = BoxedError : 'a Error.t -> boxed_error
592
-
593
-
let rec get_error_ty : type a. a fn -> boxed_error = function
594
-
| Function (_, f) -> get_error_ty f
595
-
| Returning (_, e) -> BoxedError e
596
-
597
-
let rec has_named_args : type a. a fn -> bool = function
598
-
| Function (t, f) -> (
599
-
match t.Param.name with Some _ -> true | None -> has_named_args f)
600
-
| Returning (_, _) -> false
601
-
602
-
let declare_ : bool -> string -> string list -> 'a fn -> 'a res =
603
-
fun is_notification name _ ty ->
604
-
(* We do not know the wire name yet as the description may still be unset *)
605
-
Hashtbl.add funcs name None;
606
-
fun impl ->
607
-
(* Sanity check: ensure the description has been set before we declare
608
-
any RPCs *)
609
-
(match !description with Some _ -> () | None -> raise NoDescription);
610
-
let rpcfn =
611
-
let has_named = has_named_args ty in
612
-
let rec inner : type a. a fn -> a -> Rpc.call -> Rpc.response =
613
-
fun f impl call ->
614
-
try
615
-
match f with
616
-
| Function (t, f) ->
617
-
let is_opt =
618
-
match t.Param.typedef.Rpc.Types.ty with
619
-
| Rpc.Types.Option _ -> true
620
-
| _ -> false
621
-
in
622
-
let arg_rpc, call' =
623
-
match get_arg call has_named t.Param.name is_opt with
624
-
| Ok (x, y) -> (x, y)
625
-
| Error (`Msg m) -> raise (MarshalError m)
626
-
in
627
-
let z =
628
-
Rpcmarshal.unmarshal t.Param.typedef.Rpc.Types.ty arg_rpc
629
-
in
630
-
let arg =
631
-
match z with
632
-
| Ok arg -> arg
633
-
| Error (`Msg m) -> raise (MarshalError m)
634
-
in
635
-
inner f (impl arg) call'
636
-
| Returning (t, _) ->
637
-
let call =
638
-
Rpc.success
639
-
(Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty impl)
640
-
in
641
-
{ call with is_notification }
642
-
with e -> (
643
-
let (BoxedError error_ty) = get_error_ty f in
644
-
match error_ty.Error.matcher e with
645
-
| Some y ->
646
-
Rpc.failure
647
-
(Rpcmarshal.marshal error_ty.Error.def.Rpc.Types.ty y)
648
-
| None -> raise e)
649
-
in
650
-
inner ty impl
651
-
in
652
-
Hashtbl.remove funcs name;
653
-
(* The wire name might be different from the name *)
654
-
let wire_name = get_wire_name !description name in
655
-
Hashtbl.add funcs wire_name (Some rpcfn)
656
-
657
-
let declare name a ty = declare_ true name a ty
658
-
let declare_notification name a ty = declare_ false name a ty
659
-
end
660
-
end
-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
-343
idl/_old/rpc.ml
-343
idl/_old/rpc.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
-
let debug = ref false
19
-
let set_debug x = debug := x
20
-
let get_debug () = !debug
21
-
22
-
type msg = [ `Msg of string ]
23
-
24
-
type t =
25
-
| Int of int64
26
-
| Int32 of int32
27
-
| Bool of bool
28
-
| Float of float
29
-
| String of string
30
-
| DateTime of string
31
-
| Enum of t list
32
-
| Dict of (string * t) list
33
-
| Base64 of string
34
-
| Null
35
-
36
-
module Version = struct
37
-
type t = int * int * int
38
-
39
-
let compare (x, y, z) (x', y', z') =
40
-
let cmp a b fn () =
41
-
let c = compare a b in
42
-
if c <> 0 then c else fn ()
43
-
in
44
-
cmp x x' (cmp y y' (cmp z z' (fun () -> 0))) ()
45
-
end
46
-
47
-
module Types = struct
48
-
type _ basic =
49
-
| Int : int basic
50
-
| Int32 : int32 basic
51
-
| Int64 : int64 basic
52
-
| Bool : bool basic
53
-
| Float : float basic
54
-
| String : string basic
55
-
| Char : char basic
56
-
57
-
type _ typ =
58
-
| Basic : 'a basic -> 'a typ
59
-
| DateTime : string typ
60
-
| Base64 : string typ
61
-
| Array : 'a typ -> 'a array typ
62
-
| List : 'a typ -> 'a list typ
63
-
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
64
-
| Unit : unit typ
65
-
| Option : 'a typ -> 'a option typ
66
-
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
67
-
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
68
-
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
69
-
| Struct : 'a structure -> 'a typ
70
-
| Variant : 'a variant -> 'a typ
71
-
| Abstract : 'a abstract -> 'a typ
72
-
73
-
(* A type definition has a name and description *)
74
-
and 'a def = { name : string; description : string list; ty : 'a typ }
75
-
and boxed_def = BoxedDef : 'a def -> boxed_def
76
-
77
-
and ('a, 's) field = {
78
-
fname : string;
79
-
fdescription : string list;
80
-
fversion : Version.t option;
81
-
field : 'a typ;
82
-
fdefault : 'a option;
83
-
fget : 's -> 'a;
84
-
(* Lenses *)
85
-
fset : 'a -> 's -> 's;
86
-
}
87
-
88
-
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
89
-
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
90
-
91
-
and 'a structure = {
92
-
sname : string;
93
-
fields : 'a boxed_field list;
94
-
version : Version.t option;
95
-
constructor : field_getter -> ('a, msg) result;
96
-
}
97
-
98
-
and ('a, 's) tag = {
99
-
tname : string;
100
-
tdescription : string list;
101
-
tversion : Version.t option;
102
-
tcontents : 'a typ;
103
-
tpreview : 's -> 'a option;
104
-
treview : 'a -> 's;
105
-
}
106
-
107
-
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
108
-
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
109
-
110
-
and 'a variant = {
111
-
vname : string;
112
-
variants : 'a boxed_tag list;
113
-
vdefault : 'a option;
114
-
vversion : Version.t option;
115
-
vconstructor : string -> tag_getter -> ('a, msg) result;
116
-
}
117
-
118
-
and 'a abstract = {
119
-
aname : string;
120
-
test_data : 'a list;
121
-
rpc_of : 'a -> t;
122
-
of_rpc : t -> ('a, msg) result;
123
-
}
124
-
125
-
let int = { name = "int"; ty = Basic Int; description = [ "Native integer" ] }
126
-
127
-
let int32 =
128
-
{ name = "int32"; ty = Basic Int32; description = [ "32-bit integer" ] }
129
-
130
-
let int64 =
131
-
{ name = "int64"; ty = Basic Int64; description = [ "64-bit integer" ] }
132
-
133
-
let bool = { name = "bool"; ty = Basic Bool; description = [ "Boolean" ] }
134
-
135
-
let float =
136
-
{
137
-
name = "float";
138
-
ty = Basic Float;
139
-
description = [ "Floating-point number" ];
140
-
}
141
-
142
-
let string =
143
-
{ name = "string"; ty = Basic String; description = [ "String" ] }
144
-
145
-
let char = { name = "char"; ty = Basic Char; description = [ "Char" ] }
146
-
let unit = { name = "unit"; ty = Unit; description = [ "Unit" ] }
147
-
148
-
let default_types =
149
-
[
150
-
BoxedDef int;
151
-
BoxedDef int32;
152
-
BoxedDef int64;
153
-
BoxedDef bool;
154
-
BoxedDef float;
155
-
BoxedDef string;
156
-
BoxedDef char;
157
-
BoxedDef unit;
158
-
]
159
-
end
160
-
161
-
exception Runtime_error of string * t
162
-
exception Runtime_exception of string * string
163
-
164
-
let map_strings sep fn l = String.concat sep (List.map fn l)
165
-
166
-
let rec to_string t =
167
-
let open Printf in
168
-
match t with
169
-
| Int i -> sprintf "I(%Li)" i
170
-
| Int32 i -> sprintf "I32(%li)" i
171
-
| Bool b -> sprintf "B(%b)" b
172
-
| Float f -> sprintf "F(%g)" f
173
-
| String s -> sprintf "S(%s)" s
174
-
| DateTime s -> sprintf "D(%s)" s
175
-
| Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts)
176
-
| Dict ts ->
177
-
sprintf "{%s}"
178
-
(map_strings ";" (fun (s, t) -> sprintf "%s:%s" s (to_string t)) ts)
179
-
| Base64 s -> sprintf "B64(%s)" s
180
-
| Null -> "N"
181
-
182
-
let rpc_of_t x = x
183
-
let rpc_of_int64 i = Int i
184
-
let rpc_of_int32 i = Int (Int64.of_int32 i)
185
-
let rpc_of_int i = Int (Int64.of_int i)
186
-
let rpc_of_bool b = Bool b
187
-
let rpc_of_float f = Float f
188
-
let rpc_of_string s = String s
189
-
let rpc_of_dateTime s = DateTime s
190
-
let rpc_of_base64 s = Base64 s
191
-
let rpc_of_unit () = Null
192
-
let rpc_of_char x = Int (Int64.of_int (Char.code x))
193
-
194
-
let int64_of_rpc = function
195
-
| Int i -> i
196
-
| String s -> Int64.of_string s
197
-
| x -> failwith (Printf.sprintf "Expected int64, got '%s'" (to_string x))
198
-
199
-
let int32_of_rpc = function
200
-
| Int i -> Int64.to_int32 i
201
-
| String s -> Int32.of_string s
202
-
| x -> failwith (Printf.sprintf "Expected int32, got '%s'" (to_string x))
203
-
204
-
let int_of_rpc = function
205
-
| Int i -> Int64.to_int i
206
-
| String s -> int_of_string s
207
-
| x -> failwith (Printf.sprintf "Expected int, got '%s'" (to_string x))
208
-
209
-
let bool_of_rpc = function
210
-
| Bool b -> b
211
-
| x -> failwith (Printf.sprintf "Expected bool, got '%s'" (to_string x))
212
-
213
-
let float_of_rpc = function
214
-
| Float f -> f
215
-
| Int i -> Int64.to_float i
216
-
| Int32 i -> Int32.to_float i
217
-
| String s -> float_of_string s
218
-
| x -> failwith (Printf.sprintf "Expected float, got '%s'" (to_string x))
219
-
220
-
let string_of_rpc = function
221
-
| String s -> s
222
-
| x -> failwith (Printf.sprintf "Expected string, got '%s'" (to_string x))
223
-
224
-
let dateTime_of_rpc = function
225
-
| DateTime s -> s
226
-
| x -> failwith (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
227
-
228
-
let base64_of_rpc = function _ -> failwith "Base64 Unhandled"
229
-
230
-
let unit_of_rpc = function
231
-
| Null -> ()
232
-
| x -> failwith (Printf.sprintf "Expected unit, got '%s'" (to_string x))
233
-
234
-
let char_of_rpc x =
235
-
let x = int_of_rpc x in
236
-
if x < 0 || x > 255 then failwith (Printf.sprintf "Char out of range (%d)" x)
237
-
else Char.chr x
238
-
239
-
let t_of_rpc t = t
240
-
241
-
let lowerfn = function
242
-
| String s -> String (String.lowercase_ascii s)
243
-
| Enum (String s :: ss) -> Enum (String (String.lowercase_ascii s) :: ss)
244
-
| x -> x
245
-
246
-
module ResultUnmarshallers = struct
247
-
let error_msg m = Error (`Msg m)
248
-
let ok x = Ok x
249
-
250
-
let int64_of_rpc = function
251
-
| Int i -> ok i
252
-
| String s -> (
253
-
try ok (Int64.of_string s)
254
-
with _ ->
255
-
error_msg (Printf.sprintf "Expected int64, got string '%s'" s))
256
-
| x -> error_msg (Printf.sprintf "Expected int64, got '%s'" (to_string x))
257
-
258
-
let int32_of_rpc = function
259
-
| Int i -> ok (Int64.to_int32 i)
260
-
| String s -> (
261
-
try ok (Int32.of_string s)
262
-
with _ ->
263
-
error_msg (Printf.sprintf "Expected int32, got string '%s'" s))
264
-
| x -> error_msg (Printf.sprintf "Expected int32, got '%s'" (to_string x))
265
-
266
-
let int_of_rpc = function
267
-
| Int i -> ok (Int64.to_int i)
268
-
| String s -> (
269
-
try ok (int_of_string s)
270
-
with _ -> error_msg (Printf.sprintf "Expected int, got string '%s'" s))
271
-
| x -> error_msg (Printf.sprintf "Expected int, got '%s'" (to_string x))
272
-
273
-
let bool_of_rpc = function
274
-
| Bool b -> ok b
275
-
| x -> error_msg (Printf.sprintf "Expected bool, got '%s'" (to_string x))
276
-
277
-
let float_of_rpc = function
278
-
| Float f -> ok f
279
-
| Int i -> ok (Int64.to_float i)
280
-
| Int32 i -> ok (Int32.to_float i)
281
-
| String s -> (
282
-
try ok (float_of_string s)
283
-
with _ ->
284
-
error_msg (Printf.sprintf "Expected float, got string '%s'" s))
285
-
| x -> error_msg (Printf.sprintf "Expected float, got '%s'" (to_string x))
286
-
287
-
let string_of_rpc = function
288
-
| String s -> ok s
289
-
| x -> error_msg (Printf.sprintf "Expected string, got '%s'" (to_string x))
290
-
291
-
let dateTime_of_rpc = function
292
-
| DateTime s -> ok s
293
-
| x ->
294
-
error_msg (Printf.sprintf "Expected DateTime, got '%s'" (to_string x))
295
-
296
-
let base64_of_rpc = function _ -> error_msg "Base64 Unhandled"
297
-
298
-
let unit_of_rpc = function
299
-
| Null -> ok ()
300
-
| x -> error_msg (Printf.sprintf "Expected unit, got '%s'" (to_string x))
301
-
302
-
let char_of_rpc x =
303
-
match int_of_rpc x with
304
-
| Ok x ->
305
-
if x < 0 || x > 255 then
306
-
error_msg (Printf.sprintf "Char out of range (%d)" x)
307
-
else ok (Char.chr x)
308
-
| Error y -> Error y
309
-
310
-
let t_of_rpc t = ok t
311
-
end
312
-
313
-
let struct_extend rpc default_rpc =
314
-
match (rpc, default_rpc) with
315
-
| Dict real, Dict default_fields ->
316
-
Dict
317
-
(List.fold_left
318
-
(fun real (f, default) ->
319
-
if List.mem_assoc f real then real else (f, default) :: real)
320
-
real default_fields)
321
-
| _, _ -> rpc
322
-
323
-
type callback = string list -> t -> unit
324
-
type call = { name : string; params : t list; is_notification : bool }
325
-
326
-
let call name params = { name; params; is_notification = false }
327
-
let notification name params = { name; params; is_notification = true }
328
-
329
-
let string_of_call call =
330
-
Printf.sprintf "-> %s(%s)" call.name
331
-
(String.concat "," (List.map to_string call.params))
332
-
333
-
type response = { success : bool; contents : t; is_notification : bool }
334
-
335
-
let string_of_response response =
336
-
Printf.sprintf "<- %s(%s)"
337
-
(if response.success then "success" else "failure")
338
-
(to_string response.contents)
339
-
340
-
(* is_notification is to be set as true only if the call was a notification *)
341
-
342
-
let success v = { success = true; contents = v; is_notification = false }
343
-
let failure v = { success = false; contents = v; is_notification = false }
-203
idl/_old/rpc.mli
-203
idl/_old/rpc.mli
···
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
-
type msg = [ `Msg of string ]
19
-
(** {2 Value} *)
20
-
21
-
type t =
22
-
| Int of int64
23
-
| Int32 of int32
24
-
| Bool of bool
25
-
| Float of float
26
-
| String of string
27
-
| DateTime of string
28
-
| Enum of t list
29
-
| Dict of (string * t) list
30
-
| Base64 of string
31
-
| Null
32
-
33
-
val to_string : t -> string
34
-
35
-
module Version : sig
36
-
type t = int * int * int
37
-
38
-
val compare : t -> t -> int
39
-
end
40
-
41
-
(** {2 Type declarations} *)
42
-
module Types : sig
43
-
type _ basic =
44
-
| Int : int basic
45
-
| Int32 : int32 basic
46
-
| Int64 : int64 basic
47
-
| Bool : bool basic
48
-
| Float : float basic
49
-
| String : string basic
50
-
| Char : char basic
51
-
52
-
type _ typ =
53
-
| Basic : 'a basic -> 'a typ
54
-
| DateTime : string typ
55
-
| Base64 : string typ
56
-
| Array : 'a typ -> 'a array typ
57
-
| List : 'a typ -> 'a list typ
58
-
| Dict : 'a basic * 'b typ -> ('a * 'b) list typ
59
-
| Unit : unit typ
60
-
| Option : 'a typ -> 'a option typ
61
-
| Tuple : 'a typ * 'b typ -> ('a * 'b) typ
62
-
| Tuple3 : 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) typ
63
-
| Tuple4 : 'a typ * 'b typ * 'c typ * 'd typ -> ('a * 'b * 'c * 'd) typ
64
-
| Struct : 'a structure -> 'a typ
65
-
| Variant : 'a variant -> 'a typ
66
-
| Abstract : 'a abstract -> 'a typ
67
-
68
-
and 'a def = { name : string; description : string list; ty : 'a typ }
69
-
and boxed_def = BoxedDef : 'a def -> boxed_def
70
-
71
-
and ('a, 's) field = {
72
-
fname : string;
73
-
fdescription : string list;
74
-
fversion : Version.t option;
75
-
field : 'a typ;
76
-
fdefault : 'a option;
77
-
fget : 's -> 'a;
78
-
fset : 'a -> 's -> 's;
79
-
}
80
-
81
-
and 'a boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
82
-
and field_getter = { field_get : 'a. string -> 'a typ -> ('a, msg) result }
83
-
84
-
and 'a structure = {
85
-
sname : string;
86
-
fields : 'a boxed_field list;
87
-
version : Version.t option;
88
-
constructor : field_getter -> ('a, msg) result;
89
-
}
90
-
91
-
and ('a, 's) tag = {
92
-
tname : string;
93
-
tdescription : string list;
94
-
tversion : Version.t option;
95
-
tcontents : 'a typ;
96
-
tpreview : 's -> 'a option;
97
-
(* Prism *)
98
-
treview : 'a -> 's;
99
-
}
100
-
101
-
and 'a boxed_tag = BoxedTag : ('a, 's) tag -> 's boxed_tag
102
-
and tag_getter = { tget : 'a. 'a typ -> ('a, msg) result }
103
-
104
-
and 'a variant = {
105
-
vname : string;
106
-
variants : 'a boxed_tag list;
107
-
vdefault : 'a option;
108
-
vversion : Version.t option;
109
-
vconstructor : string -> tag_getter -> ('a, msg) result;
110
-
}
111
-
112
-
and 'a abstract = {
113
-
aname : string;
114
-
test_data : 'a list;
115
-
rpc_of : 'a -> t;
116
-
of_rpc : t -> ('a, msg) result;
117
-
}
118
-
119
-
val int : int def
120
-
val int32 : int32 def
121
-
val int64 : int64 def
122
-
val bool : bool def
123
-
val float : float def
124
-
val string : string def
125
-
val char : char def
126
-
val unit : unit def
127
-
val default_types : boxed_def list
128
-
end
129
-
130
-
(** {2 Basic constructors} *)
131
-
132
-
val rpc_of_int64 : int64 -> t
133
-
val rpc_of_int32 : int32 -> t
134
-
val rpc_of_int : int -> t
135
-
val rpc_of_bool : bool -> t
136
-
val rpc_of_float : float -> t
137
-
val rpc_of_string : string -> t
138
-
val rpc_of_dateTime : string -> t
139
-
val rpc_of_base64 : string -> t
140
-
val rpc_of_t : t -> t
141
-
val rpc_of_unit : unit -> t
142
-
val rpc_of_char : char -> t
143
-
val int64_of_rpc : t -> int64
144
-
val int32_of_rpc : t -> int32
145
-
val int_of_rpc : t -> int
146
-
val bool_of_rpc : t -> bool
147
-
val float_of_rpc : t -> float
148
-
val string_of_rpc : t -> string
149
-
val dateTime_of_rpc : t -> string
150
-
val base64_of_rpc : t -> string
151
-
val t_of_rpc : t -> t
152
-
val char_of_rpc : t -> char
153
-
val unit_of_rpc : t -> unit
154
-
155
-
module ResultUnmarshallers : sig
156
-
val int64_of_rpc : t -> (int64, msg) result
157
-
val int32_of_rpc : t -> (int32, msg) result
158
-
val int_of_rpc : t -> (int, msg) result
159
-
val bool_of_rpc : t -> (bool, msg) result
160
-
val float_of_rpc : t -> (float, msg) result
161
-
val string_of_rpc : t -> (string, msg) result
162
-
val dateTime_of_rpc : t -> (string, msg) result
163
-
val base64_of_rpc : t -> (string, msg) result
164
-
val t_of_rpc : t -> (t, msg) result
165
-
val unit_of_rpc : t -> (unit, msg) result
166
-
val char_of_rpc : t -> (char, msg) result
167
-
end
168
-
169
-
(** {2 Calls} *)
170
-
171
-
type callback = string list -> t -> unit
172
-
type call = { name : string; params : t list; is_notification : bool }
173
-
174
-
val call : string -> t list -> call
175
-
val notification : string -> t list -> call
176
-
val string_of_call : call -> string
177
-
178
-
(** {2 Responses} *)
179
-
180
-
type response = { success : bool; contents : t; is_notification : bool }
181
-
182
-
val string_of_response : response -> string
183
-
val success : t -> response
184
-
val failure : t -> response
185
-
186
-
(** {2 Run-time errors} *)
187
-
188
-
exception Runtime_error of string * t
189
-
exception Runtime_exception of string * string
190
-
191
-
val set_debug : bool -> unit
192
-
(** {2 Debug options} *)
193
-
194
-
val get_debug : unit -> bool
195
-
196
-
val lowerfn : t -> t
197
-
(** Helper *)
198
-
199
-
val struct_extend : t -> t -> t
200
-
(** [struct_extend rpc1 rpc2] first checks that [rpc1] and [rpc2] are both
201
-
* dictionaries. If this is the case then [struct_extend] will create a new
202
-
* [Rpc.t] which contains all key-value pairs from [rpc1], as well as all
203
-
* key-value pairs from [rpc2] for which the key does not exist in [rpc1]. *)
-271
idl/_old/rpcmarshal.ml
-271
idl/_old/rpcmarshal.ml
···
1
-
(* Basic type definitions *)
2
-
open Rpc.Types
3
-
4
-
type err = [ `Msg of string ]
5
-
6
-
let tailrec_map f l = List.rev_map f l |> List.rev
7
-
let ( >>| ) x f = match x with Ok x -> Ok (f x) | Error y -> Error y
8
-
let ( >>= ) x f = match x with Ok x -> f x | Error y -> Error y
9
-
let return x = Ok x
10
-
let ok x = Ok x
11
-
12
-
let rec unmarshal : type a. a typ -> Rpc.t -> (a, err) result =
13
-
fun t v ->
14
-
let open Rpc in
15
-
let open Rpc.ResultUnmarshallers in
16
-
let list_helper typ l =
17
-
List.fold_left
18
-
(fun acc v ->
19
-
match (acc, unmarshal typ v) with
20
-
| Ok a, Ok v -> Ok (v :: a)
21
-
| _, Error (`Msg s) ->
22
-
Error
23
-
(`Msg
24
-
(Printf.sprintf
25
-
"Failed to unmarshal array: %s (when unmarshalling: %s)" s
26
-
(Rpc.to_string v)))
27
-
| x, _ -> x)
28
-
(Ok []) l
29
-
>>| List.rev
30
-
in
31
-
match t with
32
-
| Basic Int -> int_of_rpc v
33
-
| Basic Int32 -> int32_of_rpc v
34
-
| Basic Int64 -> int64_of_rpc v
35
-
| Basic Bool -> bool_of_rpc v
36
-
| Basic Float -> float_of_rpc v
37
-
| Basic String -> string_of_rpc v
38
-
| Basic Char -> int_of_rpc v >>| Char.chr
39
-
| DateTime -> dateTime_of_rpc v
40
-
| Base64 -> base64_of_rpc v
41
-
| Array typ -> (
42
-
match v with
43
-
| Enum xs -> list_helper typ xs >>| Array.of_list
44
-
| _ -> Error (`Msg "Expecting Array"))
45
-
| List (Tuple (Basic String, typ)) -> (
46
-
match v with
47
-
| Dict xs ->
48
-
let keys = tailrec_map fst xs in
49
-
let vs = tailrec_map snd xs in
50
-
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
51
-
| _ -> Error (`Msg "Unhandled"))
52
-
| Dict (basic, typ) -> (
53
-
match v with
54
-
| Dict xs -> (
55
-
match basic with
56
-
| String ->
57
-
let keys = tailrec_map fst xs in
58
-
let vs = tailrec_map snd xs in
59
-
list_helper typ vs >>= fun vs -> return (List.combine keys vs)
60
-
| _ -> Error (`Msg "Expecting something other than a Dict type"))
61
-
| _ -> Error (`Msg "Unhandled"))
62
-
| List typ -> (
63
-
match v with
64
-
| Enum xs -> list_helper typ xs
65
-
| _ -> Error (`Msg "Expecting array"))
66
-
| Unit -> unit_of_rpc v
67
-
| Option t -> (
68
-
match v with
69
-
| Enum [ x ] -> unmarshal t x >>= fun x -> return (Some x)
70
-
| Enum [] -> return None
71
-
| y ->
72
-
Error
73
-
(`Msg
74
-
(Printf.sprintf "Expecting an Enum value, got '%s'"
75
-
(Rpc.to_string y))))
76
-
| Tuple (t1, t2) -> (
77
-
match (v, t2) with
78
-
| Rpc.Enum list, Tuple (_, _) ->
79
-
unmarshal t1 (List.hd list) >>= fun v1 ->
80
-
unmarshal t2 (Rpc.Enum (List.tl list)) >>= fun v2 -> Ok (v1, v2)
81
-
| Rpc.Enum [ x; y ], _ ->
82
-
unmarshal t1 x >>= fun v1 ->
83
-
unmarshal t2 y >>= fun v2 -> Ok (v1, v2)
84
-
| Rpc.Enum _, _ -> Error (`Msg "Too many items in a tuple!")
85
-
| _, _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple"))
86
-
| Tuple3 (t1, t2, t3) -> (
87
-
match v with
88
-
| Rpc.Enum [ x; y; z ] ->
89
-
unmarshal t1 x >>= fun v1 ->
90
-
unmarshal t2 y >>= fun v2 ->
91
-
unmarshal t3 z >>= fun v3 -> Ok (v1, v2, v3)
92
-
| Rpc.Enum _ ->
93
-
Error (`Msg "Expecting precisely 3 items when unmarshalling a Tuple3")
94
-
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple3"))
95
-
| Tuple4 (t1, t2, t3, t4) -> (
96
-
match v with
97
-
| Rpc.Enum [ x; y; z; a ] ->
98
-
unmarshal t1 x >>= fun v1 ->
99
-
unmarshal t2 y >>= fun v2 ->
100
-
unmarshal t3 z >>= fun v3 ->
101
-
unmarshal t4 a >>= fun v4 -> Ok (v1, v2, v3, v4)
102
-
| Rpc.Enum _ ->
103
-
Error
104
-
(`Msg
105
-
"Expecting precisely 4 items in an Enum when unmarshalling a \
106
-
Tuple4")
107
-
| _ -> Error (`Msg "Expecting Rpc.Enum when unmarshalling a tuple4"))
108
-
| Struct { constructor; sname; _ } -> (
109
-
match v with
110
-
| Rpc.Dict keys' ->
111
-
let keys =
112
-
List.map (fun (s, v) -> (String.lowercase_ascii s, v)) keys'
113
-
in
114
-
constructor
115
-
{
116
-
field_get =
117
-
(let x : type a. string -> a typ -> (a, Rpc.msg) result =
118
-
fun s ty ->
119
-
let s = String.lowercase_ascii s in
120
-
match ty with
121
-
| Option x -> (
122
-
try
123
-
List.assoc s keys |> unmarshal x >>= fun o ->
124
-
return (Some o)
125
-
with _ -> return None)
126
-
| y -> (
127
-
try List.assoc s keys |> unmarshal y
128
-
with Not_found ->
129
-
Error
130
-
(`Msg
131
-
(Printf.sprintf
132
-
"No value found for key: '%s' when \
133
-
unmarshalling '%s'"
134
-
s sname)))
135
-
in
136
-
x);
137
-
}
138
-
| _ ->
139
-
Error
140
-
(`Msg
141
-
(Printf.sprintf "Expecting Rpc.Dict when unmarshalling a '%s'"
142
-
sname)))
143
-
| Variant { vconstructor; _ } ->
144
-
(match v with
145
-
| Rpc.String name -> ok (name, Rpc.Null)
146
-
| Rpc.Enum [ Rpc.String name; contents ] -> ok (name, contents)
147
-
| _ ->
148
-
Error (`Msg "Expecting String or Enum when unmarshalling a variant"))
149
-
>>= fun (name, contents) ->
150
-
let constr = { tget = (fun typ -> unmarshal typ contents) } in
151
-
vconstructor name constr
152
-
| Abstract { of_rpc; _ } -> of_rpc v
153
-
154
-
let rec marshal : type a. a typ -> a -> Rpc.t =
155
-
fun t v ->
156
-
let open Rpc in
157
-
let rpc_of_basic : type a. a basic -> a -> Rpc.t =
158
-
fun t v ->
159
-
match t with
160
-
| Int -> rpc_of_int v
161
-
| Int32 -> rpc_of_int32 v
162
-
| Int64 -> rpc_of_int64 v
163
-
| Bool -> rpc_of_bool v
164
-
| Float -> rpc_of_float v
165
-
| String -> rpc_of_string v
166
-
| Char -> rpc_of_int (Char.code v)
167
-
in
168
-
match t with
169
-
| Basic t -> rpc_of_basic t v
170
-
| DateTime -> rpc_of_dateTime v
171
-
| Base64 -> rpc_of_base64 v
172
-
| Array typ -> Enum (tailrec_map (marshal typ) (Array.to_list v))
173
-
| List (Tuple (Basic String, typ)) ->
174
-
Dict (tailrec_map (fun (x, y) -> (x, marshal typ y)) v)
175
-
| List typ -> Enum (tailrec_map (marshal typ) v)
176
-
| Dict (String, typ) ->
177
-
Rpc.Dict (tailrec_map (fun (k, v) -> (k, marshal typ v)) v)
178
-
| Dict (basic, typ) ->
179
-
Rpc.Enum
180
-
(tailrec_map
181
-
(fun (k, v) -> Rpc.Enum [ rpc_of_basic basic k; marshal typ v ])
182
-
v)
183
-
| Unit -> rpc_of_unit v
184
-
| Option ty ->
185
-
Rpc.Enum (match v with Some x -> [ marshal ty x ] | None -> [])
186
-
| Tuple (x, (Tuple (_, _) as y)) -> (
187
-
match marshal y (snd v) with
188
-
| Rpc.Enum xs -> Rpc.Enum (marshal x (fst v) :: xs)
189
-
| _ -> failwith "Marshalling a tuple should always give an Enum")
190
-
| Tuple (x, y) -> Rpc.Enum [ marshal x (fst v); marshal y (snd v) ]
191
-
| Tuple3 (x, y, z) ->
192
-
let vx, vy, vz = v in
193
-
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz ]
194
-
| Tuple4 (x, y, z, a) ->
195
-
let vx, vy, vz, va = v in
196
-
Rpc.Enum [ marshal x vx; marshal y vy; marshal z vz; marshal a va ]
197
-
| Struct { fields; _ } ->
198
-
let fields =
199
-
List.fold_left
200
-
(fun acc f ->
201
-
match f with
202
-
| BoxedField f -> (
203
-
let value = marshal f.field (f.fget v) in
204
-
match (f.field, value) with
205
-
| Option _, Rpc.Enum [] -> acc
206
-
| Option _, Rpc.Enum [ x ] -> (f.fname, x) :: acc
207
-
| _, _ -> (f.fname, value) :: acc))
208
-
[] fields
209
-
in
210
-
Rpc.Dict fields
211
-
| Variant { variants; _ } ->
212
-
List.fold_left
213
-
(fun acc t ->
214
-
match t with
215
-
| BoxedTag t -> (
216
-
match t.tpreview v with
217
-
| Some x -> (
218
-
match marshal t.tcontents x with
219
-
| Rpc.Null -> Rpc.String t.tname
220
-
| y -> Rpc.Enum [ Rpc.String t.tname; y ])
221
-
| None -> acc))
222
-
Rpc.Null variants
223
-
| Abstract { rpc_of; _ } -> rpc_of v
224
-
225
-
let ocaml_of_basic : type a. a basic -> string = function
226
-
| Int64 -> "int64"
227
-
| Int32 -> "int32"
228
-
| Int -> "int"
229
-
| String -> "string"
230
-
| Float -> "float"
231
-
| Bool -> "bool"
232
-
| Char -> "char"
233
-
234
-
let rec ocaml_of_t : type a. a typ -> string = function
235
-
| Basic b -> ocaml_of_basic b
236
-
| DateTime -> "string"
237
-
| Base64 -> "base64"
238
-
| Array t -> ocaml_of_t t ^ " list"
239
-
| List t -> ocaml_of_t t ^ " list"
240
-
| Dict (b, t) ->
241
-
Printf.sprintf "(%s * %s) list" (ocaml_of_basic b) (ocaml_of_t t)
242
-
| Unit -> "unit"
243
-
| Option t -> ocaml_of_t t ^ " option"
244
-
| Tuple (a, b) -> Printf.sprintf "(%s * %s)" (ocaml_of_t a) (ocaml_of_t b)
245
-
| Tuple3 (a, b, c) ->
246
-
Printf.sprintf "(%s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
247
-
(ocaml_of_t c)
248
-
| Tuple4 (a, b, c, d) ->
249
-
Printf.sprintf "(%s * %s * %s * %s)" (ocaml_of_t a) (ocaml_of_t b)
250
-
(ocaml_of_t c) (ocaml_of_t d)
251
-
| Struct { fields; _ } ->
252
-
let fields =
253
-
List.map
254
-
(function
255
-
| BoxedField f ->
256
-
Printf.sprintf "%s: %s;" f.fname (ocaml_of_t f.field))
257
-
fields
258
-
in
259
-
Printf.sprintf "{ %s }" (String.concat " " fields)
260
-
| Variant { variants; _ } ->
261
-
let tags =
262
-
List.map
263
-
(function
264
-
| BoxedTag t ->
265
-
Printf.sprintf "| %s (%s) (** %s *)" t.tname
266
-
(ocaml_of_t t.tcontents)
267
-
(String.concat " " t.tdescription))
268
-
variants
269
-
in
270
-
String.concat " " tags
271
-
| Abstract _ -> "<abstract>"
-47
idl/dune
-47
idl/dune
···
1
-
(library
2
-
(name js_top_worker_rpc)
3
-
(public_name js_top_worker-rpc)
4
-
(modules toplevel_api_gen transport)
5
-
(libraries rresult mime_printer merlin-lib.query_protocol rpclib rpclib.json))
6
-
7
1
(library
8
2
(name js_top_worker_message)
9
3
(public_name js_top_worker-rpc.message)
···
13
7
(pps js_of_ocaml-ppx)))
14
8
15
9
(library
16
-
(name js_top_worker_client)
17
-
(public_name js_top_worker-client)
18
-
(modules js_top_worker_client)
19
-
(libraries js_top_worker-rpc lwt brr rpclib.json)
20
-
(preprocess
21
-
(pps js_of_ocaml-ppx)))
22
-
23
-
(library
24
-
(name js_top_worker_client_fut)
25
-
(public_name js_top_worker-client_fut)
26
-
(modules js_top_worker_client_fut)
27
-
(libraries js_top_worker-rpc rpclib.json brr)
28
-
(preprocess
29
-
(pps js_of_ocaml-ppx)))
30
-
31
-
(library
32
10
(name js_top_worker_client_msg)
33
11
(public_name js_top_worker-client.msg)
34
12
(modules js_top_worker_client_msg)
35
13
(libraries js_top_worker-rpc.message lwt brr js_of_ocaml)
36
14
(preprocess
37
15
(pps js_of_ocaml-ppx)))
38
-
39
-
(library
40
-
(name js_top_worker_rpc_def)
41
-
(modules toplevel_api)
42
-
(enabled_if
43
-
(and (>= %{ocaml_version} 4.12) (not %{ocaml-config:ox})))
44
-
(libraries mime_printer merlin-lib.query_protocol)
45
-
(preprocess
46
-
(pps ppx_deriving_rpc)))
47
-
48
-
(rule
49
-
(target toplevel_api_gen.ml.gen)
50
-
(enabled_if
51
-
(and (>= %{ocaml_version} 4.12) (not %{ocaml-config:ox})))
52
-
(action
53
-
(with-stderr-to
54
-
%{target}
55
-
(run ocamlc -stop-after parsing -dsource %{dep:toplevel_api.pp.ml}))))
56
-
57
-
(rule
58
-
(alias runtest)
59
-
(enabled_if
60
-
(and (>= %{ocaml_version} 4.12) (not %{ocaml-config:ox})))
61
-
(action
62
-
(diff toplevel_api_gen.ml toplevel_api_gen.ml.gen)))
-137
idl/js_top_worker_client.ml
-137
idl/js_top_worker_client.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 Lwt_mvar.t * int) Queue.t;
17
-
}
18
-
19
-
type rpc = Rpc.call -> Rpc.response Lwt.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
-
Lwt.async (fun () ->
27
-
match Queue.take_opt context.waiting with
28
-
| None -> Lwt.return ()
29
-
| Some (mv, outstanding_execution) ->
30
-
Brr.G.stop_timer outstanding_execution;
31
-
let msg = Message.Ev.data (Brr.Ev.as_type msg) in
32
-
Js_of_ocaml.Console.console##log
33
-
(Js_of_ocaml.Js.string
34
-
"Client received the following, to be converted to an OCaml \
35
-
string");
36
-
Js_of_ocaml.Console.console##log msg;
37
-
let msg = Js_of_ocaml.Js.to_string msg in
38
-
(* log (Printf.sprintf "Client received: %s" msg); *)
39
-
Lwt_mvar.put mv (Ok (Transport.Json.response_of_string msg)))
40
-
41
-
let rpc : context -> Rpc.call -> Rpc.response Lwt.t =
42
-
fun context call ->
43
-
let open Lwt in
44
-
let jv = Transport.Json.string_of_call call |> Js_of_ocaml.Js.string in
45
-
(* log (Printf.sprintf "Client sending: %s" jv); *)
46
-
let mv = Lwt_mvar.create_empty () in
47
-
let outstanding_execution =
48
-
Brr.G.set_timeout ~ms:context.timeout (fun () ->
49
-
Lwt.async (fun () -> Lwt_mvar.put mv (Error Timeout));
50
-
Worker.terminate context.worker;
51
-
context.timeout_fn ())
52
-
in
53
-
Queue.push (mv, outstanding_execution) context.waiting;
54
-
Worker.post context.worker jv;
55
-
Lwt_mvar.take mv >>= fun r ->
56
-
match r with
57
-
| Ok jv ->
58
-
let response = jv in
59
-
Lwt.return response
60
-
| Error exn -> Lwt.fail exn
61
-
62
-
let start url timeout timeout_fn : rpc =
63
-
let worker = Worker.create (Jstr.v url) in
64
-
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
65
-
let _listener =
66
-
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
67
-
in
68
-
rpc context
69
-
70
-
module Rpc_lwt = Idl.Make (Lwt)
71
-
module Wraw = Toplevel_api_gen.Make (Rpc_lwt.GenClient ())
72
-
73
-
module W : sig
74
-
type init_config = Toplevel_api_gen.init_config
75
-
type err = Toplevel_api_gen.err
76
-
type exec_result = Toplevel_api_gen.exec_result
77
-
78
-
val init :
79
-
rpc ->
80
-
Toplevel_api_gen.init_config ->
81
-
(unit, Toplevel_api_gen.err) result Lwt.t
82
-
83
-
val create_env :
84
-
rpc ->
85
-
string ->
86
-
(unit, Toplevel_api_gen.err) result Lwt.t
87
-
88
-
val destroy_env :
89
-
rpc ->
90
-
string ->
91
-
(unit, Toplevel_api_gen.err) result Lwt.t
92
-
93
-
val list_envs :
94
-
rpc ->
95
-
(string list, Toplevel_api_gen.err) result Lwt.t
96
-
97
-
val setup :
98
-
rpc ->
99
-
string ->
100
-
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
101
-
102
-
val exec :
103
-
rpc ->
104
-
string ->
105
-
string ->
106
-
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
107
-
108
-
val exec_toplevel :
109
-
rpc ->
110
-
string ->
111
-
string ->
112
-
(Toplevel_api_gen.exec_toplevel_result, Toplevel_api_gen.err) result Lwt.t
113
-
114
-
val query_errors :
115
-
rpc ->
116
-
string ->
117
-
string option ->
118
-
string list ->
119
-
bool ->
120
-
string ->
121
-
(Toplevel_api_gen.error list, Toplevel_api_gen.err) result Lwt.t
122
-
end = struct
123
-
type init_config = Toplevel_api_gen.init_config
124
-
type err = Toplevel_api_gen.err
125
-
type exec_result = Toplevel_api_gen.exec_result
126
-
127
-
let init rpc a = Wraw.init rpc a |> Rpc_lwt.T.get
128
-
let create_env rpc env_id = Wraw.create_env rpc env_id |> Rpc_lwt.T.get
129
-
let destroy_env rpc env_id = Wraw.destroy_env rpc env_id |> Rpc_lwt.T.get
130
-
let list_envs rpc = Wraw.list_envs rpc () |> Rpc_lwt.T.get
131
-
let setup rpc env_id = Wraw.setup rpc env_id |> Rpc_lwt.T.get
132
-
let exec rpc env_id phrase = Wraw.exec rpc env_id phrase |> Rpc_lwt.T.get
133
-
let exec_toplevel rpc env_id script = Wraw.exec_toplevel rpc env_id script |> Rpc_lwt.T.get
134
-
135
-
let query_errors rpc env_id id deps is_toplevel doc =
136
-
Wraw.query_errors rpc env_id id deps is_toplevel doc |> Rpc_lwt.T.get
137
-
end
-76
idl/js_top_worker_client.mli
-76
idl/js_top_worker_client.mli
···
1
-
(* Worker_rpc *)
2
-
3
-
open Js_top_worker_rpc
4
-
5
-
(** Functions to facilitate RPC calls to web workers. *)
6
-
7
-
exception Timeout
8
-
(** When RPC calls take too long, the Lwt promise is set to failed state with
9
-
this exception. *)
10
-
11
-
type rpc = Rpc.call -> Rpc.response Lwt.t
12
-
(** RPC function for communicating with the worker. This is used by each RPC
13
-
function declared in {!W} *)
14
-
15
-
val start : string -> int -> (unit -> unit) -> rpc
16
-
(** [start url timeout timeout_fn] initialises a web worker from [url] and
17
-
starts communications with it. [timeout] is the number of seconds to wait
18
-
for a response from any RPC before raising an error, and [timeout_fn] is
19
-
called when a timeout occurs. Returns the {!type-rpc} function used in the
20
-
RPC calls. *)
21
-
22
-
module W : sig
23
-
(** {2 Type declarations}
24
-
25
-
The following types are redeclared here for convenience. *)
26
-
27
-
type init_config = Toplevel_api_gen.init_config
28
-
type err = Toplevel_api_gen.err
29
-
type exec_result = Toplevel_api_gen.exec_result
30
-
31
-
(** {2 RPC calls}
32
-
33
-
The first parameter of these calls is the rpc function returned by
34
-
{!val-start}. If any of these calls fails to receive a response from the
35
-
worker by the timeout set in the {!val-start} call, the {!Lwt} thread will
36
-
be {{!Lwt.fail}failed}. *)
37
-
38
-
val init : rpc -> init_config -> (unit, err) result Lwt.t
39
-
(** Initialise the toplevel. This must be called before any other API. *)
40
-
41
-
val create_env : rpc -> string -> (unit, err) result Lwt.t
42
-
(** Create a new isolated execution environment with the given ID. *)
43
-
44
-
val destroy_env : rpc -> string -> (unit, err) result Lwt.t
45
-
(** Destroy an execution environment. *)
46
-
47
-
val list_envs : rpc -> (string list, err) result Lwt.t
48
-
(** List all existing environment IDs. *)
49
-
50
-
val setup : rpc -> string -> (exec_result, err) result Lwt.t
51
-
(** Start the toplevel for the given environment. If [env_id] is empty string,
52
-
uses the default environment. Return value is the initial blurb printed
53
-
when starting a toplevel. Note that the toplevel must be initialised first. *)
54
-
55
-
val exec : rpc -> string -> string -> (exec_result, err) result Lwt.t
56
-
(** Execute a phrase using the toplevel. If [env_id] is empty string, uses the
57
-
default environment. The toplevel must have been initialised first. *)
58
-
59
-
val exec_toplevel :
60
-
rpc ->
61
-
string ->
62
-
string ->
63
-
(Toplevel_api_gen.exec_toplevel_result, err) result Lwt.t
64
-
(** Execute a toplevel script. If [env_id] is empty string, uses the default
65
-
environment. The toplevel must have been initialised first. *)
66
-
67
-
val query_errors :
68
-
rpc ->
69
-
string ->
70
-
string option ->
71
-
string list ->
72
-
bool ->
73
-
string ->
74
-
(Toplevel_api_gen.error list, err) result Lwt.t
75
-
(** Query the toplevel for errors. [env_id] specifies the environment. *)
76
-
end
-97
idl/js_top_worker_client_fut.ml
-97
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 = Message.Ev.data (Brr.Ev.as_type msg) in
31
-
(* Js_of_ocaml.Console.console##log (Js_of_ocaml.Js.string "Client received the following, to be converted to an OCaml string"); *)
32
-
(* Js_of_ocaml.Console.console##log msg; *)
33
-
let msg = Js_of_ocaml.Js.to_string msg in
34
-
(* log (Printf.sprintf "Client received: %s" msg); *)
35
-
mv (Ok (Transport.Json.response_of_string msg))
36
-
37
-
let rpc : context -> Rpc.call -> Rpc.response Fut.t =
38
-
fun context call ->
39
-
let open Fut.Syntax in
40
-
let jv = Transport.Json.string_of_call call |> Js_of_ocaml.Js.string in
41
-
(* log (Printf.sprintf "Client sending: %s" jv); *)
42
-
let v, mv = Fut.create () in
43
-
let outstanding_execution =
44
-
Brr.G.set_timeout ~ms:context.timeout (fun () ->
45
-
mv (Error Timeout);
46
-
Worker.terminate context.worker;
47
-
context.timeout_fn ())
48
-
in
49
-
Queue.push (mv, outstanding_execution) context.waiting;
50
-
Worker.post context.worker jv;
51
-
let* r = v in
52
-
match r with
53
-
| Ok jv ->
54
-
let response = jv in
55
-
Fut.return response
56
-
| Error exn -> raise exn
57
-
58
-
let start url timeout timeout_fn : rpc =
59
-
let worker = Worker.create (Jstr.v url) in
60
-
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
61
-
let _listener =
62
-
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
63
-
in
64
-
rpc context
65
-
66
-
module M = struct
67
-
include Fut
68
-
69
-
let fail e = raise e
70
-
end
71
-
72
-
module Rpc_fut = Idl.Make (M)
73
-
module Wraw = Toplevel_api_gen.Make (Rpc_fut.GenClient ())
74
-
75
-
module W = struct
76
-
type init_config = Toplevel_api_gen.init_config
77
-
type err = Toplevel_api_gen.err
78
-
type exec_result = Toplevel_api_gen.exec_result
79
-
80
-
let init rpc a = Wraw.init rpc a |> Rpc_fut.T.get
81
-
let create_env rpc env_id = Wraw.create_env rpc env_id |> Rpc_fut.T.get
82
-
let destroy_env rpc env_id = Wraw.destroy_env rpc env_id |> Rpc_fut.T.get
83
-
let list_envs rpc = Wraw.list_envs rpc () |> Rpc_fut.T.get
84
-
let setup rpc env_id = Wraw.setup rpc env_id |> Rpc_fut.T.get
85
-
let exec rpc env_id phrase = Wraw.exec rpc env_id phrase |> Rpc_fut.T.get
86
-
87
-
let query_errors rpc env_id id deps is_toplevel doc =
88
-
Wraw.query_errors rpc env_id id deps is_toplevel doc |> Rpc_fut.T.get
89
-
90
-
let exec_toplevel rpc env_id doc = Wraw.exec_toplevel rpc env_id doc |> Rpc_fut.T.get
91
-
92
-
let complete_prefix rpc env_id id deps is_toplevel doc pos =
93
-
Wraw.complete_prefix rpc env_id id deps is_toplevel doc pos |> Rpc_fut.T.get
94
-
95
-
let type_enclosing rpc env_id id deps is_toplevel doc pos =
96
-
Wraw.type_enclosing rpc env_id id deps is_toplevel doc pos |> Rpc_fut.T.get
97
-
end
-341
idl/toplevel_api.ml
-341
idl/toplevel_api.ml
···
1
-
(** IDL for talking to the toplevel webworker *)
2
-
3
-
open Rpc
4
-
open Idl
5
-
6
-
let sockpath =
7
-
match Sys.getenv_opt "JS_TOP_WORKER_SOCK" with
8
-
| Some path -> path
9
-
| None -> "/tmp/js_top_worker.sock"
10
-
11
-
open Merlin_kernel
12
-
module Location = Ocaml_parsing.Location
13
-
14
-
type lexing_position = Lexing.position = {
15
-
pos_fname: string;
16
-
pos_lnum: int;
17
-
pos_bol: int;
18
-
pos_cnum: int;
19
-
} [@@deriving rpcty]
20
-
21
-
type location = Location.t = {
22
-
loc_start: lexing_position;
23
-
loc_end: lexing_position;
24
-
loc_ghost: bool;
25
-
} [@@deriving rpcty]
26
-
27
-
type location_error_source = Location.error_source =
28
-
| Lexer
29
-
| Parser
30
-
| Typer
31
-
| Warning
32
-
| Unknown
33
-
| Env
34
-
| Config [@@deriving rpcty]
35
-
36
-
type location_report_kind = Location.report_kind =
37
-
| Report_error
38
-
| Report_warning of string
39
-
| Report_warning_as_error of string
40
-
| Report_alert of string
41
-
| Report_alert_as_error of string [@@deriving rpcty]
42
-
43
-
type source = string [@@deriving rpcty]
44
-
45
-
(** CMIs are provided either statically or as URLs to be downloaded on demand *)
46
-
47
-
(** Dynamic cmis are loaded from beneath the given url. In addition the
48
-
top-level modules are specified, and prefixes for other modules. For
49
-
example, for the OCaml standard library, a user might pass:
50
-
51
-
{[
52
-
{ dcs_url="/static/stdlib";
53
-
dcs_toplevel_modules=["Stdlib"];
54
-
dcs_file_prefixes=["stdlib__"]; }
55
-
]}
56
-
57
-
In which case, merlin will expect to be able to download a valid file
58
-
from the url ["/static/stdlib/stdlib.cmi"] corresponding to the
59
-
specified toplevel module, and it will also attempt to download any
60
-
module with the prefix ["Stdlib__"] from the same base url, so for
61
-
example if an attempt is made to look up the module ["Stdlib__Foo"]
62
-
then merlin-js will attempt to download a file from the url
63
-
["/static/stdlib/stdlib__Foo.cmi"].
64
-
*)
65
-
66
-
type dynamic_cmis = {
67
-
dcs_url : string;
68
-
dcs_toplevel_modules : string list;
69
-
dcs_file_prefixes : string list;
70
-
}
71
-
72
-
and static_cmi = {
73
-
sc_name : string; (* capitalised, e.g. 'Stdlib' *)
74
-
sc_content : string;
75
-
}
76
-
77
-
and cmis = {
78
-
static_cmis : static_cmi list;
79
-
dynamic_cmis : dynamic_cmis list;
80
-
} [@@deriving rpcty]
81
-
82
-
type action =
83
-
| Complete_prefix of source * Msource.position
84
-
| Type_enclosing of source * Msource.position
85
-
| All_errors of source
86
-
| Add_cmis of cmis
87
-
88
-
type error = {
89
-
kind : location_report_kind;
90
-
loc: location;
91
-
main : string;
92
-
sub : string list;
93
-
source : location_error_source;
94
-
} [@@deriving rpcty]
95
-
96
-
type error_list = error list [@@deriving rpcty]
97
-
98
-
type kind_ty =
99
-
Constructor
100
-
| Keyword
101
-
| Label
102
-
| MethodCall
103
-
| Modtype
104
-
| Module
105
-
| Type
106
-
| Value
107
-
| Variant [@@deriving rpcty]
108
-
109
-
type query_protocol_compl_entry = {
110
-
name: string;
111
-
kind: kind_ty;
112
-
desc: string;
113
-
info: string;
114
-
deprecated: bool;
115
-
} [@@deriving rpcty]
116
-
117
-
118
-
type completions = {
119
-
from: int;
120
-
to_: int;
121
-
entries : query_protocol_compl_entry list
122
-
} [@@deriving rpcty]
123
-
124
-
type msource_position =
125
-
| Start
126
-
| Offset of int
127
-
| Logical of int * int
128
-
| End [@@deriving rpcty]
129
-
130
-
type is_tail_position =
131
-
| No | Tail_position | Tail_call [@@deriving rpcty]
132
-
133
-
type index_or_string =
134
-
| Index of int
135
-
| String of string [@@deriving rpcty]
136
-
137
-
138
-
type typed_enclosings = location * index_or_string * is_tail_position [@@deriving rpcty]
139
-
type typed_enclosings_list = typed_enclosings list [@@deriving rpcty]
140
-
let report_source_to_string = function
141
-
| Location.Lexer -> "lexer"
142
-
| Location.Parser -> "parser"
143
-
| Location.Typer -> "typer"
144
-
| Location.Warning -> "warning" (* todo incorrect ?*)
145
-
| Location.Unknown -> "unknown"
146
-
| Location.Env -> "env"
147
-
| Location.Config -> "config"
148
-
149
-
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
150
-
[@@deriving rpcty]
151
-
(** An area to be highlighted *)
152
-
type encoding = Mime_printer.encoding = | Noencoding | Base64 [@@deriving rpcty]
153
-
154
-
type mime_val = Mime_printer.t = {
155
-
mime_type : string;
156
-
encoding : encoding;
157
-
data : string;
158
-
}
159
-
[@@deriving rpcty]
160
-
161
-
type exec_result = {
162
-
stdout : string option;
163
-
stderr : string option;
164
-
sharp_ppf : string option;
165
-
caml_ppf : string option;
166
-
highlight : highlight option;
167
-
mime_vals : mime_val list;
168
-
}
169
-
[@@deriving rpcty]
170
-
(** Represents the result of executing a toplevel phrase *)
171
-
172
-
type script_parts = (int * int) list (* Input length and output length *)
173
-
[@@deriving rpcty]
174
-
175
-
type exec_toplevel_result = {
176
-
script : string;
177
-
parts : script_parts;
178
-
mime_vals : mime_val list;
179
-
}
180
-
[@@deriving rpcty]
181
-
(** Represents the result of executing a toplevel script *)
182
-
183
-
type cma = {
184
-
url : string; (** URL where the cma is available *)
185
-
fn : string; (** Name of the 'wrapping' function *)
186
-
}
187
-
[@@deriving rpcty]
188
-
189
-
type init_config = {
190
-
findlib_requires : string list; (** Findlib packages to require *)
191
-
stdlib_dcs : string option; (** URL to the dynamic cmis for the OCaml standard library *)
192
-
findlib_index : string option; (** URL to the findlib_index.json file. Defaults to "findlib_index.json" *)
193
-
execute : bool (** Whether this session should support execution or not. *)
194
-
} [@@deriving rpcty]
195
-
type err = InternalError of string [@@deriving rpcty]
196
-
197
-
type opt_id = string option [@@deriving rpcty]
198
-
199
-
type env_id = string [@@deriving rpcty]
200
-
(** Environment identifier. If empty string, uses the default environment. *)
201
-
202
-
type env_id_list = string list [@@deriving rpcty]
203
-
(** List of environment identifiers *)
204
-
205
-
type dependencies = string list [@@deriving rpcty]
206
-
(** The ids of the cells that are dependencies *)
207
-
208
-
module E = Idl.Error.Make (struct
209
-
type t = err
210
-
211
-
let t = err
212
-
let internal_error_of e = Some (InternalError (Printexc.to_string e))
213
-
end)
214
-
215
-
let err = E.error
216
-
217
-
module Make (R : RPC) = struct
218
-
open R
219
-
220
-
let description =
221
-
Interface.
222
-
{
223
-
name = "Toplevel";
224
-
namespace = None;
225
-
description =
226
-
[ "Functions for manipulating the toplevel worker thread" ];
227
-
version = (1, 0, 0);
228
-
}
229
-
230
-
let implementation = implement description
231
-
let unit_p = Param.mk Types.unit
232
-
let phrase_p = Param.mk ~description:["The OCaml phrase to execute"] Types.string
233
-
let id_p = Param.mk opt_id
234
-
let env_id_p = Param.mk ~name:"env_id" ~description:["Environment ID (empty string for default)"] env_id
235
-
let env_id_list_p = Param.mk env_id_list
236
-
let dependencies_p = Param.mk dependencies
237
-
let exec_result_p = Param.mk exec_result
238
-
239
-
let source_p = Param.mk source
240
-
let position_p = Param.mk msource_position
241
-
242
-
let completions_p = Param.mk completions
243
-
let error_list_p = Param.mk error_list
244
-
let typed_enclosings_p = Param.mk typed_enclosings_list
245
-
let is_toplevel_p = Param.mk ~name:"is_toplevel" Types.bool
246
-
247
-
let toplevel_script_p = Param.mk ~description:[
248
-
"A toplevel script is a sequence of toplevel phrases interspersed with";
249
-
"The output from the toplevel. Each phase must be preceded by '# ', and";
250
-
"the output from the toplevel is indented by 2 spaces."
251
-
] Types.string
252
-
253
-
let exec_toplevel_result_p = Param.mk exec_toplevel_result
254
-
255
-
let init_libs =
256
-
Param.mk ~name:"init_libs"
257
-
~description:
258
-
[
259
-
"Configuration for the toplevel.";
260
-
]
261
-
init_config
262
-
263
-
let init =
264
-
declare "init"
265
-
[ "Initialise the toplevel. This must be called before any other API." ]
266
-
(init_libs @-> returning unit_p err)
267
-
268
-
(** {2 Environment Management} *)
269
-
270
-
let create_env =
271
-
declare "create_env"
272
-
[
273
-
"Create a new isolated execution environment with the given ID.";
274
-
"Returns unit on success. The environment must be set up with";
275
-
"setup_env before use.";
276
-
]
277
-
(env_id_p @-> returning unit_p err)
278
-
279
-
let destroy_env =
280
-
declare "destroy_env"
281
-
[
282
-
"Destroy an execution environment, freeing its resources.";
283
-
"The environment ID must exist.";
284
-
]
285
-
(env_id_p @-> returning unit_p err)
286
-
287
-
let list_envs =
288
-
declare "list_envs"
289
-
[ "List all existing environment IDs." ]
290
-
(unit_p @-> returning env_id_list_p err)
291
-
292
-
let setup =
293
-
declare "setup"
294
-
[
295
-
"Start the toplevel for the given environment. Return value is the";
296
-
"initial blurb printed when starting a toplevel. Note that the";
297
-
"toplevel must be initialised first. If env_id is None, uses the";
298
-
"default environment.";
299
-
]
300
-
(env_id_p @-> returning exec_result_p err)
301
-
302
-
let exec =
303
-
declare "exec"
304
-
[
305
-
"Execute a phrase using the toplevel. The toplevel must have been";
306
-
"initialised first. If env_id is None, uses the default environment.";
307
-
]
308
-
(env_id_p @-> phrase_p @-> returning exec_result_p err)
309
-
310
-
let exec_toplevel =
311
-
declare "exec_toplevel"
312
-
[
313
-
"Execute a toplevel script. The toplevel must have been";
314
-
"initialised first. Returns the updated toplevel script.";
315
-
"If env_id is None, uses the default environment.";
316
-
]
317
-
(env_id_p @-> toplevel_script_p @-> returning exec_toplevel_result_p err)
318
-
319
-
let complete_prefix =
320
-
declare "complete_prefix"
321
-
[
322
-
"Complete a prefix. If env_id is None, uses the default environment.";
323
-
]
324
-
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> position_p @-> returning completions_p err)
325
-
326
-
let query_errors =
327
-
declare "query_errors"
328
-
[
329
-
"Query the errors in the given source.";
330
-
"If env_id is None, uses the default environment.";
331
-
]
332
-
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> returning error_list_p err)
333
-
334
-
let type_enclosing =
335
-
declare "type_enclosing"
336
-
[
337
-
"Get the type of the enclosing expression.";
338
-
"If env_id is None, uses the default environment.";
339
-
]
340
-
(env_id_p @-> id_p @-> dependencies_p @-> is_toplevel_p @-> source_p @-> position_p @-> returning typed_enclosings_p err)
341
-
end
-2309
idl/toplevel_api_gen.ml
-2309
idl/toplevel_api_gen.ml
···
1
-
[@@@ocaml.ppx.context
2
-
{
3
-
tool_name = "ppx_driver";
4
-
include_dirs = [];
5
-
hidden_include_dirs = [];
6
-
load_path = ([], []);
7
-
open_modules = [];
8
-
for_package = None;
9
-
debug = false;
10
-
use_threads = false;
11
-
use_vmthreads = false;
12
-
recursive_types = false;
13
-
principal = false;
14
-
no_alias_deps = false;
15
-
unboxed_types = false;
16
-
unsafe_string = false;
17
-
cookies = [("library-name", "js_top_worker_rpc_def")]
18
-
}]
19
-
[@@@ocaml.text " IDL for talking to the toplevel webworker "]
20
-
open Rpc
21
-
open Idl
22
-
let sockpath =
23
-
match Sys.getenv_opt "JS_TOP_WORKER_SOCK" with
24
-
| Some path -> path
25
-
| None -> "/tmp/js_top_worker.sock"
26
-
open Merlin_kernel
27
-
module Location = Ocaml_parsing.Location
28
-
type lexing_position = Lexing.position =
29
-
{
30
-
pos_fname: string ;
31
-
pos_lnum: int ;
32
-
pos_bol: int ;
33
-
pos_cnum: int }[@@deriving rpcty]
34
-
include
35
-
struct
36
-
let _ = fun (_ : lexing_position) -> ()
37
-
let rec lexing_position_pos_fname : (_, lexing_position) Rpc.Types.field
38
-
=
39
-
{
40
-
Rpc.Types.fname = "pos_fname";
41
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
42
-
Rpc.Types.fdefault = None;
43
-
Rpc.Types.fdescription = [];
44
-
Rpc.Types.fversion = None;
45
-
Rpc.Types.fget = (fun _r -> _r.pos_fname);
46
-
Rpc.Types.fset = (fun v _s -> { _s with pos_fname = v })
47
-
}
48
-
and lexing_position_pos_lnum : (_, lexing_position) Rpc.Types.field =
49
-
{
50
-
Rpc.Types.fname = "pos_lnum";
51
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
52
-
Rpc.Types.fdefault = None;
53
-
Rpc.Types.fdescription = [];
54
-
Rpc.Types.fversion = None;
55
-
Rpc.Types.fget = (fun _r -> _r.pos_lnum);
56
-
Rpc.Types.fset = (fun v _s -> { _s with pos_lnum = v })
57
-
}
58
-
and lexing_position_pos_bol : (_, lexing_position) Rpc.Types.field =
59
-
{
60
-
Rpc.Types.fname = "pos_bol";
61
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
62
-
Rpc.Types.fdefault = None;
63
-
Rpc.Types.fdescription = [];
64
-
Rpc.Types.fversion = None;
65
-
Rpc.Types.fget = (fun _r -> _r.pos_bol);
66
-
Rpc.Types.fset = (fun v _s -> { _s with pos_bol = v })
67
-
}
68
-
and lexing_position_pos_cnum : (_, lexing_position) Rpc.Types.field =
69
-
{
70
-
Rpc.Types.fname = "pos_cnum";
71
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
72
-
Rpc.Types.fdefault = None;
73
-
Rpc.Types.fdescription = [];
74
-
Rpc.Types.fversion = None;
75
-
Rpc.Types.fget = (fun _r -> _r.pos_cnum);
76
-
Rpc.Types.fset = (fun v _s -> { _s with pos_cnum = v })
77
-
}
78
-
and typ_of_lexing_position =
79
-
Rpc.Types.Struct
80
-
({
81
-
Rpc.Types.fields =
82
-
[Rpc.Types.BoxedField lexing_position_pos_fname;
83
-
Rpc.Types.BoxedField lexing_position_pos_lnum;
84
-
Rpc.Types.BoxedField lexing_position_pos_bol;
85
-
Rpc.Types.BoxedField lexing_position_pos_cnum];
86
-
Rpc.Types.sname = "lexing_position";
87
-
Rpc.Types.version = None;
88
-
Rpc.Types.constructor =
89
-
(fun getter ->
90
-
let open Rresult.R in
91
-
(getter.Rpc.Types.field_get "pos_cnum"
92
-
(let open Rpc.Types in Basic Int))
93
-
>>=
94
-
(fun lexing_position_pos_cnum ->
95
-
(getter.Rpc.Types.field_get "pos_bol"
96
-
(let open Rpc.Types in Basic Int))
97
-
>>=
98
-
(fun lexing_position_pos_bol ->
99
-
(getter.Rpc.Types.field_get "pos_lnum"
100
-
(let open Rpc.Types in Basic Int))
101
-
>>=
102
-
(fun lexing_position_pos_lnum ->
103
-
(getter.Rpc.Types.field_get "pos_fname"
104
-
(let open Rpc.Types in Basic String))
105
-
>>=
106
-
(fun lexing_position_pos_fname ->
107
-
return
108
-
{
109
-
pos_fname =
110
-
lexing_position_pos_fname;
111
-
pos_lnum = lexing_position_pos_lnum;
112
-
pos_bol = lexing_position_pos_bol;
113
-
pos_cnum = lexing_position_pos_cnum
114
-
})))))
115
-
} : lexing_position Rpc.Types.structure)
116
-
and lexing_position =
117
-
{
118
-
Rpc.Types.name = "lexing_position";
119
-
Rpc.Types.description = [];
120
-
Rpc.Types.ty = typ_of_lexing_position
121
-
}
122
-
let _ = lexing_position_pos_fname
123
-
and _ = lexing_position_pos_lnum
124
-
and _ = lexing_position_pos_bol
125
-
and _ = lexing_position_pos_cnum
126
-
and _ = typ_of_lexing_position
127
-
and _ = lexing_position
128
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
129
-
type location = Location.t =
130
-
{
131
-
loc_start: lexing_position ;
132
-
loc_end: lexing_position ;
133
-
loc_ghost: bool }[@@deriving rpcty]
134
-
include
135
-
struct
136
-
let _ = fun (_ : location) -> ()
137
-
let rec location_loc_start : (_, location) Rpc.Types.field =
138
-
{
139
-
Rpc.Types.fname = "loc_start";
140
-
Rpc.Types.field = typ_of_lexing_position;
141
-
Rpc.Types.fdefault = None;
142
-
Rpc.Types.fdescription = [];
143
-
Rpc.Types.fversion = None;
144
-
Rpc.Types.fget = (fun _r -> _r.loc_start);
145
-
Rpc.Types.fset = (fun v _s -> { _s with loc_start = v })
146
-
}
147
-
and location_loc_end : (_, location) Rpc.Types.field =
148
-
{
149
-
Rpc.Types.fname = "loc_end";
150
-
Rpc.Types.field = typ_of_lexing_position;
151
-
Rpc.Types.fdefault = None;
152
-
Rpc.Types.fdescription = [];
153
-
Rpc.Types.fversion = None;
154
-
Rpc.Types.fget = (fun _r -> _r.loc_end);
155
-
Rpc.Types.fset = (fun v _s -> { _s with loc_end = v })
156
-
}
157
-
and location_loc_ghost : (_, location) Rpc.Types.field =
158
-
{
159
-
Rpc.Types.fname = "loc_ghost";
160
-
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
161
-
Rpc.Types.fdefault = None;
162
-
Rpc.Types.fdescription = [];
163
-
Rpc.Types.fversion = None;
164
-
Rpc.Types.fget = (fun _r -> _r.loc_ghost);
165
-
Rpc.Types.fset = (fun v _s -> { _s with loc_ghost = v })
166
-
}
167
-
and typ_of_location =
168
-
Rpc.Types.Struct
169
-
({
170
-
Rpc.Types.fields =
171
-
[Rpc.Types.BoxedField location_loc_start;
172
-
Rpc.Types.BoxedField location_loc_end;
173
-
Rpc.Types.BoxedField location_loc_ghost];
174
-
Rpc.Types.sname = "location";
175
-
Rpc.Types.version = None;
176
-
Rpc.Types.constructor =
177
-
(fun getter ->
178
-
let open Rresult.R in
179
-
(getter.Rpc.Types.field_get "loc_ghost"
180
-
(let open Rpc.Types in Basic Bool))
181
-
>>=
182
-
(fun location_loc_ghost ->
183
-
(getter.Rpc.Types.field_get "loc_end"
184
-
typ_of_lexing_position)
185
-
>>=
186
-
(fun location_loc_end ->
187
-
(getter.Rpc.Types.field_get "loc_start"
188
-
typ_of_lexing_position)
189
-
>>=
190
-
(fun location_loc_start ->
191
-
return
192
-
{
193
-
loc_start = location_loc_start;
194
-
loc_end = location_loc_end;
195
-
loc_ghost = location_loc_ghost
196
-
}))))
197
-
} : location Rpc.Types.structure)
198
-
and location =
199
-
{
200
-
Rpc.Types.name = "location";
201
-
Rpc.Types.description = [];
202
-
Rpc.Types.ty = typ_of_location
203
-
}
204
-
let _ = location_loc_start
205
-
and _ = location_loc_end
206
-
and _ = location_loc_ghost
207
-
and _ = typ_of_location
208
-
and _ = location
209
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
210
-
type location_error_source = Location.error_source =
211
-
| Lexer
212
-
| Parser
213
-
| Typer
214
-
| Warning
215
-
| Unknown
216
-
| Env
217
-
| Config [@@deriving rpcty]
218
-
include
219
-
struct
220
-
let _ = fun (_ : location_error_source) -> ()
221
-
let rec typ_of_location_error_source =
222
-
Rpc.Types.Variant
223
-
({
224
-
Rpc.Types.vname = "location_error_source";
225
-
Rpc.Types.variants =
226
-
[BoxedTag
227
-
{
228
-
Rpc.Types.tname = "Lexer";
229
-
Rpc.Types.tcontents = Unit;
230
-
Rpc.Types.tversion = None;
231
-
Rpc.Types.tdescription = [];
232
-
Rpc.Types.tpreview =
233
-
((function | Lexer -> Some () | _ -> None));
234
-
Rpc.Types.treview = ((function | () -> Lexer))
235
-
};
236
-
BoxedTag
237
-
{
238
-
Rpc.Types.tname = "Parser";
239
-
Rpc.Types.tcontents = Unit;
240
-
Rpc.Types.tversion = None;
241
-
Rpc.Types.tdescription = [];
242
-
Rpc.Types.tpreview =
243
-
((function | Parser -> Some () | _ -> None));
244
-
Rpc.Types.treview = ((function | () -> Parser))
245
-
};
246
-
BoxedTag
247
-
{
248
-
Rpc.Types.tname = "Typer";
249
-
Rpc.Types.tcontents = Unit;
250
-
Rpc.Types.tversion = None;
251
-
Rpc.Types.tdescription = [];
252
-
Rpc.Types.tpreview =
253
-
((function | Typer -> Some () | _ -> None));
254
-
Rpc.Types.treview = ((function | () -> Typer))
255
-
};
256
-
BoxedTag
257
-
{
258
-
Rpc.Types.tname = "Warning";
259
-
Rpc.Types.tcontents = Unit;
260
-
Rpc.Types.tversion = None;
261
-
Rpc.Types.tdescription = [];
262
-
Rpc.Types.tpreview =
263
-
((function | Warning -> Some () | _ -> None));
264
-
Rpc.Types.treview = ((function | () -> Warning))
265
-
};
266
-
BoxedTag
267
-
{
268
-
Rpc.Types.tname = "Unknown";
269
-
Rpc.Types.tcontents = Unit;
270
-
Rpc.Types.tversion = None;
271
-
Rpc.Types.tdescription = [];
272
-
Rpc.Types.tpreview =
273
-
((function | Unknown -> Some () | _ -> None));
274
-
Rpc.Types.treview = ((function | () -> Unknown))
275
-
};
276
-
BoxedTag
277
-
{
278
-
Rpc.Types.tname = "Env";
279
-
Rpc.Types.tcontents = Unit;
280
-
Rpc.Types.tversion = None;
281
-
Rpc.Types.tdescription = [];
282
-
Rpc.Types.tpreview =
283
-
((function | Env -> Some () | _ -> None));
284
-
Rpc.Types.treview = ((function | () -> Env))
285
-
};
286
-
BoxedTag
287
-
{
288
-
Rpc.Types.tname = "Config";
289
-
Rpc.Types.tcontents = Unit;
290
-
Rpc.Types.tversion = None;
291
-
Rpc.Types.tdescription = [];
292
-
Rpc.Types.tpreview =
293
-
((function | Config -> Some () | _ -> None));
294
-
Rpc.Types.treview = ((function | () -> Config))
295
-
}];
296
-
Rpc.Types.vdefault = None;
297
-
Rpc.Types.vversion = None;
298
-
Rpc.Types.vconstructor =
299
-
(fun s' t ->
300
-
let s = String.lowercase_ascii s' in
301
-
match s with
302
-
| "lexer" ->
303
-
Rresult.R.bind (t.tget Unit)
304
-
(function | () -> Rresult.R.ok Lexer)
305
-
| "parser" ->
306
-
Rresult.R.bind (t.tget Unit)
307
-
(function | () -> Rresult.R.ok Parser)
308
-
| "typer" ->
309
-
Rresult.R.bind (t.tget Unit)
310
-
(function | () -> Rresult.R.ok Typer)
311
-
| "warning" ->
312
-
Rresult.R.bind (t.tget Unit)
313
-
(function | () -> Rresult.R.ok Warning)
314
-
| "unknown" ->
315
-
Rresult.R.bind (t.tget Unit)
316
-
(function | () -> Rresult.R.ok Unknown)
317
-
| "env" ->
318
-
Rresult.R.bind (t.tget Unit)
319
-
(function | () -> Rresult.R.ok Env)
320
-
| "config" ->
321
-
Rresult.R.bind (t.tget Unit)
322
-
(function | () -> Rresult.R.ok Config)
323
-
| _ ->
324
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
325
-
} : location_error_source Rpc.Types.variant)
326
-
and location_error_source =
327
-
{
328
-
Rpc.Types.name = "location_error_source";
329
-
Rpc.Types.description = [];
330
-
Rpc.Types.ty = typ_of_location_error_source
331
-
}
332
-
let _ = typ_of_location_error_source
333
-
and _ = location_error_source
334
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
335
-
type location_report_kind = Location.report_kind =
336
-
| Report_error
337
-
| Report_warning of string
338
-
| Report_warning_as_error of string
339
-
| Report_alert of string
340
-
| Report_alert_as_error of string [@@deriving rpcty]
341
-
include
342
-
struct
343
-
let _ = fun (_ : location_report_kind) -> ()
344
-
let rec typ_of_location_report_kind =
345
-
Rpc.Types.Variant
346
-
({
347
-
Rpc.Types.vname = "location_report_kind";
348
-
Rpc.Types.variants =
349
-
[BoxedTag
350
-
{
351
-
Rpc.Types.tname = "Report_error";
352
-
Rpc.Types.tcontents = Unit;
353
-
Rpc.Types.tversion = None;
354
-
Rpc.Types.tdescription = [];
355
-
Rpc.Types.tpreview =
356
-
((function | Report_error -> Some () | _ -> None));
357
-
Rpc.Types.treview = ((function | () -> Report_error))
358
-
};
359
-
BoxedTag
360
-
{
361
-
Rpc.Types.tname = "Report_warning";
362
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
363
-
Rpc.Types.tversion = None;
364
-
Rpc.Types.tdescription = [];
365
-
Rpc.Types.tpreview =
366
-
((function | Report_warning a0 -> Some a0 | _ -> None));
367
-
Rpc.Types.treview = ((function | a0 -> Report_warning a0))
368
-
};
369
-
BoxedTag
370
-
{
371
-
Rpc.Types.tname = "Report_warning_as_error";
372
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
373
-
Rpc.Types.tversion = None;
374
-
Rpc.Types.tdescription = [];
375
-
Rpc.Types.tpreview =
376
-
((function
377
-
| Report_warning_as_error a0 -> Some a0
378
-
| _ -> None));
379
-
Rpc.Types.treview =
380
-
((function | a0 -> Report_warning_as_error a0))
381
-
};
382
-
BoxedTag
383
-
{
384
-
Rpc.Types.tname = "Report_alert";
385
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
386
-
Rpc.Types.tversion = None;
387
-
Rpc.Types.tdescription = [];
388
-
Rpc.Types.tpreview =
389
-
((function | Report_alert a0 -> Some a0 | _ -> None));
390
-
Rpc.Types.treview = ((function | a0 -> Report_alert a0))
391
-
};
392
-
BoxedTag
393
-
{
394
-
Rpc.Types.tname = "Report_alert_as_error";
395
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
396
-
Rpc.Types.tversion = None;
397
-
Rpc.Types.tdescription = [];
398
-
Rpc.Types.tpreview =
399
-
((function
400
-
| Report_alert_as_error a0 -> Some a0
401
-
| _ -> None));
402
-
Rpc.Types.treview =
403
-
((function | a0 -> Report_alert_as_error a0))
404
-
}];
405
-
Rpc.Types.vdefault = None;
406
-
Rpc.Types.vversion = None;
407
-
Rpc.Types.vconstructor =
408
-
(fun s' t ->
409
-
let s = String.lowercase_ascii s' in
410
-
match s with
411
-
| "report_error" ->
412
-
Rresult.R.bind (t.tget Unit)
413
-
(function | () -> Rresult.R.ok Report_error)
414
-
| "report_warning" ->
415
-
Rresult.R.bind
416
-
(t.tget (let open Rpc.Types in Basic String))
417
-
(function | a0 -> Rresult.R.ok (Report_warning a0))
418
-
| "report_warning_as_error" ->
419
-
Rresult.R.bind
420
-
(t.tget (let open Rpc.Types in Basic String))
421
-
(function
422
-
| a0 -> Rresult.R.ok (Report_warning_as_error a0))
423
-
| "report_alert" ->
424
-
Rresult.R.bind
425
-
(t.tget (let open Rpc.Types in Basic String))
426
-
(function | a0 -> Rresult.R.ok (Report_alert a0))
427
-
| "report_alert_as_error" ->
428
-
Rresult.R.bind
429
-
(t.tget (let open Rpc.Types in Basic String))
430
-
(function
431
-
| a0 -> Rresult.R.ok (Report_alert_as_error a0))
432
-
| _ ->
433
-
Rresult.R.error_msg (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 list }[@@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 _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 = (fun v _s -> { _s with dcs_toplevel_modules = v })
499
-
}
500
-
and dynamic_cmis_dcs_file_prefixes : (_, dynamic_cmis) Rpc.Types.field =
501
-
{
502
-
Rpc.Types.fname = "dcs_file_prefixes";
503
-
Rpc.Types.field =
504
-
(Rpc.Types.List (let open Rpc.Types in Basic String));
505
-
Rpc.Types.fdefault = None;
506
-
Rpc.Types.fdescription = [];
507
-
Rpc.Types.fversion = None;
508
-
Rpc.Types.fget = (fun _r -> _r.dcs_file_prefixes);
509
-
Rpc.Types.fset = (fun v _s -> { _s with dcs_file_prefixes = v })
510
-
}
511
-
and typ_of_dynamic_cmis =
512
-
Rpc.Types.Struct
513
-
({
514
-
Rpc.Types.fields =
515
-
[Rpc.Types.BoxedField dynamic_cmis_dcs_url;
516
-
Rpc.Types.BoxedField dynamic_cmis_dcs_toplevel_modules;
517
-
Rpc.Types.BoxedField dynamic_cmis_dcs_file_prefixes];
518
-
Rpc.Types.sname = "dynamic_cmis";
519
-
Rpc.Types.version = None;
520
-
Rpc.Types.constructor =
521
-
(fun getter ->
522
-
let open Rresult.R in
523
-
(getter.Rpc.Types.field_get "dcs_file_prefixes"
524
-
(Rpc.Types.List (let open Rpc.Types in Basic String)))
525
-
>>=
526
-
(fun dynamic_cmis_dcs_file_prefixes ->
527
-
(getter.Rpc.Types.field_get "dcs_toplevel_modules"
528
-
(Rpc.Types.List
529
-
(let open Rpc.Types in Basic String)))
530
-
>>=
531
-
(fun dynamic_cmis_dcs_toplevel_modules ->
532
-
(getter.Rpc.Types.field_get "dcs_url"
533
-
(let open Rpc.Types in Basic String))
534
-
>>=
535
-
(fun dynamic_cmis_dcs_url ->
536
-
return
537
-
{
538
-
dcs_url = dynamic_cmis_dcs_url;
539
-
dcs_toplevel_modules =
540
-
dynamic_cmis_dcs_toplevel_modules;
541
-
dcs_file_prefixes =
542
-
dynamic_cmis_dcs_file_prefixes
543
-
}))))
544
-
} : dynamic_cmis Rpc.Types.structure)
545
-
and dynamic_cmis =
546
-
{
547
-
Rpc.Types.name = "dynamic_cmis";
548
-
Rpc.Types.description = [];
549
-
Rpc.Types.ty = typ_of_dynamic_cmis
550
-
}
551
-
and static_cmi_sc_name : (_, static_cmi) Rpc.Types.field =
552
-
{
553
-
Rpc.Types.fname = "sc_name";
554
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
555
-
Rpc.Types.fdefault = None;
556
-
Rpc.Types.fdescription = [];
557
-
Rpc.Types.fversion = None;
558
-
Rpc.Types.fget = (fun _r -> _r.sc_name);
559
-
Rpc.Types.fset = (fun v _s -> { _s with sc_name = v })
560
-
}
561
-
and static_cmi_sc_content : (_, static_cmi) Rpc.Types.field =
562
-
{
563
-
Rpc.Types.fname = "sc_content";
564
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
565
-
Rpc.Types.fdefault = None;
566
-
Rpc.Types.fdescription = [];
567
-
Rpc.Types.fversion = None;
568
-
Rpc.Types.fget = (fun _r -> _r.sc_content);
569
-
Rpc.Types.fset = (fun v _s -> { _s with sc_content = v })
570
-
}
571
-
and typ_of_static_cmi =
572
-
Rpc.Types.Struct
573
-
({
574
-
Rpc.Types.fields =
575
-
[Rpc.Types.BoxedField static_cmi_sc_name;
576
-
Rpc.Types.BoxedField static_cmi_sc_content];
577
-
Rpc.Types.sname = "static_cmi";
578
-
Rpc.Types.version = None;
579
-
Rpc.Types.constructor =
580
-
(fun getter ->
581
-
let open Rresult.R in
582
-
(getter.Rpc.Types.field_get "sc_content"
583
-
(let open Rpc.Types in Basic String))
584
-
>>=
585
-
(fun static_cmi_sc_content ->
586
-
(getter.Rpc.Types.field_get "sc_name"
587
-
(let open Rpc.Types in Basic String))
588
-
>>=
589
-
(fun static_cmi_sc_name ->
590
-
return
591
-
{
592
-
sc_name = static_cmi_sc_name;
593
-
sc_content = static_cmi_sc_content
594
-
})))
595
-
} : static_cmi Rpc.Types.structure)
596
-
and static_cmi =
597
-
{
598
-
Rpc.Types.name = "static_cmi";
599
-
Rpc.Types.description = [];
600
-
Rpc.Types.ty = typ_of_static_cmi
601
-
}
602
-
and cmis_static_cmis : (_, cmis) Rpc.Types.field =
603
-
{
604
-
Rpc.Types.fname = "static_cmis";
605
-
Rpc.Types.field = (Rpc.Types.List typ_of_static_cmi);
606
-
Rpc.Types.fdefault = None;
607
-
Rpc.Types.fdescription = [];
608
-
Rpc.Types.fversion = None;
609
-
Rpc.Types.fget = (fun _r -> _r.static_cmis);
610
-
Rpc.Types.fset = (fun v _s -> { _s with static_cmis = v })
611
-
}
612
-
and cmis_dynamic_cmis : (_, cmis) Rpc.Types.field =
613
-
{
614
-
Rpc.Types.fname = "dynamic_cmis";
615
-
Rpc.Types.field = (Rpc.Types.List typ_of_dynamic_cmis);
616
-
Rpc.Types.fdefault = None;
617
-
Rpc.Types.fdescription = [];
618
-
Rpc.Types.fversion = None;
619
-
Rpc.Types.fget = (fun _r -> _r.dynamic_cmis);
620
-
Rpc.Types.fset = (fun v _s -> { _s with dynamic_cmis = v })
621
-
}
622
-
and typ_of_cmis =
623
-
Rpc.Types.Struct
624
-
({
625
-
Rpc.Types.fields =
626
-
[Rpc.Types.BoxedField cmis_static_cmis;
627
-
Rpc.Types.BoxedField cmis_dynamic_cmis];
628
-
Rpc.Types.sname = "cmis";
629
-
Rpc.Types.version = None;
630
-
Rpc.Types.constructor =
631
-
(fun getter ->
632
-
let open Rresult.R in
633
-
(getter.Rpc.Types.field_get "dynamic_cmis"
634
-
(Rpc.Types.List typ_of_dynamic_cmis))
635
-
>>=
636
-
(fun cmis_dynamic_cmis ->
637
-
(getter.Rpc.Types.field_get "static_cmis"
638
-
(Rpc.Types.List typ_of_static_cmi))
639
-
>>=
640
-
(fun cmis_static_cmis ->
641
-
return
642
-
{
643
-
static_cmis = cmis_static_cmis;
644
-
dynamic_cmis = cmis_dynamic_cmis
645
-
})))
646
-
} : cmis Rpc.Types.structure)
647
-
and cmis =
648
-
{
649
-
Rpc.Types.name = "cmis";
650
-
Rpc.Types.description = [];
651
-
Rpc.Types.ty = typ_of_cmis
652
-
}
653
-
let _ = dynamic_cmis_dcs_url
654
-
and _ = dynamic_cmis_dcs_toplevel_modules
655
-
and _ = dynamic_cmis_dcs_file_prefixes
656
-
and _ = typ_of_dynamic_cmis
657
-
and _ = dynamic_cmis
658
-
and _ = static_cmi_sc_name
659
-
and _ = static_cmi_sc_content
660
-
and _ = typ_of_static_cmi
661
-
and _ = static_cmi
662
-
and _ = cmis_static_cmis
663
-
and _ = cmis_dynamic_cmis
664
-
and _ = typ_of_cmis
665
-
and _ = cmis
666
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
667
-
type action =
668
-
| Complete_prefix of source * Msource.position
669
-
| Type_enclosing of source * Msource.position
670
-
| All_errors of source
671
-
| Add_cmis of cmis
672
-
type error =
673
-
{
674
-
kind: location_report_kind ;
675
-
loc: location ;
676
-
main: string ;
677
-
sub: string list ;
678
-
source: location_error_source }[@@deriving rpcty]
679
-
include
680
-
struct
681
-
let _ = fun (_ : error) -> ()
682
-
let rec error_kind : (_, error) Rpc.Types.field =
683
-
{
684
-
Rpc.Types.fname = "kind";
685
-
Rpc.Types.field = typ_of_location_report_kind;
686
-
Rpc.Types.fdefault = None;
687
-
Rpc.Types.fdescription = [];
688
-
Rpc.Types.fversion = None;
689
-
Rpc.Types.fget = (fun _r -> _r.kind);
690
-
Rpc.Types.fset = (fun v _s -> { _s with kind = v })
691
-
}
692
-
and error_loc : (_, error) Rpc.Types.field =
693
-
{
694
-
Rpc.Types.fname = "loc";
695
-
Rpc.Types.field = typ_of_location;
696
-
Rpc.Types.fdefault = None;
697
-
Rpc.Types.fdescription = [];
698
-
Rpc.Types.fversion = None;
699
-
Rpc.Types.fget = (fun _r -> _r.loc);
700
-
Rpc.Types.fset = (fun v _s -> { _s with loc = v })
701
-
}
702
-
and error_main : (_, error) Rpc.Types.field =
703
-
{
704
-
Rpc.Types.fname = "main";
705
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
706
-
Rpc.Types.fdefault = None;
707
-
Rpc.Types.fdescription = [];
708
-
Rpc.Types.fversion = None;
709
-
Rpc.Types.fget = (fun _r -> _r.main);
710
-
Rpc.Types.fset = (fun v _s -> { _s with main = v })
711
-
}
712
-
and error_sub : (_, error) Rpc.Types.field =
713
-
{
714
-
Rpc.Types.fname = "sub";
715
-
Rpc.Types.field =
716
-
(Rpc.Types.List (let open Rpc.Types in Basic String));
717
-
Rpc.Types.fdefault = None;
718
-
Rpc.Types.fdescription = [];
719
-
Rpc.Types.fversion = None;
720
-
Rpc.Types.fget = (fun _r -> _r.sub);
721
-
Rpc.Types.fset = (fun v _s -> { _s with sub = v })
722
-
}
723
-
and error_source : (_, error) Rpc.Types.field =
724
-
{
725
-
Rpc.Types.fname = "source";
726
-
Rpc.Types.field = typ_of_location_error_source;
727
-
Rpc.Types.fdefault = None;
728
-
Rpc.Types.fdescription = [];
729
-
Rpc.Types.fversion = None;
730
-
Rpc.Types.fget = (fun _r -> _r.source);
731
-
Rpc.Types.fset = (fun v _s -> { _s with source = v })
732
-
}
733
-
and typ_of_error =
734
-
Rpc.Types.Struct
735
-
({
736
-
Rpc.Types.fields =
737
-
[Rpc.Types.BoxedField error_kind;
738
-
Rpc.Types.BoxedField error_loc;
739
-
Rpc.Types.BoxedField error_main;
740
-
Rpc.Types.BoxedField error_sub;
741
-
Rpc.Types.BoxedField error_source];
742
-
Rpc.Types.sname = "error";
743
-
Rpc.Types.version = None;
744
-
Rpc.Types.constructor =
745
-
(fun getter ->
746
-
let open Rresult.R in
747
-
(getter.Rpc.Types.field_get "source"
748
-
typ_of_location_error_source)
749
-
>>=
750
-
(fun error_source ->
751
-
(getter.Rpc.Types.field_get "sub"
752
-
(Rpc.Types.List
753
-
(let open Rpc.Types in Basic String)))
754
-
>>=
755
-
(fun error_sub ->
756
-
(getter.Rpc.Types.field_get "main"
757
-
(let open Rpc.Types in Basic String))
758
-
>>=
759
-
(fun error_main ->
760
-
(getter.Rpc.Types.field_get "loc"
761
-
typ_of_location)
762
-
>>=
763
-
(fun error_loc ->
764
-
(getter.Rpc.Types.field_get "kind"
765
-
typ_of_location_report_kind)
766
-
>>=
767
-
(fun error_kind ->
768
-
return
769
-
{
770
-
kind = error_kind;
771
-
loc = error_loc;
772
-
main = error_main;
773
-
sub = error_sub;
774
-
source = error_source
775
-
}))))))
776
-
} : error Rpc.Types.structure)
777
-
and error =
778
-
{
779
-
Rpc.Types.name = "error";
780
-
Rpc.Types.description = [];
781
-
Rpc.Types.ty = typ_of_error
782
-
}
783
-
let _ = error_kind
784
-
and _ = error_loc
785
-
and _ = error_main
786
-
and _ = error_sub
787
-
and _ = error_source
788
-
and _ = typ_of_error
789
-
and _ = error
790
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
791
-
type error_list = error list[@@deriving rpcty]
792
-
include
793
-
struct
794
-
let _ = fun (_ : error_list) -> ()
795
-
let rec typ_of_error_list = Rpc.Types.List typ_of_error
796
-
and error_list =
797
-
{
798
-
Rpc.Types.name = "error_list";
799
-
Rpc.Types.description = [];
800
-
Rpc.Types.ty = typ_of_error_list
801
-
}
802
-
let _ = typ_of_error_list
803
-
and _ = error_list
804
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
805
-
type kind_ty =
806
-
| Constructor
807
-
| Keyword
808
-
| Label
809
-
| MethodCall
810
-
| Modtype
811
-
| Module
812
-
| Type
813
-
| Value
814
-
| Variant [@@deriving rpcty]
815
-
include
816
-
struct
817
-
let _ = fun (_ : kind_ty) -> ()
818
-
let rec typ_of_kind_ty =
819
-
Rpc.Types.Variant
820
-
({
821
-
Rpc.Types.vname = "kind_ty";
822
-
Rpc.Types.variants =
823
-
[BoxedTag
824
-
{
825
-
Rpc.Types.tname = "Constructor";
826
-
Rpc.Types.tcontents = Unit;
827
-
Rpc.Types.tversion = None;
828
-
Rpc.Types.tdescription = [];
829
-
Rpc.Types.tpreview =
830
-
((function | Constructor -> Some () | _ -> None));
831
-
Rpc.Types.treview = ((function | () -> Constructor))
832
-
};
833
-
BoxedTag
834
-
{
835
-
Rpc.Types.tname = "Keyword";
836
-
Rpc.Types.tcontents = Unit;
837
-
Rpc.Types.tversion = None;
838
-
Rpc.Types.tdescription = [];
839
-
Rpc.Types.tpreview =
840
-
((function | Keyword -> Some () | _ -> None));
841
-
Rpc.Types.treview = ((function | () -> Keyword))
842
-
};
843
-
BoxedTag
844
-
{
845
-
Rpc.Types.tname = "Label";
846
-
Rpc.Types.tcontents = Unit;
847
-
Rpc.Types.tversion = None;
848
-
Rpc.Types.tdescription = [];
849
-
Rpc.Types.tpreview =
850
-
((function | Label -> Some () | _ -> None));
851
-
Rpc.Types.treview = ((function | () -> Label))
852
-
};
853
-
BoxedTag
854
-
{
855
-
Rpc.Types.tname = "MethodCall";
856
-
Rpc.Types.tcontents = Unit;
857
-
Rpc.Types.tversion = None;
858
-
Rpc.Types.tdescription = [];
859
-
Rpc.Types.tpreview =
860
-
((function | MethodCall -> Some () | _ -> None));
861
-
Rpc.Types.treview = ((function | () -> MethodCall))
862
-
};
863
-
BoxedTag
864
-
{
865
-
Rpc.Types.tname = "Modtype";
866
-
Rpc.Types.tcontents = Unit;
867
-
Rpc.Types.tversion = None;
868
-
Rpc.Types.tdescription = [];
869
-
Rpc.Types.tpreview =
870
-
((function | Modtype -> Some () | _ -> None));
871
-
Rpc.Types.treview = ((function | () -> Modtype))
872
-
};
873
-
BoxedTag
874
-
{
875
-
Rpc.Types.tname = "Module";
876
-
Rpc.Types.tcontents = Unit;
877
-
Rpc.Types.tversion = None;
878
-
Rpc.Types.tdescription = [];
879
-
Rpc.Types.tpreview =
880
-
((function | Module -> Some () | _ -> None));
881
-
Rpc.Types.treview = ((function | () -> Module))
882
-
};
883
-
BoxedTag
884
-
{
885
-
Rpc.Types.tname = "Type";
886
-
Rpc.Types.tcontents = Unit;
887
-
Rpc.Types.tversion = None;
888
-
Rpc.Types.tdescription = [];
889
-
Rpc.Types.tpreview =
890
-
((function | Type -> Some () | _ -> None));
891
-
Rpc.Types.treview = ((function | () -> Type))
892
-
};
893
-
BoxedTag
894
-
{
895
-
Rpc.Types.tname = "Value";
896
-
Rpc.Types.tcontents = Unit;
897
-
Rpc.Types.tversion = None;
898
-
Rpc.Types.tdescription = [];
899
-
Rpc.Types.tpreview =
900
-
((function | Value -> Some () | _ -> None));
901
-
Rpc.Types.treview = ((function | () -> Value))
902
-
};
903
-
BoxedTag
904
-
{
905
-
Rpc.Types.tname = "Variant";
906
-
Rpc.Types.tcontents = Unit;
907
-
Rpc.Types.tversion = None;
908
-
Rpc.Types.tdescription = [];
909
-
Rpc.Types.tpreview =
910
-
((function | Variant -> Some () | _ -> None));
911
-
Rpc.Types.treview = ((function | () -> Variant))
912
-
}];
913
-
Rpc.Types.vdefault = None;
914
-
Rpc.Types.vversion = None;
915
-
Rpc.Types.vconstructor =
916
-
(fun s' t ->
917
-
let s = String.lowercase_ascii s' in
918
-
match s with
919
-
| "constructor" ->
920
-
Rresult.R.bind (t.tget Unit)
921
-
(function | () -> Rresult.R.ok Constructor)
922
-
| "keyword" ->
923
-
Rresult.R.bind (t.tget Unit)
924
-
(function | () -> Rresult.R.ok Keyword)
925
-
| "label" ->
926
-
Rresult.R.bind (t.tget Unit)
927
-
(function | () -> Rresult.R.ok Label)
928
-
| "methodcall" ->
929
-
Rresult.R.bind (t.tget Unit)
930
-
(function | () -> Rresult.R.ok MethodCall)
931
-
| "modtype" ->
932
-
Rresult.R.bind (t.tget Unit)
933
-
(function | () -> Rresult.R.ok Modtype)
934
-
| "module" ->
935
-
Rresult.R.bind (t.tget Unit)
936
-
(function | () -> Rresult.R.ok Module)
937
-
| "type" ->
938
-
Rresult.R.bind (t.tget Unit)
939
-
(function | () -> Rresult.R.ok Type)
940
-
| "value" ->
941
-
Rresult.R.bind (t.tget Unit)
942
-
(function | () -> Rresult.R.ok Value)
943
-
| "variant" ->
944
-
Rresult.R.bind (t.tget Unit)
945
-
(function | () -> Rresult.R.ok Variant)
946
-
| _ ->
947
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
948
-
} : kind_ty Rpc.Types.variant)
949
-
and kind_ty =
950
-
{
951
-
Rpc.Types.name = "kind_ty";
952
-
Rpc.Types.description = [];
953
-
Rpc.Types.ty = typ_of_kind_ty
954
-
}
955
-
let _ = typ_of_kind_ty
956
-
and _ = kind_ty
957
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
958
-
type query_protocol_compl_entry =
959
-
{
960
-
name: string ;
961
-
kind: kind_ty ;
962
-
desc: string ;
963
-
info: string ;
964
-
deprecated: bool }[@@deriving rpcty]
965
-
include
966
-
struct
967
-
let _ = fun (_ : query_protocol_compl_entry) -> ()
968
-
let rec query_protocol_compl_entry_name :
969
-
(_, query_protocol_compl_entry) Rpc.Types.field =
970
-
{
971
-
Rpc.Types.fname = "name";
972
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
973
-
Rpc.Types.fdefault = None;
974
-
Rpc.Types.fdescription = [];
975
-
Rpc.Types.fversion = None;
976
-
Rpc.Types.fget = (fun _r -> _r.name);
977
-
Rpc.Types.fset = (fun v _s -> { _s with name = v })
978
-
}
979
-
and query_protocol_compl_entry_kind :
980
-
(_, query_protocol_compl_entry) Rpc.Types.field =
981
-
{
982
-
Rpc.Types.fname = "kind";
983
-
Rpc.Types.field = typ_of_kind_ty;
984
-
Rpc.Types.fdefault = None;
985
-
Rpc.Types.fdescription = [];
986
-
Rpc.Types.fversion = None;
987
-
Rpc.Types.fget = (fun _r -> _r.kind);
988
-
Rpc.Types.fset = (fun v _s -> { _s with kind = v })
989
-
}
990
-
and query_protocol_compl_entry_desc :
991
-
(_, query_protocol_compl_entry) Rpc.Types.field =
992
-
{
993
-
Rpc.Types.fname = "desc";
994
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
995
-
Rpc.Types.fdefault = None;
996
-
Rpc.Types.fdescription = [];
997
-
Rpc.Types.fversion = None;
998
-
Rpc.Types.fget = (fun _r -> _r.desc);
999
-
Rpc.Types.fset = (fun v _s -> { _s with desc = v })
1000
-
}
1001
-
and query_protocol_compl_entry_info :
1002
-
(_, query_protocol_compl_entry) Rpc.Types.field =
1003
-
{
1004
-
Rpc.Types.fname = "info";
1005
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1006
-
Rpc.Types.fdefault = None;
1007
-
Rpc.Types.fdescription = [];
1008
-
Rpc.Types.fversion = None;
1009
-
Rpc.Types.fget = (fun _r -> _r.info);
1010
-
Rpc.Types.fset = (fun v _s -> { _s with info = v })
1011
-
}
1012
-
and query_protocol_compl_entry_deprecated :
1013
-
(_, query_protocol_compl_entry) Rpc.Types.field =
1014
-
{
1015
-
Rpc.Types.fname = "deprecated";
1016
-
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
1017
-
Rpc.Types.fdefault = None;
1018
-
Rpc.Types.fdescription = [];
1019
-
Rpc.Types.fversion = None;
1020
-
Rpc.Types.fget = (fun _r -> _r.deprecated);
1021
-
Rpc.Types.fset = (fun v _s -> { _s with deprecated = v })
1022
-
}
1023
-
and typ_of_query_protocol_compl_entry =
1024
-
Rpc.Types.Struct
1025
-
({
1026
-
Rpc.Types.fields =
1027
-
[Rpc.Types.BoxedField query_protocol_compl_entry_name;
1028
-
Rpc.Types.BoxedField query_protocol_compl_entry_kind;
1029
-
Rpc.Types.BoxedField query_protocol_compl_entry_desc;
1030
-
Rpc.Types.BoxedField query_protocol_compl_entry_info;
1031
-
Rpc.Types.BoxedField query_protocol_compl_entry_deprecated];
1032
-
Rpc.Types.sname = "query_protocol_compl_entry";
1033
-
Rpc.Types.version = None;
1034
-
Rpc.Types.constructor =
1035
-
(fun getter ->
1036
-
let open Rresult.R in
1037
-
(getter.Rpc.Types.field_get "deprecated"
1038
-
(let open Rpc.Types in Basic Bool))
1039
-
>>=
1040
-
(fun query_protocol_compl_entry_deprecated ->
1041
-
(getter.Rpc.Types.field_get "info"
1042
-
(let open Rpc.Types in Basic String))
1043
-
>>=
1044
-
(fun query_protocol_compl_entry_info ->
1045
-
(getter.Rpc.Types.field_get "desc"
1046
-
(let open Rpc.Types in Basic String))
1047
-
>>=
1048
-
(fun query_protocol_compl_entry_desc ->
1049
-
(getter.Rpc.Types.field_get "kind"
1050
-
typ_of_kind_ty)
1051
-
>>=
1052
-
(fun query_protocol_compl_entry_kind ->
1053
-
(getter.Rpc.Types.field_get "name"
1054
-
(let open Rpc.Types in Basic String))
1055
-
>>=
1056
-
(fun query_protocol_compl_entry_name
1057
-
->
1058
-
return
1059
-
{
1060
-
name =
1061
-
query_protocol_compl_entry_name;
1062
-
kind =
1063
-
query_protocol_compl_entry_kind;
1064
-
desc =
1065
-
query_protocol_compl_entry_desc;
1066
-
info =
1067
-
query_protocol_compl_entry_info;
1068
-
deprecated =
1069
-
query_protocol_compl_entry_deprecated
1070
-
}))))))
1071
-
} : query_protocol_compl_entry Rpc.Types.structure)
1072
-
and query_protocol_compl_entry =
1073
-
{
1074
-
Rpc.Types.name = "query_protocol_compl_entry";
1075
-
Rpc.Types.description = [];
1076
-
Rpc.Types.ty = typ_of_query_protocol_compl_entry
1077
-
}
1078
-
let _ = query_protocol_compl_entry_name
1079
-
and _ = query_protocol_compl_entry_kind
1080
-
and _ = query_protocol_compl_entry_desc
1081
-
and _ = query_protocol_compl_entry_info
1082
-
and _ = query_protocol_compl_entry_deprecated
1083
-
and _ = typ_of_query_protocol_compl_entry
1084
-
and _ = query_protocol_compl_entry
1085
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1086
-
type completions =
1087
-
{
1088
-
from: int ;
1089
-
to_: int ;
1090
-
entries: query_protocol_compl_entry list }[@@deriving rpcty]
1091
-
include
1092
-
struct
1093
-
let _ = fun (_ : completions) -> ()
1094
-
let rec completions_from : (_, completions) Rpc.Types.field =
1095
-
{
1096
-
Rpc.Types.fname = "from";
1097
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1098
-
Rpc.Types.fdefault = None;
1099
-
Rpc.Types.fdescription = [];
1100
-
Rpc.Types.fversion = None;
1101
-
Rpc.Types.fget = (fun _r -> _r.from);
1102
-
Rpc.Types.fset = (fun v _s -> { _s with from = v })
1103
-
}
1104
-
and completions_to_ : (_, completions) Rpc.Types.field =
1105
-
{
1106
-
Rpc.Types.fname = "to_";
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.to_);
1112
-
Rpc.Types.fset = (fun v _s -> { _s with to_ = v })
1113
-
}
1114
-
and completions_entries : (_, completions) Rpc.Types.field =
1115
-
{
1116
-
Rpc.Types.fname = "entries";
1117
-
Rpc.Types.field = (Rpc.Types.List typ_of_query_protocol_compl_entry);
1118
-
Rpc.Types.fdefault = None;
1119
-
Rpc.Types.fdescription = [];
1120
-
Rpc.Types.fversion = None;
1121
-
Rpc.Types.fget = (fun _r -> _r.entries);
1122
-
Rpc.Types.fset = (fun v _s -> { _s with entries = v })
1123
-
}
1124
-
and typ_of_completions =
1125
-
Rpc.Types.Struct
1126
-
({
1127
-
Rpc.Types.fields =
1128
-
[Rpc.Types.BoxedField completions_from;
1129
-
Rpc.Types.BoxedField completions_to_;
1130
-
Rpc.Types.BoxedField completions_entries];
1131
-
Rpc.Types.sname = "completions";
1132
-
Rpc.Types.version = None;
1133
-
Rpc.Types.constructor =
1134
-
(fun getter ->
1135
-
let open Rresult.R in
1136
-
(getter.Rpc.Types.field_get "entries"
1137
-
(Rpc.Types.List typ_of_query_protocol_compl_entry))
1138
-
>>=
1139
-
(fun completions_entries ->
1140
-
(getter.Rpc.Types.field_get "to_"
1141
-
(let open Rpc.Types in Basic Int))
1142
-
>>=
1143
-
(fun completions_to_ ->
1144
-
(getter.Rpc.Types.field_get "from"
1145
-
(let open Rpc.Types in Basic Int))
1146
-
>>=
1147
-
(fun completions_from ->
1148
-
return
1149
-
{
1150
-
from = completions_from;
1151
-
to_ = completions_to_;
1152
-
entries = completions_entries
1153
-
}))))
1154
-
} : completions Rpc.Types.structure)
1155
-
and completions =
1156
-
{
1157
-
Rpc.Types.name = "completions";
1158
-
Rpc.Types.description = [];
1159
-
Rpc.Types.ty = typ_of_completions
1160
-
}
1161
-
let _ = completions_from
1162
-
and _ = completions_to_
1163
-
and _ = completions_entries
1164
-
and _ = typ_of_completions
1165
-
and _ = completions
1166
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1167
-
type msource_position =
1168
-
| Start
1169
-
| Offset of int
1170
-
| Logical of int * int
1171
-
| End [@@deriving rpcty]
1172
-
include
1173
-
struct
1174
-
let _ = fun (_ : msource_position) -> ()
1175
-
let rec typ_of_msource_position =
1176
-
Rpc.Types.Variant
1177
-
({
1178
-
Rpc.Types.vname = "msource_position";
1179
-
Rpc.Types.variants =
1180
-
[BoxedTag
1181
-
{
1182
-
Rpc.Types.tname = "Start";
1183
-
Rpc.Types.tcontents = Unit;
1184
-
Rpc.Types.tversion = None;
1185
-
Rpc.Types.tdescription = [];
1186
-
Rpc.Types.tpreview =
1187
-
((function | Start -> Some () | _ -> None));
1188
-
Rpc.Types.treview = ((function | () -> Start))
1189
-
};
1190
-
BoxedTag
1191
-
{
1192
-
Rpc.Types.tname = "Offset";
1193
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic Int));
1194
-
Rpc.Types.tversion = None;
1195
-
Rpc.Types.tdescription = [];
1196
-
Rpc.Types.tpreview =
1197
-
((function | Offset a0 -> Some a0 | _ -> None));
1198
-
Rpc.Types.treview = ((function | a0 -> Offset a0))
1199
-
};
1200
-
BoxedTag
1201
-
{
1202
-
Rpc.Types.tname = "Logical";
1203
-
Rpc.Types.tcontents =
1204
-
(Tuple
1205
-
(((let open Rpc.Types in Basic Int)),
1206
-
((let open Rpc.Types in Basic Int))));
1207
-
Rpc.Types.tversion = None;
1208
-
Rpc.Types.tdescription = [];
1209
-
Rpc.Types.tpreview =
1210
-
((function | Logical (a0, a1) -> Some (a0, a1) | _ -> None));
1211
-
Rpc.Types.treview =
1212
-
((function | (a0, a1) -> Logical (a0, a1)))
1213
-
};
1214
-
BoxedTag
1215
-
{
1216
-
Rpc.Types.tname = "End";
1217
-
Rpc.Types.tcontents = Unit;
1218
-
Rpc.Types.tversion = None;
1219
-
Rpc.Types.tdescription = [];
1220
-
Rpc.Types.tpreview =
1221
-
((function | End -> Some () | _ -> None));
1222
-
Rpc.Types.treview = ((function | () -> End))
1223
-
}];
1224
-
Rpc.Types.vdefault = None;
1225
-
Rpc.Types.vversion = None;
1226
-
Rpc.Types.vconstructor =
1227
-
(fun s' t ->
1228
-
let s = String.lowercase_ascii s' in
1229
-
match s with
1230
-
| "start" ->
1231
-
Rresult.R.bind (t.tget Unit)
1232
-
(function | () -> Rresult.R.ok Start)
1233
-
| "offset" ->
1234
-
Rresult.R.bind (t.tget (let open Rpc.Types in Basic Int))
1235
-
(function | a0 -> Rresult.R.ok (Offset a0))
1236
-
| "logical" ->
1237
-
Rresult.R.bind
1238
-
(t.tget
1239
-
(Tuple
1240
-
((let open Rpc.Types in Basic Int),
1241
-
(let open Rpc.Types in Basic Int))))
1242
-
(function | (a0, a1) -> Rresult.R.ok (Logical (a0, a1)))
1243
-
| "end" ->
1244
-
Rresult.R.bind (t.tget Unit)
1245
-
(function | () -> Rresult.R.ok End)
1246
-
| _ ->
1247
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1248
-
} : msource_position Rpc.Types.variant)
1249
-
and msource_position =
1250
-
{
1251
-
Rpc.Types.name = "msource_position";
1252
-
Rpc.Types.description = [];
1253
-
Rpc.Types.ty = typ_of_msource_position
1254
-
}
1255
-
let _ = typ_of_msource_position
1256
-
and _ = msource_position
1257
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1258
-
type is_tail_position =
1259
-
| No
1260
-
| Tail_position
1261
-
| Tail_call [@@deriving rpcty]
1262
-
include
1263
-
struct
1264
-
let _ = fun (_ : is_tail_position) -> ()
1265
-
let rec typ_of_is_tail_position =
1266
-
Rpc.Types.Variant
1267
-
({
1268
-
Rpc.Types.vname = "is_tail_position";
1269
-
Rpc.Types.variants =
1270
-
[BoxedTag
1271
-
{
1272
-
Rpc.Types.tname = "No";
1273
-
Rpc.Types.tcontents = Unit;
1274
-
Rpc.Types.tversion = None;
1275
-
Rpc.Types.tdescription = [];
1276
-
Rpc.Types.tpreview =
1277
-
((function | No -> Some () | _ -> None));
1278
-
Rpc.Types.treview = ((function | () -> No))
1279
-
};
1280
-
BoxedTag
1281
-
{
1282
-
Rpc.Types.tname = "Tail_position";
1283
-
Rpc.Types.tcontents = Unit;
1284
-
Rpc.Types.tversion = None;
1285
-
Rpc.Types.tdescription = [];
1286
-
Rpc.Types.tpreview =
1287
-
((function | Tail_position -> Some () | _ -> None));
1288
-
Rpc.Types.treview = ((function | () -> Tail_position))
1289
-
};
1290
-
BoxedTag
1291
-
{
1292
-
Rpc.Types.tname = "Tail_call";
1293
-
Rpc.Types.tcontents = Unit;
1294
-
Rpc.Types.tversion = None;
1295
-
Rpc.Types.tdescription = [];
1296
-
Rpc.Types.tpreview =
1297
-
((function | Tail_call -> Some () | _ -> None));
1298
-
Rpc.Types.treview = ((function | () -> Tail_call))
1299
-
}];
1300
-
Rpc.Types.vdefault = None;
1301
-
Rpc.Types.vversion = None;
1302
-
Rpc.Types.vconstructor =
1303
-
(fun s' t ->
1304
-
let s = String.lowercase_ascii s' in
1305
-
match s with
1306
-
| "no" ->
1307
-
Rresult.R.bind (t.tget Unit)
1308
-
(function | () -> Rresult.R.ok No)
1309
-
| "tail_position" ->
1310
-
Rresult.R.bind (t.tget Unit)
1311
-
(function | () -> Rresult.R.ok Tail_position)
1312
-
| "tail_call" ->
1313
-
Rresult.R.bind (t.tget Unit)
1314
-
(function | () -> Rresult.R.ok Tail_call)
1315
-
| _ ->
1316
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1317
-
} : is_tail_position Rpc.Types.variant)
1318
-
and is_tail_position =
1319
-
{
1320
-
Rpc.Types.name = "is_tail_position";
1321
-
Rpc.Types.description = [];
1322
-
Rpc.Types.ty = typ_of_is_tail_position
1323
-
}
1324
-
let _ = typ_of_is_tail_position
1325
-
and _ = is_tail_position
1326
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1327
-
type index_or_string =
1328
-
| Index of int
1329
-
| String of string [@@deriving rpcty]
1330
-
include
1331
-
struct
1332
-
let _ = fun (_ : index_or_string) -> ()
1333
-
let rec typ_of_index_or_string =
1334
-
Rpc.Types.Variant
1335
-
({
1336
-
Rpc.Types.vname = "index_or_string";
1337
-
Rpc.Types.variants =
1338
-
[BoxedTag
1339
-
{
1340
-
Rpc.Types.tname = "Index";
1341
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic Int));
1342
-
Rpc.Types.tversion = None;
1343
-
Rpc.Types.tdescription = [];
1344
-
Rpc.Types.tpreview =
1345
-
((function | Index a0 -> Some a0 | _ -> None));
1346
-
Rpc.Types.treview = ((function | a0 -> Index a0))
1347
-
};
1348
-
BoxedTag
1349
-
{
1350
-
Rpc.Types.tname = "String";
1351
-
Rpc.Types.tcontents = ((let open Rpc.Types in Basic String));
1352
-
Rpc.Types.tversion = None;
1353
-
Rpc.Types.tdescription = [];
1354
-
Rpc.Types.tpreview =
1355
-
((function | String a0 -> Some a0 | _ -> None));
1356
-
Rpc.Types.treview = ((function | a0 -> String a0))
1357
-
}];
1358
-
Rpc.Types.vdefault = None;
1359
-
Rpc.Types.vversion = None;
1360
-
Rpc.Types.vconstructor =
1361
-
(fun s' t ->
1362
-
let s = String.lowercase_ascii s' in
1363
-
match s with
1364
-
| "index" ->
1365
-
Rresult.R.bind (t.tget (let open Rpc.Types in Basic Int))
1366
-
(function | a0 -> Rresult.R.ok (Index a0))
1367
-
| "string" ->
1368
-
Rresult.R.bind
1369
-
(t.tget (let open Rpc.Types in Basic String))
1370
-
(function | a0 -> Rresult.R.ok (String a0))
1371
-
| _ ->
1372
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1373
-
} : index_or_string Rpc.Types.variant)
1374
-
and index_or_string =
1375
-
{
1376
-
Rpc.Types.name = "index_or_string";
1377
-
Rpc.Types.description = [];
1378
-
Rpc.Types.ty = typ_of_index_or_string
1379
-
}
1380
-
let _ = typ_of_index_or_string
1381
-
and _ = index_or_string
1382
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1383
-
type typed_enclosings = (location * index_or_string * is_tail_position)
1384
-
[@@deriving rpcty]
1385
-
include
1386
-
struct
1387
-
let _ = fun (_ : typed_enclosings) -> ()
1388
-
let rec typ_of_typed_enclosings =
1389
-
Rpc.Types.Tuple3
1390
-
(typ_of_location, typ_of_index_or_string, typ_of_is_tail_position)
1391
-
and typed_enclosings =
1392
-
{
1393
-
Rpc.Types.name = "typed_enclosings";
1394
-
Rpc.Types.description = [];
1395
-
Rpc.Types.ty = typ_of_typed_enclosings
1396
-
}
1397
-
let _ = typ_of_typed_enclosings
1398
-
and _ = typed_enclosings
1399
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1400
-
type typed_enclosings_list = typed_enclosings list[@@deriving rpcty]
1401
-
include
1402
-
struct
1403
-
let _ = fun (_ : typed_enclosings_list) -> ()
1404
-
let rec typ_of_typed_enclosings_list =
1405
-
Rpc.Types.List typ_of_typed_enclosings
1406
-
and typed_enclosings_list =
1407
-
{
1408
-
Rpc.Types.name = "typed_enclosings_list";
1409
-
Rpc.Types.description = [];
1410
-
Rpc.Types.ty = typ_of_typed_enclosings_list
1411
-
}
1412
-
let _ = typ_of_typed_enclosings_list
1413
-
and _ = typed_enclosings_list
1414
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1415
-
let report_source_to_string =
1416
-
function
1417
-
| Location.Lexer -> "lexer"
1418
-
| Location.Parser -> "parser"
1419
-
| Location.Typer -> "typer"
1420
-
| Location.Warning -> "warning"
1421
-
| Location.Unknown -> "unknown"
1422
-
| Location.Env -> "env"
1423
-
| Location.Config -> "config"
1424
-
type highlight = {
1425
-
line1: int ;
1426
-
line2: int ;
1427
-
col1: int ;
1428
-
col2: int }[@@deriving rpcty][@@ocaml.doc " An area to be highlighted "]
1429
-
include
1430
-
struct
1431
-
let _ = fun (_ : highlight) -> ()
1432
-
let rec highlight_line1 : (_, highlight) Rpc.Types.field =
1433
-
{
1434
-
Rpc.Types.fname = "line1";
1435
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1436
-
Rpc.Types.fdefault = None;
1437
-
Rpc.Types.fdescription = [];
1438
-
Rpc.Types.fversion = None;
1439
-
Rpc.Types.fget = (fun _r -> _r.line1);
1440
-
Rpc.Types.fset = (fun v _s -> { _s with line1 = v })
1441
-
}
1442
-
and highlight_line2 : (_, highlight) Rpc.Types.field =
1443
-
{
1444
-
Rpc.Types.fname = "line2";
1445
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1446
-
Rpc.Types.fdefault = None;
1447
-
Rpc.Types.fdescription = [];
1448
-
Rpc.Types.fversion = None;
1449
-
Rpc.Types.fget = (fun _r -> _r.line2);
1450
-
Rpc.Types.fset = (fun v _s -> { _s with line2 = v })
1451
-
}
1452
-
and highlight_col1 : (_, highlight) Rpc.Types.field =
1453
-
{
1454
-
Rpc.Types.fname = "col1";
1455
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1456
-
Rpc.Types.fdefault = None;
1457
-
Rpc.Types.fdescription = [];
1458
-
Rpc.Types.fversion = None;
1459
-
Rpc.Types.fget = (fun _r -> _r.col1);
1460
-
Rpc.Types.fset = (fun v _s -> { _s with col1 = v })
1461
-
}
1462
-
and highlight_col2 : (_, highlight) Rpc.Types.field =
1463
-
{
1464
-
Rpc.Types.fname = "col2";
1465
-
Rpc.Types.field = (let open Rpc.Types in Basic Int);
1466
-
Rpc.Types.fdefault = None;
1467
-
Rpc.Types.fdescription = [];
1468
-
Rpc.Types.fversion = None;
1469
-
Rpc.Types.fget = (fun _r -> _r.col2);
1470
-
Rpc.Types.fset = (fun v _s -> { _s with col2 = v })
1471
-
}
1472
-
and typ_of_highlight =
1473
-
Rpc.Types.Struct
1474
-
({
1475
-
Rpc.Types.fields =
1476
-
[Rpc.Types.BoxedField highlight_line1;
1477
-
Rpc.Types.BoxedField highlight_line2;
1478
-
Rpc.Types.BoxedField highlight_col1;
1479
-
Rpc.Types.BoxedField highlight_col2];
1480
-
Rpc.Types.sname = "highlight";
1481
-
Rpc.Types.version = None;
1482
-
Rpc.Types.constructor =
1483
-
(fun getter ->
1484
-
let open Rresult.R in
1485
-
(getter.Rpc.Types.field_get "col2"
1486
-
(let open Rpc.Types in Basic Int))
1487
-
>>=
1488
-
(fun highlight_col2 ->
1489
-
(getter.Rpc.Types.field_get "col1"
1490
-
(let open Rpc.Types in Basic Int))
1491
-
>>=
1492
-
(fun highlight_col1 ->
1493
-
(getter.Rpc.Types.field_get "line2"
1494
-
(let open Rpc.Types in Basic Int))
1495
-
>>=
1496
-
(fun highlight_line2 ->
1497
-
(getter.Rpc.Types.field_get "line1"
1498
-
(let open Rpc.Types in Basic Int))
1499
-
>>=
1500
-
(fun highlight_line1 ->
1501
-
return
1502
-
{
1503
-
line1 = highlight_line1;
1504
-
line2 = highlight_line2;
1505
-
col1 = highlight_col1;
1506
-
col2 = highlight_col2
1507
-
})))))
1508
-
} : highlight Rpc.Types.structure)
1509
-
and highlight =
1510
-
{
1511
-
Rpc.Types.name = "highlight";
1512
-
Rpc.Types.description = ["An area to be highlighted"];
1513
-
Rpc.Types.ty = typ_of_highlight
1514
-
}
1515
-
let _ = highlight_line1
1516
-
and _ = highlight_line2
1517
-
and _ = highlight_col1
1518
-
and _ = highlight_col2
1519
-
and _ = typ_of_highlight
1520
-
and _ = highlight
1521
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1522
-
type encoding = Mime_printer.encoding =
1523
-
| Noencoding
1524
-
| Base64 [@@ocaml.doc " An area to be highlighted "][@@deriving rpcty]
1525
-
include
1526
-
struct
1527
-
let _ = fun (_ : encoding) -> ()
1528
-
let rec typ_of_encoding =
1529
-
Rpc.Types.Variant
1530
-
({
1531
-
Rpc.Types.vname = "encoding";
1532
-
Rpc.Types.variants =
1533
-
[BoxedTag
1534
-
{
1535
-
Rpc.Types.tname = "Noencoding";
1536
-
Rpc.Types.tcontents = Unit;
1537
-
Rpc.Types.tversion = None;
1538
-
Rpc.Types.tdescription = [];
1539
-
Rpc.Types.tpreview =
1540
-
((function | Noencoding -> Some () | _ -> None));
1541
-
Rpc.Types.treview = ((function | () -> Noencoding))
1542
-
};
1543
-
BoxedTag
1544
-
{
1545
-
Rpc.Types.tname = "Base64";
1546
-
Rpc.Types.tcontents = Unit;
1547
-
Rpc.Types.tversion = None;
1548
-
Rpc.Types.tdescription = [];
1549
-
Rpc.Types.tpreview =
1550
-
((function | Base64 -> Some () | _ -> None));
1551
-
Rpc.Types.treview = ((function | () -> Base64))
1552
-
}];
1553
-
Rpc.Types.vdefault = None;
1554
-
Rpc.Types.vversion = None;
1555
-
Rpc.Types.vconstructor =
1556
-
(fun s' t ->
1557
-
let s = String.lowercase_ascii s' in
1558
-
match s with
1559
-
| "noencoding" ->
1560
-
Rresult.R.bind (t.tget Unit)
1561
-
(function | () -> Rresult.R.ok Noencoding)
1562
-
| "base64" ->
1563
-
Rresult.R.bind (t.tget Unit)
1564
-
(function | () -> Rresult.R.ok Base64)
1565
-
| _ ->
1566
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
1567
-
} : encoding Rpc.Types.variant)
1568
-
and encoding =
1569
-
{
1570
-
Rpc.Types.name = "encoding";
1571
-
Rpc.Types.description = ["An area to be highlighted"];
1572
-
Rpc.Types.ty = typ_of_encoding
1573
-
}
1574
-
let _ = typ_of_encoding
1575
-
and _ = encoding
1576
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1577
-
type mime_val = Mime_printer.t =
1578
-
{
1579
-
mime_type: string ;
1580
-
encoding: encoding ;
1581
-
data: string }[@@deriving rpcty]
1582
-
include
1583
-
struct
1584
-
let _ = fun (_ : mime_val) -> ()
1585
-
let rec mime_val_mime_type : (_, mime_val) Rpc.Types.field =
1586
-
{
1587
-
Rpc.Types.fname = "mime_type";
1588
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1589
-
Rpc.Types.fdefault = None;
1590
-
Rpc.Types.fdescription = [];
1591
-
Rpc.Types.fversion = None;
1592
-
Rpc.Types.fget = (fun _r -> _r.mime_type);
1593
-
Rpc.Types.fset = (fun v _s -> { _s with mime_type = v })
1594
-
}
1595
-
and mime_val_encoding : (_, mime_val) Rpc.Types.field =
1596
-
{
1597
-
Rpc.Types.fname = "encoding";
1598
-
Rpc.Types.field = typ_of_encoding;
1599
-
Rpc.Types.fdefault = None;
1600
-
Rpc.Types.fdescription = [];
1601
-
Rpc.Types.fversion = None;
1602
-
Rpc.Types.fget = (fun _r -> _r.encoding);
1603
-
Rpc.Types.fset = (fun v _s -> { _s with encoding = v })
1604
-
}
1605
-
and mime_val_data : (_, mime_val) Rpc.Types.field =
1606
-
{
1607
-
Rpc.Types.fname = "data";
1608
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1609
-
Rpc.Types.fdefault = None;
1610
-
Rpc.Types.fdescription = [];
1611
-
Rpc.Types.fversion = None;
1612
-
Rpc.Types.fget = (fun _r -> _r.data);
1613
-
Rpc.Types.fset = (fun v _s -> { _s with data = v })
1614
-
}
1615
-
and typ_of_mime_val =
1616
-
Rpc.Types.Struct
1617
-
({
1618
-
Rpc.Types.fields =
1619
-
[Rpc.Types.BoxedField mime_val_mime_type;
1620
-
Rpc.Types.BoxedField mime_val_encoding;
1621
-
Rpc.Types.BoxedField mime_val_data];
1622
-
Rpc.Types.sname = "mime_val";
1623
-
Rpc.Types.version = None;
1624
-
Rpc.Types.constructor =
1625
-
(fun getter ->
1626
-
let open Rresult.R in
1627
-
(getter.Rpc.Types.field_get "data"
1628
-
(let open Rpc.Types in Basic String))
1629
-
>>=
1630
-
(fun mime_val_data ->
1631
-
(getter.Rpc.Types.field_get "encoding" typ_of_encoding)
1632
-
>>=
1633
-
(fun mime_val_encoding ->
1634
-
(getter.Rpc.Types.field_get "mime_type"
1635
-
(let open Rpc.Types in Basic String))
1636
-
>>=
1637
-
(fun mime_val_mime_type ->
1638
-
return
1639
-
{
1640
-
mime_type = mime_val_mime_type;
1641
-
encoding = mime_val_encoding;
1642
-
data = mime_val_data
1643
-
}))))
1644
-
} : mime_val Rpc.Types.structure)
1645
-
and mime_val =
1646
-
{
1647
-
Rpc.Types.name = "mime_val";
1648
-
Rpc.Types.description = [];
1649
-
Rpc.Types.ty = typ_of_mime_val
1650
-
}
1651
-
let _ = mime_val_mime_type
1652
-
and _ = mime_val_encoding
1653
-
and _ = mime_val_data
1654
-
and _ = typ_of_mime_val
1655
-
and _ = mime_val
1656
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1657
-
type exec_result =
1658
-
{
1659
-
stdout: string option ;
1660
-
stderr: string option ;
1661
-
sharp_ppf: string option ;
1662
-
caml_ppf: string option ;
1663
-
highlight: highlight option ;
1664
-
mime_vals: mime_val list }[@@deriving rpcty][@@ocaml.doc
1665
-
" Represents the result of executing a toplevel phrase "]
1666
-
include
1667
-
struct
1668
-
let _ = fun (_ : exec_result) -> ()
1669
-
let rec exec_result_stdout : (_, exec_result) Rpc.Types.field =
1670
-
{
1671
-
Rpc.Types.fname = "stdout";
1672
-
Rpc.Types.field =
1673
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1674
-
Rpc.Types.fdefault = None;
1675
-
Rpc.Types.fdescription = [];
1676
-
Rpc.Types.fversion = None;
1677
-
Rpc.Types.fget = (fun _r -> _r.stdout);
1678
-
Rpc.Types.fset = (fun v _s -> { _s with stdout = v })
1679
-
}
1680
-
and exec_result_stderr : (_, exec_result) Rpc.Types.field =
1681
-
{
1682
-
Rpc.Types.fname = "stderr";
1683
-
Rpc.Types.field =
1684
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1685
-
Rpc.Types.fdefault = None;
1686
-
Rpc.Types.fdescription = [];
1687
-
Rpc.Types.fversion = None;
1688
-
Rpc.Types.fget = (fun _r -> _r.stderr);
1689
-
Rpc.Types.fset = (fun v _s -> { _s with stderr = v })
1690
-
}
1691
-
and exec_result_sharp_ppf : (_, exec_result) Rpc.Types.field =
1692
-
{
1693
-
Rpc.Types.fname = "sharp_ppf";
1694
-
Rpc.Types.field =
1695
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1696
-
Rpc.Types.fdefault = None;
1697
-
Rpc.Types.fdescription = [];
1698
-
Rpc.Types.fversion = None;
1699
-
Rpc.Types.fget = (fun _r -> _r.sharp_ppf);
1700
-
Rpc.Types.fset = (fun v _s -> { _s with sharp_ppf = v })
1701
-
}
1702
-
and exec_result_caml_ppf : (_, exec_result) Rpc.Types.field =
1703
-
{
1704
-
Rpc.Types.fname = "caml_ppf";
1705
-
Rpc.Types.field =
1706
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
1707
-
Rpc.Types.fdefault = None;
1708
-
Rpc.Types.fdescription = [];
1709
-
Rpc.Types.fversion = None;
1710
-
Rpc.Types.fget = (fun _r -> _r.caml_ppf);
1711
-
Rpc.Types.fset = (fun v _s -> { _s with caml_ppf = v })
1712
-
}
1713
-
and exec_result_highlight : (_, exec_result) Rpc.Types.field =
1714
-
{
1715
-
Rpc.Types.fname = "highlight";
1716
-
Rpc.Types.field = (Rpc.Types.Option typ_of_highlight);
1717
-
Rpc.Types.fdefault = None;
1718
-
Rpc.Types.fdescription = [];
1719
-
Rpc.Types.fversion = None;
1720
-
Rpc.Types.fget = (fun _r -> _r.highlight);
1721
-
Rpc.Types.fset = (fun v _s -> { _s with highlight = v })
1722
-
}
1723
-
and exec_result_mime_vals : (_, exec_result) Rpc.Types.field =
1724
-
{
1725
-
Rpc.Types.fname = "mime_vals";
1726
-
Rpc.Types.field = (Rpc.Types.List typ_of_mime_val);
1727
-
Rpc.Types.fdefault = None;
1728
-
Rpc.Types.fdescription = [];
1729
-
Rpc.Types.fversion = None;
1730
-
Rpc.Types.fget = (fun _r -> _r.mime_vals);
1731
-
Rpc.Types.fset = (fun v _s -> { _s with mime_vals = v })
1732
-
}
1733
-
and typ_of_exec_result =
1734
-
Rpc.Types.Struct
1735
-
({
1736
-
Rpc.Types.fields =
1737
-
[Rpc.Types.BoxedField exec_result_stdout;
1738
-
Rpc.Types.BoxedField exec_result_stderr;
1739
-
Rpc.Types.BoxedField exec_result_sharp_ppf;
1740
-
Rpc.Types.BoxedField exec_result_caml_ppf;
1741
-
Rpc.Types.BoxedField exec_result_highlight;
1742
-
Rpc.Types.BoxedField exec_result_mime_vals];
1743
-
Rpc.Types.sname = "exec_result";
1744
-
Rpc.Types.version = None;
1745
-
Rpc.Types.constructor =
1746
-
(fun getter ->
1747
-
let open Rresult.R in
1748
-
(getter.Rpc.Types.field_get "mime_vals"
1749
-
(Rpc.Types.List typ_of_mime_val))
1750
-
>>=
1751
-
(fun exec_result_mime_vals ->
1752
-
(getter.Rpc.Types.field_get "highlight"
1753
-
(Rpc.Types.Option typ_of_highlight))
1754
-
>>=
1755
-
(fun exec_result_highlight ->
1756
-
(getter.Rpc.Types.field_get "caml_ppf"
1757
-
(Rpc.Types.Option
1758
-
(let open Rpc.Types in Basic String)))
1759
-
>>=
1760
-
(fun exec_result_caml_ppf ->
1761
-
(getter.Rpc.Types.field_get "sharp_ppf"
1762
-
(Rpc.Types.Option
1763
-
(let open Rpc.Types in Basic String)))
1764
-
>>=
1765
-
(fun exec_result_sharp_ppf ->
1766
-
(getter.Rpc.Types.field_get "stderr"
1767
-
(Rpc.Types.Option
1768
-
(let open Rpc.Types in
1769
-
Basic String)))
1770
-
>>=
1771
-
(fun exec_result_stderr ->
1772
-
(getter.Rpc.Types.field_get
1773
-
"stdout"
1774
-
(Rpc.Types.Option
1775
-
(let open Rpc.Types in
1776
-
Basic String)))
1777
-
>>=
1778
-
(fun exec_result_stdout ->
1779
-
return
1780
-
{
1781
-
stdout =
1782
-
exec_result_stdout;
1783
-
stderr =
1784
-
exec_result_stderr;
1785
-
sharp_ppf =
1786
-
exec_result_sharp_ppf;
1787
-
caml_ppf =
1788
-
exec_result_caml_ppf;
1789
-
highlight =
1790
-
exec_result_highlight;
1791
-
mime_vals =
1792
-
exec_result_mime_vals
1793
-
})))))))
1794
-
} : exec_result Rpc.Types.structure)
1795
-
and exec_result =
1796
-
{
1797
-
Rpc.Types.name = "exec_result";
1798
-
Rpc.Types.description =
1799
-
["Represents the result of executing a toplevel phrase"];
1800
-
Rpc.Types.ty = typ_of_exec_result
1801
-
}
1802
-
let _ = exec_result_stdout
1803
-
and _ = exec_result_stderr
1804
-
and _ = exec_result_sharp_ppf
1805
-
and _ = exec_result_caml_ppf
1806
-
and _ = exec_result_highlight
1807
-
and _ = exec_result_mime_vals
1808
-
and _ = typ_of_exec_result
1809
-
and _ = exec_result
1810
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1811
-
type script_parts = (int * int) list[@@deriving rpcty]
1812
-
include
1813
-
struct
1814
-
let _ = fun (_ : script_parts) -> ()
1815
-
let rec typ_of_script_parts =
1816
-
Rpc.Types.List
1817
-
(Rpc.Types.Tuple
1818
-
((let open Rpc.Types in Basic Int),
1819
-
(let open Rpc.Types in Basic Int)))
1820
-
and script_parts =
1821
-
{
1822
-
Rpc.Types.name = "script_parts";
1823
-
Rpc.Types.description = [];
1824
-
Rpc.Types.ty = typ_of_script_parts
1825
-
}
1826
-
let _ = typ_of_script_parts
1827
-
and _ = script_parts
1828
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1829
-
type exec_toplevel_result =
1830
-
{
1831
-
script: string ;
1832
-
parts: script_parts ;
1833
-
mime_vals: mime_val list }[@@deriving rpcty][@@ocaml.doc
1834
-
" Represents the result of executing a toplevel script "]
1835
-
include
1836
-
struct
1837
-
let _ = fun (_ : exec_toplevel_result) -> ()
1838
-
let rec exec_toplevel_result_script :
1839
-
(_, exec_toplevel_result) Rpc.Types.field =
1840
-
{
1841
-
Rpc.Types.fname = "script";
1842
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1843
-
Rpc.Types.fdefault = None;
1844
-
Rpc.Types.fdescription = [];
1845
-
Rpc.Types.fversion = None;
1846
-
Rpc.Types.fget = (fun _r -> _r.script);
1847
-
Rpc.Types.fset = (fun v _s -> { _s with script = v })
1848
-
}
1849
-
and exec_toplevel_result_parts :
1850
-
(_, exec_toplevel_result) Rpc.Types.field =
1851
-
{
1852
-
Rpc.Types.fname = "parts";
1853
-
Rpc.Types.field = typ_of_script_parts;
1854
-
Rpc.Types.fdefault = None;
1855
-
Rpc.Types.fdescription = [];
1856
-
Rpc.Types.fversion = None;
1857
-
Rpc.Types.fget = (fun _r -> _r.parts);
1858
-
Rpc.Types.fset = (fun v _s -> { _s with parts = v })
1859
-
}
1860
-
and exec_toplevel_result_mime_vals :
1861
-
(_, exec_toplevel_result) Rpc.Types.field =
1862
-
{
1863
-
Rpc.Types.fname = "mime_vals";
1864
-
Rpc.Types.field = (Rpc.Types.List typ_of_mime_val);
1865
-
Rpc.Types.fdefault = None;
1866
-
Rpc.Types.fdescription = [];
1867
-
Rpc.Types.fversion = None;
1868
-
Rpc.Types.fget = (fun _r -> _r.mime_vals);
1869
-
Rpc.Types.fset = (fun v _s -> { _s with mime_vals = v })
1870
-
}
1871
-
and typ_of_exec_toplevel_result =
1872
-
Rpc.Types.Struct
1873
-
({
1874
-
Rpc.Types.fields =
1875
-
[Rpc.Types.BoxedField exec_toplevel_result_script;
1876
-
Rpc.Types.BoxedField exec_toplevel_result_parts;
1877
-
Rpc.Types.BoxedField exec_toplevel_result_mime_vals];
1878
-
Rpc.Types.sname = "exec_toplevel_result";
1879
-
Rpc.Types.version = None;
1880
-
Rpc.Types.constructor =
1881
-
(fun getter ->
1882
-
let open Rresult.R in
1883
-
(getter.Rpc.Types.field_get "mime_vals"
1884
-
(Rpc.Types.List typ_of_mime_val))
1885
-
>>=
1886
-
(fun exec_toplevel_result_mime_vals ->
1887
-
(getter.Rpc.Types.field_get "parts"
1888
-
typ_of_script_parts)
1889
-
>>=
1890
-
(fun exec_toplevel_result_parts ->
1891
-
(getter.Rpc.Types.field_get "script"
1892
-
(let open Rpc.Types in Basic String))
1893
-
>>=
1894
-
(fun exec_toplevel_result_script ->
1895
-
return
1896
-
{
1897
-
script = exec_toplevel_result_script;
1898
-
parts = exec_toplevel_result_parts;
1899
-
mime_vals =
1900
-
exec_toplevel_result_mime_vals
1901
-
}))))
1902
-
} : exec_toplevel_result Rpc.Types.structure)
1903
-
and exec_toplevel_result =
1904
-
{
1905
-
Rpc.Types.name = "exec_toplevel_result";
1906
-
Rpc.Types.description =
1907
-
["Represents the result of executing a toplevel script"];
1908
-
Rpc.Types.ty = typ_of_exec_toplevel_result
1909
-
}
1910
-
let _ = exec_toplevel_result_script
1911
-
and _ = exec_toplevel_result_parts
1912
-
and _ = exec_toplevel_result_mime_vals
1913
-
and _ = typ_of_exec_toplevel_result
1914
-
and _ = exec_toplevel_result
1915
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1916
-
type cma =
1917
-
{
1918
-
url: string [@ocaml.doc " URL where the cma is available "];
1919
-
fn: string [@ocaml.doc " Name of the 'wrapping' function "]}[@@deriving
1920
-
rpcty]
1921
-
include
1922
-
struct
1923
-
let _ = fun (_ : cma) -> ()
1924
-
let rec cma_url : (_, cma) Rpc.Types.field =
1925
-
{
1926
-
Rpc.Types.fname = "url";
1927
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1928
-
Rpc.Types.fdefault = None;
1929
-
Rpc.Types.fdescription = ["URL where the cma is available"];
1930
-
Rpc.Types.fversion = None;
1931
-
Rpc.Types.fget = (fun _r -> _r.url);
1932
-
Rpc.Types.fset = (fun v _s -> { _s with url = v })
1933
-
}
1934
-
and cma_fn : (_, cma) Rpc.Types.field =
1935
-
{
1936
-
Rpc.Types.fname = "fn";
1937
-
Rpc.Types.field = (let open Rpc.Types in Basic String);
1938
-
Rpc.Types.fdefault = None;
1939
-
Rpc.Types.fdescription = ["Name of the 'wrapping' function"];
1940
-
Rpc.Types.fversion = None;
1941
-
Rpc.Types.fget = (fun _r -> _r.fn);
1942
-
Rpc.Types.fset = (fun v _s -> { _s with fn = v })
1943
-
}
1944
-
and typ_of_cma =
1945
-
Rpc.Types.Struct
1946
-
({
1947
-
Rpc.Types.fields =
1948
-
[Rpc.Types.BoxedField cma_url; Rpc.Types.BoxedField cma_fn];
1949
-
Rpc.Types.sname = "cma";
1950
-
Rpc.Types.version = None;
1951
-
Rpc.Types.constructor =
1952
-
(fun getter ->
1953
-
let open Rresult.R in
1954
-
(getter.Rpc.Types.field_get "fn"
1955
-
(let open Rpc.Types in Basic String))
1956
-
>>=
1957
-
(fun cma_fn ->
1958
-
(getter.Rpc.Types.field_get "url"
1959
-
(let open Rpc.Types in Basic String))
1960
-
>>=
1961
-
(fun cma_url ->
1962
-
return { url = cma_url; fn = cma_fn })))
1963
-
} : cma Rpc.Types.structure)
1964
-
and cma =
1965
-
{
1966
-
Rpc.Types.name = "cma";
1967
-
Rpc.Types.description = [];
1968
-
Rpc.Types.ty = typ_of_cma
1969
-
}
1970
-
let _ = cma_url
1971
-
and _ = cma_fn
1972
-
and _ = typ_of_cma
1973
-
and _ = cma
1974
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
1975
-
type init_config =
1976
-
{
1977
-
findlib_requires: string list [@ocaml.doc " Findlib packages to require "];
1978
-
stdlib_dcs: string option
1979
-
[@ocaml.doc " URL to the dynamic cmis for the OCaml standard library "];
1980
-
findlib_index: string option
1981
-
[@ocaml.doc
1982
-
" URL to the findlib_index.json file. Defaults to \"findlib_index.json\" "];
1983
-
execute: bool
1984
-
[@ocaml.doc " Whether this session should support execution or not. "]}
1985
-
[@@deriving rpcty]
1986
-
include
1987
-
struct
1988
-
let _ = fun (_ : init_config) -> ()
1989
-
let rec init_config_findlib_requires : (_, init_config) Rpc.Types.field =
1990
-
{
1991
-
Rpc.Types.fname = "findlib_requires";
1992
-
Rpc.Types.field =
1993
-
(Rpc.Types.List (let open Rpc.Types in Basic String));
1994
-
Rpc.Types.fdefault = None;
1995
-
Rpc.Types.fdescription = ["Findlib packages to require"];
1996
-
Rpc.Types.fversion = None;
1997
-
Rpc.Types.fget = (fun _r -> _r.findlib_requires);
1998
-
Rpc.Types.fset = (fun v _s -> { _s with findlib_requires = v })
1999
-
}
2000
-
and init_config_stdlib_dcs : (_, init_config) Rpc.Types.field =
2001
-
{
2002
-
Rpc.Types.fname = "stdlib_dcs";
2003
-
Rpc.Types.field =
2004
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
2005
-
Rpc.Types.fdefault = None;
2006
-
Rpc.Types.fdescription =
2007
-
["URL to the dynamic cmis for the OCaml standard library"];
2008
-
Rpc.Types.fversion = None;
2009
-
Rpc.Types.fget = (fun _r -> _r.stdlib_dcs);
2010
-
Rpc.Types.fset = (fun v _s -> { _s with stdlib_dcs = v })
2011
-
}
2012
-
and init_config_findlib_index : (_, init_config) Rpc.Types.field =
2013
-
{
2014
-
Rpc.Types.fname = "findlib_index";
2015
-
Rpc.Types.field =
2016
-
(Rpc.Types.Option (let open Rpc.Types in Basic String));
2017
-
Rpc.Types.fdefault = None;
2018
-
Rpc.Types.fdescription =
2019
-
["URL to the findlib_index.json file. Defaults to \"findlib_index.json\""];
2020
-
Rpc.Types.fversion = None;
2021
-
Rpc.Types.fget = (fun _r -> _r.findlib_index);
2022
-
Rpc.Types.fset = (fun v _s -> { _s with findlib_index = v })
2023
-
}
2024
-
and init_config_execute : (_, init_config) Rpc.Types.field =
2025
-
{
2026
-
Rpc.Types.fname = "execute";
2027
-
Rpc.Types.field = (let open Rpc.Types in Basic Bool);
2028
-
Rpc.Types.fdefault = None;
2029
-
Rpc.Types.fdescription =
2030
-
["Whether this session should support execution or not."];
2031
-
Rpc.Types.fversion = None;
2032
-
Rpc.Types.fget = (fun _r -> _r.execute);
2033
-
Rpc.Types.fset = (fun v _s -> { _s with execute = v })
2034
-
}
2035
-
and typ_of_init_config =
2036
-
Rpc.Types.Struct
2037
-
({
2038
-
Rpc.Types.fields =
2039
-
[Rpc.Types.BoxedField init_config_findlib_requires;
2040
-
Rpc.Types.BoxedField init_config_stdlib_dcs;
2041
-
Rpc.Types.BoxedField init_config_findlib_index;
2042
-
Rpc.Types.BoxedField init_config_execute];
2043
-
Rpc.Types.sname = "init_config";
2044
-
Rpc.Types.version = None;
2045
-
Rpc.Types.constructor =
2046
-
(fun getter ->
2047
-
let open Rresult.R in
2048
-
(getter.Rpc.Types.field_get "execute"
2049
-
(let open Rpc.Types in Basic Bool))
2050
-
>>=
2051
-
(fun init_config_execute ->
2052
-
(getter.Rpc.Types.field_get "findlib_index"
2053
-
(Rpc.Types.Option
2054
-
(let open Rpc.Types in Basic String)))
2055
-
>>=
2056
-
(fun init_config_findlib_index ->
2057
-
(getter.Rpc.Types.field_get "stdlib_dcs"
2058
-
(Rpc.Types.Option
2059
-
(let open Rpc.Types in Basic String)))
2060
-
>>=
2061
-
(fun init_config_stdlib_dcs ->
2062
-
(getter.Rpc.Types.field_get
2063
-
"findlib_requires"
2064
-
(Rpc.Types.List
2065
-
(let open Rpc.Types in Basic String)))
2066
-
>>=
2067
-
(fun init_config_findlib_requires ->
2068
-
return
2069
-
{
2070
-
findlib_requires =
2071
-
init_config_findlib_requires;
2072
-
stdlib_dcs = init_config_stdlib_dcs;
2073
-
findlib_index =
2074
-
init_config_findlib_index;
2075
-
execute = init_config_execute
2076
-
})))))
2077
-
} : init_config Rpc.Types.structure)
2078
-
and init_config =
2079
-
{
2080
-
Rpc.Types.name = "init_config";
2081
-
Rpc.Types.description = [];
2082
-
Rpc.Types.ty = typ_of_init_config
2083
-
}
2084
-
let _ = init_config_findlib_requires
2085
-
and _ = init_config_stdlib_dcs
2086
-
and _ = init_config_findlib_index
2087
-
and _ = init_config_execute
2088
-
and _ = typ_of_init_config
2089
-
and _ = init_config
2090
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2091
-
type err =
2092
-
| InternalError of string [@@deriving rpcty]
2093
-
include
2094
-
struct
2095
-
let _ = fun (_ : err) -> ()
2096
-
let rec typ_of_err =
2097
-
Rpc.Types.Variant
2098
-
({
2099
-
Rpc.Types.vname = "err";
2100
-
Rpc.Types.variants =
2101
-
[BoxedTag
2102
-
{
2103
-
Rpc.Types.tname = "InternalError";
2104
-
Rpc.Types.tcontents =
2105
-
((let open Rpc.Types in Basic String));
2106
-
Rpc.Types.tversion = None;
2107
-
Rpc.Types.tdescription = [];
2108
-
Rpc.Types.tpreview =
2109
-
((function | InternalError a0 -> Some a0));
2110
-
Rpc.Types.treview = ((function | a0 -> InternalError a0))
2111
-
}];
2112
-
Rpc.Types.vdefault = None;
2113
-
Rpc.Types.vversion = None;
2114
-
Rpc.Types.vconstructor =
2115
-
(fun s' t ->
2116
-
let s = String.lowercase_ascii s' in
2117
-
match s with
2118
-
| "internalerror" ->
2119
-
Rresult.R.bind
2120
-
(t.tget (let open Rpc.Types in Basic String))
2121
-
(function | a0 -> Rresult.R.ok (InternalError a0))
2122
-
| _ ->
2123
-
Rresult.R.error_msg (Printf.sprintf "Unknown tag '%s'" s))
2124
-
} : err Rpc.Types.variant)
2125
-
and err =
2126
-
{
2127
-
Rpc.Types.name = "err";
2128
-
Rpc.Types.description = [];
2129
-
Rpc.Types.ty = typ_of_err
2130
-
}
2131
-
let _ = typ_of_err
2132
-
and _ = err
2133
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2134
-
type opt_id = string option[@@deriving rpcty]
2135
-
include
2136
-
struct
2137
-
let _ = fun (_ : opt_id) -> ()
2138
-
let rec typ_of_opt_id =
2139
-
Rpc.Types.Option (let open Rpc.Types in Basic String)
2140
-
and opt_id =
2141
-
{
2142
-
Rpc.Types.name = "opt_id";
2143
-
Rpc.Types.description = [];
2144
-
Rpc.Types.ty = typ_of_opt_id
2145
-
}
2146
-
let _ = typ_of_opt_id
2147
-
and _ = opt_id
2148
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2149
-
type env_id = string[@@deriving rpcty][@@ocaml.doc
2150
-
" Environment identifier. If empty string, uses the default environment. "]
2151
-
include
2152
-
struct
2153
-
let _ = fun (_ : env_id) -> ()
2154
-
let rec typ_of_env_id = let open Rpc.Types in Basic String
2155
-
and env_id =
2156
-
{
2157
-
Rpc.Types.name = "env_id";
2158
-
Rpc.Types.description =
2159
-
["Environment identifier. If empty string, uses the default environment."];
2160
-
Rpc.Types.ty = typ_of_env_id
2161
-
}
2162
-
let _ = typ_of_env_id
2163
-
and _ = env_id
2164
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2165
-
type env_id_list = string list[@@deriving rpcty][@@ocaml.doc
2166
-
" List of environment identifiers "]
2167
-
include
2168
-
struct
2169
-
let _ = fun (_ : env_id_list) -> ()
2170
-
let rec typ_of_env_id_list =
2171
-
Rpc.Types.List (let open Rpc.Types in Basic String)
2172
-
and env_id_list =
2173
-
{
2174
-
Rpc.Types.name = "env_id_list";
2175
-
Rpc.Types.description = ["List of environment identifiers"];
2176
-
Rpc.Types.ty = typ_of_env_id_list
2177
-
}
2178
-
let _ = typ_of_env_id_list
2179
-
and _ = env_id_list
2180
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2181
-
type dependencies = string list[@@deriving rpcty][@@ocaml.doc
2182
-
" The ids of the cells that are dependencies "]
2183
-
include
2184
-
struct
2185
-
let _ = fun (_ : dependencies) -> ()
2186
-
let rec typ_of_dependencies =
2187
-
Rpc.Types.List (let open Rpc.Types in Basic String)
2188
-
and dependencies =
2189
-
{
2190
-
Rpc.Types.name = "dependencies";
2191
-
Rpc.Types.description =
2192
-
["The ids of the cells that are dependencies"];
2193
-
Rpc.Types.ty = typ_of_dependencies
2194
-
}
2195
-
let _ = typ_of_dependencies
2196
-
and _ = dependencies
2197
-
end[@@ocaml.doc "@inline"][@@merlin.hide ]
2198
-
module E =
2199
-
(Idl.Error.Make)(struct
2200
-
type t = err
2201
-
let t = err
2202
-
let internal_error_of e =
2203
-
Some (InternalError (Printexc.to_string e))
2204
-
end)
2205
-
let err = E.error
2206
-
module Make(R:RPC) =
2207
-
struct
2208
-
open R
2209
-
let description =
2210
-
let open Interface in
2211
-
{
2212
-
name = "Toplevel";
2213
-
namespace = None;
2214
-
description =
2215
-
["Functions for manipulating the toplevel worker thread"];
2216
-
version = (1, 0, 0)
2217
-
}
2218
-
let implementation = implement description
2219
-
let unit_p = Param.mk Types.unit
2220
-
let phrase_p =
2221
-
Param.mk ~description:["The OCaml phrase to execute"] Types.string
2222
-
let id_p = Param.mk opt_id
2223
-
let env_id_p =
2224
-
Param.mk ~name:"env_id"
2225
-
~description:["Environment ID (empty string for default)"] env_id
2226
-
let env_id_list_p = Param.mk env_id_list
2227
-
let dependencies_p = Param.mk dependencies
2228
-
let exec_result_p = Param.mk exec_result
2229
-
let source_p = Param.mk source
2230
-
let position_p = Param.mk msource_position
2231
-
let completions_p = Param.mk completions
2232
-
let error_list_p = Param.mk error_list
2233
-
let typed_enclosings_p = Param.mk typed_enclosings_list
2234
-
let is_toplevel_p = Param.mk ~name:"is_toplevel" Types.bool
2235
-
let toplevel_script_p =
2236
-
Param.mk
2237
-
~description:["A toplevel script is a sequence of toplevel phrases interspersed with";
2238
-
"The output from the toplevel. Each phase must be preceded by '# ', and";
2239
-
"the output from the toplevel is indented by 2 spaces."]
2240
-
Types.string
2241
-
let exec_toplevel_result_p = Param.mk exec_toplevel_result
2242
-
let init_libs =
2243
-
Param.mk ~name:"init_libs"
2244
-
~description:["Configuration for the toplevel."] init_config
2245
-
let init =
2246
-
declare "init"
2247
-
["Initialise the toplevel. This must be called before any other API."]
2248
-
(init_libs @-> (returning unit_p err))
2249
-
[@@@ocaml.text " {2 Environment Management} "]
2250
-
let create_env =
2251
-
declare "create_env"
2252
-
["Create a new isolated execution environment with the given ID.";
2253
-
"Returns unit on success. The environment must be set up with";
2254
-
"setup_env before use."] (env_id_p @-> (returning unit_p err))
2255
-
let destroy_env =
2256
-
declare "destroy_env"
2257
-
["Destroy an execution environment, freeing its resources.";
2258
-
"The environment ID must exist."]
2259
-
(env_id_p @-> (returning unit_p err))
2260
-
let list_envs =
2261
-
declare "list_envs" ["List all existing environment IDs."]
2262
-
(unit_p @-> (returning env_id_list_p err))
2263
-
let setup =
2264
-
declare "setup"
2265
-
["Start the toplevel for the given environment. Return value is the";
2266
-
"initial blurb printed when starting a toplevel. Note that the";
2267
-
"toplevel must be initialised first. If env_id is None, uses the";
2268
-
"default environment."] (env_id_p @-> (returning exec_result_p err))
2269
-
let exec =
2270
-
declare "exec"
2271
-
["Execute a phrase using the toplevel. The toplevel must have been";
2272
-
"initialised first. If env_id is None, uses the default environment."]
2273
-
(env_id_p @-> (phrase_p @-> (returning exec_result_p err)))
2274
-
let exec_toplevel =
2275
-
declare "exec_toplevel"
2276
-
["Execute a toplevel script. The toplevel must have been";
2277
-
"initialised first. Returns the updated toplevel script.";
2278
-
"If env_id is None, uses the default environment."]
2279
-
(env_id_p @->
2280
-
(toplevel_script_p @-> (returning exec_toplevel_result_p err)))
2281
-
let complete_prefix =
2282
-
declare "complete_prefix"
2283
-
["Complete a prefix. If env_id is None, uses the default environment."]
2284
-
(env_id_p @->
2285
-
(id_p @->
2286
-
(dependencies_p @->
2287
-
(is_toplevel_p @->
2288
-
(source_p @->
2289
-
(position_p @-> (returning completions_p err)))))))
2290
-
let query_errors =
2291
-
declare "query_errors"
2292
-
["Query the errors in the given source.";
2293
-
"If env_id is None, uses the default environment."]
2294
-
(env_id_p @->
2295
-
(id_p @->
2296
-
(dependencies_p @->
2297
-
(is_toplevel_p @->
2298
-
(source_p @-> (returning error_list_p err))))))
2299
-
let type_enclosing =
2300
-
declare "type_enclosing"
2301
-
["Get the type of the enclosing expression.";
2302
-
"If env_id is None, uses the default environment."]
2303
-
(env_id_p @->
2304
-
(id_p @->
2305
-
(dependencies_p @->
2306
-
(is_toplevel_p @->
2307
-
(source_p @->
2308
-
(position_p @-> (returning typed_enclosings_p err)))))))
2309
-
end
-34
idl/transport.ml
-34
idl/transport.ml
···
1
-
(** Transport abstraction for RPC encoding.
2
-
3
-
This module provides a common interface for encoding/decoding RPC messages.
4
-
Uses JSON-RPC for browser compatibility. *)
5
-
6
-
module type S = sig
7
-
(** Encode a call (ID is auto-generated) *)
8
-
val string_of_call : Rpc.call -> string
9
-
10
-
(** Decode a message to get the ID and call *)
11
-
val id_and_call_of_string : string -> Rpc.t * Rpc.call
12
-
13
-
(** Encode a response with the given ID *)
14
-
val string_of_response : id:Rpc.t -> Rpc.response -> string
15
-
16
-
(** Decode a message to get the response *)
17
-
val response_of_string : string -> Rpc.response
18
-
end
19
-
20
-
(** JSON-RPC transport *)
21
-
module Json : S = struct
22
-
let string_of_call call =
23
-
Jsonrpc.string_of_call call
24
-
25
-
let id_and_call_of_string s =
26
-
let _, id, call = Jsonrpc.version_id_and_call_of_string s in
27
-
(id, call)
28
-
29
-
let string_of_response ~id response =
30
-
Jsonrpc.string_of_response ~id response
31
-
32
-
let response_of_string s =
33
-
Jsonrpc.response_of_string s
34
-
end
-25
idl/transport.mli
-25
idl/transport.mli
···
1
-
(** Transport abstraction for RPC encoding.
2
-
3
-
This module provides a common interface for encoding/decoding RPC messages.
4
-
Uses JSON-RPC for browser compatibility. *)
5
-
6
-
(** Transport signature defining the encoding/decoding interface. *)
7
-
module type S = sig
8
-
val string_of_call : Rpc.call -> string
9
-
(** Encode a call. A unique request ID is auto-generated. *)
10
-
11
-
val id_and_call_of_string : string -> Rpc.t * Rpc.call
12
-
(** Decode a message to get the ID and call.
13
-
@raise Failure if decoding fails. *)
14
-
15
-
val string_of_response : id:Rpc.t -> Rpc.response -> string
16
-
(** Encode a response with the given ID. *)
17
-
18
-
val response_of_string : string -> Rpc.response
19
-
(** Decode a message to get the response.
20
-
@raise Failure if decoding fails. *)
21
-
end
22
-
23
-
(** JSON-RPC transport.
24
-
Uses the standard JSON-RPC 2.0 encoding from [rpclib.json]. *)
25
-
module Json : S
+1
-1
js_top_worker-bin.opam
+1
-1
js_top_worker-bin.opam
+4
-6
js_top_worker-client.opam
+4
-6
js_top_worker-client.opam
···
9
9
"ocaml"
10
10
"dune" {>= "2.9.1"}
11
11
"js_of_ocaml" {>= "3.11.0"}
12
-
"rresult"
13
-
"astring"
14
-
"brr" {>= "0.0.4"}
15
-
"js_top_worker" {= version}
12
+
"js_of_ocaml-ppx"
16
13
"js_top_worker-rpc" {= version}
17
14
"lwt"
15
+
"brr" {>= "0.0.4"}
18
16
]
19
17
build : [
20
18
["dune" "subst"] {pinned}
21
19
["dune" "build" "-p" name "-j" jobs]
22
20
]
23
-
synopsis: "JS Toplevel worker client"
21
+
synopsis: "JS Toplevel worker client library"
24
22
description: """
25
-
An OCaml toplevel designed to run as a web worker
23
+
Client library for communicating with js_top_worker via message protocol
26
24
"""
-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
-
"""
+6
-13
js_top_worker-rpc.opam
+6
-13
js_top_worker-rpc.opam
···
6
6
homepage: "https://github.com/jonludlam/js_top_worker"
7
7
bug-reports: "https://github.com/jonludlam/js_top_worker/issues"
8
8
depends: [
9
-
"ocaml" {>= "5.1"}
10
-
"dune" {>= "3.10"}
11
-
"mime_printer"
12
-
"rresult"
13
-
"merlin-lib"
14
-
"rpclib"
15
-
"js_of_ocaml" {>= "5.0"}
16
-
"js_of_ocaml-ppx" {>= "5.0"}
9
+
"ocaml"
10
+
"dune" {>= "2.9.1"}
11
+
"js_of_ocaml" {>= "3.11.0"}
12
+
"js_of_ocaml-ppx"
17
13
]
18
14
build : [
19
15
["dune" "subst"] {pinned}
20
16
["dune" "build" "-p" name "-j" jobs]
21
17
]
22
-
synopsis: "JS Toplevel worker - RPC functions"
18
+
synopsis: "JS Toplevel worker message protocol"
23
19
description: """
24
-
An OCaml toplevel designed to run as a web worker
20
+
Message protocol definitions for js_top_worker communication
25
21
"""
26
-
pin-depends: [
27
-
[ "mime_printer.dev" "git+https://github.com/jonludlam/mime_printer.git#odoc_notebook" ]
28
-
]
-1
js_top_worker-unix.opam
-1
js_top_worker-unix.opam
-1
js_top_worker-web.opam
-1
js_top_worker-web.opam
+1
-2
js_top_worker.opam
+1
-2
js_top_worker.opam
-21
js_top_worker_rpc_def.opam
-21
js_top_worker_rpc_def.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
-
"ppx_deriving_rpc"
12
-
"rresult"
13
-
]
14
-
build : [
15
-
["dune" "subst"] {pinned}
16
-
["dune" "build" "-p" name "-j" jobs]
17
-
]
18
-
synopsis: "JS Toplevel worker IDL generator"
19
-
description: """
20
-
An OCaml toplevel designed to run as a web worker: IDL generator edition
21
-
"""
+4
-6
lib/dune
+4
-6
lib/dune
···
6
6
(modules toplexer ocamltop impl environment)
7
7
(libraries
8
8
logs
9
-
js_top_worker-rpc
10
-
rpclib-lwt
9
+
lwt
11
10
js_of_ocaml-compiler
12
11
js_of_ocaml-ppx
13
12
astring
···
37
36
(modules toplexer ocamltop impl environment)
38
37
(libraries
39
38
logs
40
-
js_top_worker-rpc
41
-
rpclib-lwt
39
+
lwt
42
40
js_of_ocaml-compiler
43
41
js_of_ocaml-ppx
44
42
astring
···
82
80
angstrom
83
81
findlib
84
82
fpath
85
-
rpclib.json))
83
+
yojson))
86
84
87
85
; Web worker library -- OxCaml
88
86
···
104
102
angstrom
105
103
findlib
106
104
fpath
107
-
rpclib.json))
105
+
yojson))
+13
-6
lib/findlibish.ml
+13
-6
lib/findlibish.ml
···
30
30
"js_of_ocaml-ppx";
31
31
"js_of_ocaml-toplevel";
32
32
"js_top_worker";
33
-
"js_top_worker-rpc";
34
33
"logs";
35
34
"logs.browser";
36
35
"merlin-lib.kernel";
···
118
117
let fetch_dynamic_cmis sync_get url =
119
118
match sync_get url with
120
119
| None -> Error (`Msg "Failed to fetch dynamic cmis")
121
-
| Some json ->
122
-
let rpc = Jsonrpc.of_string json in
123
-
Rpcmarshal.unmarshal
124
-
Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis rpc
120
+
| Some json_str ->
121
+
(try
122
+
let json = Yojson.Safe.from_string json_str in
123
+
let open Yojson.Safe.Util in
124
+
let dcs_url = json |> member "dcs_url" |> to_string in
125
+
let dcs_toplevel_modules =
126
+
json |> member "dcs_toplevel_modules" |> to_list |> List.map to_string in
127
+
let dcs_file_prefixes =
128
+
json |> member "dcs_file_prefixes" |> to_list |> List.map to_string in
129
+
Ok { Js_top_worker.Impl.dcs_url; dcs_toplevel_modules; dcs_file_prefixes }
130
+
with e ->
131
+
Error (`Msg (Printf.sprintf "Failed to parse dynamic_cmis JSON: %s" (Printexc.to_string e))))
125
132
126
133
let (let*) = Lwt.bind
127
134
···
266
273
267
274
let require ~import_scripts sync_get cmi_only v packages =
268
275
let rec require dcss package :
269
-
Js_top_worker_rpc.Toplevel_api_gen.dynamic_cmis list =
276
+
Js_top_worker.Impl.dynamic_cmis list =
270
277
match List.find (fun lib -> lib.name = package) v with
271
278
| exception Not_found ->
272
279
Jslib.log "Package %s not found" package;
+170
-71
lib/impl.ml
+170
-71
lib/impl.ml
···
8
8
platform-specific operations for different environments (WebWorker,
9
9
Node.js, Unix). *)
10
10
11
-
open Js_top_worker_rpc
12
-
module M = Rpc_lwt.ErrM (* Server is not synchronous *)
13
-
module IdlM = Rpc_lwt
11
+
let ( let* ) = Lwt.bind
12
+
13
+
(** {2 API Types}
14
+
15
+
These types define the toplevel API contract. They were previously
16
+
generated by [ppx_deriving_rpc] in [Toplevel_api_gen] but are now
17
+
plain OCaml types without RPC dependencies. *)
18
+
19
+
type err = InternalError of string
20
+
21
+
type highlight = { line1 : int; line2 : int; col1 : int; col2 : int }
22
+
23
+
type mime_val = Mime_printer.t = {
24
+
mime_type : string;
25
+
encoding : Mime_printer.encoding;
26
+
data : string;
27
+
}
28
+
29
+
type exec_result = {
30
+
stdout : string option;
31
+
stderr : string option;
32
+
sharp_ppf : string option;
33
+
caml_ppf : string option;
34
+
highlight : highlight option;
35
+
mime_vals : mime_val list;
36
+
}
37
+
38
+
type exec_toplevel_result = {
39
+
script : string;
40
+
parts : (int * int) list;
41
+
mime_vals : mime_val list;
42
+
}
43
+
44
+
type dynamic_cmis = {
45
+
dcs_url : string;
46
+
dcs_toplevel_modules : string list;
47
+
dcs_file_prefixes : string list;
48
+
}
49
+
50
+
type init_config = {
51
+
findlib_requires : string list;
52
+
stdlib_dcs : string option;
53
+
findlib_index : string option;
54
+
execute : bool;
55
+
}
56
+
57
+
type msource_position =
58
+
| Start
59
+
| Offset of int
60
+
| Logical of int * int
61
+
| End
62
+
63
+
type kind_ty =
64
+
| Value
65
+
| Constructor
66
+
| Variant
67
+
| Label
68
+
| Module
69
+
| Modtype
70
+
| Type
71
+
| MethodCall
72
+
| Keyword
14
73
15
-
let ( let* ) = Lwt.bind
74
+
type query_protocol_compl_entry = {
75
+
name : string;
76
+
kind : kind_ty;
77
+
desc : string;
78
+
info : string;
79
+
deprecated : bool;
80
+
}
81
+
82
+
type completions = {
83
+
from : int;
84
+
to_ : int;
85
+
entries : query_protocol_compl_entry list;
86
+
}
87
+
88
+
type index_or_string = Index of int | String of string
89
+
90
+
type tail_position = No | Tail_position | Tail_call
91
+
92
+
type location = Ocaml_parsing.Location.t
93
+
94
+
type error_kind = Ocaml_parsing.Location.report_kind =
95
+
| Report_error
96
+
| Report_warning of string
97
+
| Report_warning_as_error of string
98
+
| Report_alert of string
99
+
| Report_alert_as_error of string
100
+
101
+
type error_source = Ocaml_parsing.Location.error_source =
102
+
| Lexer
103
+
| Parser
104
+
| Typer
105
+
| Warning
106
+
| Unknown
107
+
| Env
108
+
| Config
109
+
110
+
type error = {
111
+
kind : error_kind;
112
+
loc : location;
113
+
main : string;
114
+
sub : string list;
115
+
source : error_source;
116
+
}
117
+
118
+
type typed_enclosings = location * index_or_string * tail_position
16
119
17
120
(** {2 Cell Dependency System}
18
121
···
170
273
val async_get : string -> (string, [> `Msg of string ]) result Lwt.t
171
274
val import_scripts : string list -> unit
172
275
val init_function : string -> unit -> unit
173
-
val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
276
+
val get_stdlib_dcs : string -> dynamic_cmis list
174
277
val findlib_init : string -> findlib_t Lwt.t
175
278
val path : string
176
279
177
280
val require :
178
-
bool -> findlib_t -> string list -> Toplevel_api_gen.dynamic_cmis list
281
+
bool -> findlib_t -> string list -> dynamic_cmis list
179
282
end
180
283
181
284
(** {2 Main Functor}
···
244
347
Fetches and installs toplevel CMIs synchronously. *)
245
348
let furl = "file://" in
246
349
let l = String.length furl in
247
-
if String.length dcs.Toplevel_api_gen.dcs_url > l
350
+
if String.length dcs.dcs_url > l
248
351
&& String.sub dcs.dcs_url 0 l = furl
249
352
then begin
250
353
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
···
253
356
else begin
254
357
(* Web URL - fetch CMIs synchronously *)
255
358
let fetch_sync filename =
256
-
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
359
+
let url = Filename.concat dcs.dcs_url filename in
257
360
S.sync_get url
258
361
in
259
362
let path =
···
394
497
let set_highlight loc =
395
498
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
396
499
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
397
-
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
500
+
highlighted := Some { line1; col1; line2; col2 }
398
501
in
399
502
Buffer.clear code_buff;
400
503
Buffer.clear res_buff;
···
429
532
let mime_vals = Mime_printer.get () in
430
533
Format.pp_print_flush pp_code ();
431
534
Format.pp_print_flush pp_result ();
432
-
Toplevel_api_gen.
433
-
{
434
-
stdout = string_opt o.stdout;
435
-
stderr = string_opt o.stderr;
436
-
sharp_ppf = buff_opt code_buff;
437
-
caml_ppf = buff_opt res_buff;
438
-
highlight = !highlighted;
439
-
mime_vals;
440
-
}
535
+
{
536
+
stdout = string_opt o.stdout;
537
+
stderr = string_opt o.stderr;
538
+
sharp_ppf = buff_opt code_buff;
539
+
caml_ppf = buff_opt res_buff;
540
+
highlight = !highlighted;
541
+
mime_vals;
542
+
}
441
543
442
544
(** {3 Incremental Phrase Execution}
443
545
···
447
549
type phrase_output = {
448
550
loc : int;
449
551
caml_ppf : string option;
450
-
mime_vals : Toplevel_api_gen.mime_val list;
552
+
mime_vals : mime_val list;
451
553
}
452
554
453
555
let execute_in_env_incremental env phrase ~on_phrase_output =
···
459
561
let set_highlight loc =
460
562
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
461
563
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
462
-
highlighted := Some Toplevel_api_gen.{ line1; col1; line2; col2 }
564
+
highlighted := Some { line1; col1; line2; col2 }
463
565
in
464
566
Buffer.clear code_buff;
465
567
Buffer.clear res_buff;
···
511
613
let mime_vals = Mime_printer.get () in
512
614
Format.pp_print_flush pp_code ();
513
615
Format.pp_print_flush pp_result ();
514
-
Toplevel_api_gen.
515
-
{
516
-
stdout = string_opt o.stdout;
517
-
stderr = string_opt o.stderr;
518
-
sharp_ppf = buff_opt code_buff;
519
-
caml_ppf = buff_opt res_buff;
520
-
highlight = !highlighted;
521
-
mime_vals;
522
-
}
616
+
{
617
+
stdout = string_opt o.stdout;
618
+
stderr = string_opt o.stderr;
619
+
sharp_ppf = buff_opt code_buff;
620
+
caml_ppf = buff_opt res_buff;
621
+
highlight = !highlighted;
622
+
mime_vals;
623
+
}
523
624
524
625
(** {3 Dynamic CMI Loading}
525
626
···
548
649
549
650
let add_dynamic_cmis dcs =
550
651
let fetch filename =
551
-
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
652
+
let url = Filename.concat dcs.dcs_url filename in
552
653
S.async_get url
553
654
in
554
655
let fetch_sync filename =
555
-
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
656
+
let url = Filename.concat dcs.dcs_url filename in
556
657
S.sync_get url
557
658
in
558
659
let path =
···
616
717
if s = "merl" then reset_dirs () else reset_dirs_comp ()
617
718
| None ->
618
719
Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
619
-
(Filename.concat dcs.Toplevel_api_gen.dcs_url filename));
720
+
(Filename.concat dcs.dcs_url filename));
620
721
if s = "merl" then reset_dirs () else reset_dirs_comp ();
621
722
old_loader ~allow_hidden ~unit_name
622
723
in
···
647
748
in
648
749
Lwt.return ()
649
750
650
-
(** {3 RPC Handlers}
751
+
(** {3 API Functions}
651
752
652
-
Functions that implement the toplevel RPC API. Each function returns
653
-
results in the [IdlM.ErrM] monad. *)
753
+
Functions that implement the toplevel API. Each function returns
754
+
[(_, err) result Lwt.t]. *)
654
755
655
-
let init (init_libs : Toplevel_api_gen.init_config) =
756
+
let init (init_libs : init_config) =
656
757
Lwt.catch
657
758
(fun () ->
658
759
Logs.info (fun m -> m "init()");
···
686
787
Lwt.return (Ok ()))
687
788
(fun e ->
688
789
Lwt.return
689
-
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
790
+
(Error (InternalError (Printexc.to_string e))))
690
791
691
792
let setup env_id =
692
793
Lwt.catch
···
698
799
Logs.info (fun m -> m "setup() already done for env %s" (Environment.id env));
699
800
Lwt.return
700
801
(Ok
701
-
Toplevel_api_gen.
702
-
{
802
+
{
703
803
stdout = None;
704
804
stderr = Some "Environment already set up";
705
805
sharp_ppf = None;
···
751
851
752
852
Lwt.return
753
853
(Ok
754
-
Toplevel_api_gen.
755
-
{
854
+
{
756
855
stdout = string_opt o.stdout;
757
856
stderr = string_opt o.stderr;
758
857
sharp_ppf = None;
···
762
861
}))
763
862
(fun e ->
764
863
Lwt.return
765
-
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
864
+
(Error (InternalError (Printexc.to_string e))))
766
865
767
866
let handle_toplevel env stripped =
768
867
if String.length stripped < 2 || stripped.[0] <> '#' || stripped.[1] <> ' '
769
868
then (
770
869
Printf.eprintf
771
870
"Warning, ignoring toplevel block without a leading '# '.\n";
772
-
IdlM.ErrM.return
773
-
{ Toplevel_api_gen.script = stripped; mime_vals = []; parts = [] })
871
+
Lwt.return (Ok
872
+
{ script = stripped; mime_vals = []; parts = [] }))
774
873
else
775
874
let s = String.sub stripped 2 (String.length stripped - 2) in
776
875
let list = Ocamltop.parse_toplevel s in
···
798
897
String.sub content_txt 0 (String.length content_txt - 1)
799
898
in
800
899
let result =
801
-
{ Toplevel_api_gen.script = content_txt; mime_vals; parts = [] }
900
+
{ script = content_txt; mime_vals; parts = [] }
802
901
in
803
-
IdlM.ErrM.return result
902
+
Lwt.return (Ok result)
804
903
805
904
let exec_toplevel env_id (phrase : string) =
806
905
let env = resolve_env env_id in
807
906
try handle_toplevel env phrase
808
907
with e ->
809
908
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
810
-
IdlM.ErrM.return_err
811
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
909
+
Lwt.return (Error
910
+
(InternalError (Printexc.to_string e)))
812
911
813
912
let execute env_id (phrase : string) =
814
913
Logs.info (fun m -> m "execute() for env_id=%s" env_id);
815
914
let env = resolve_env env_id in
816
915
let result = execute_in_env env phrase in
817
916
Logs.info (fun m -> m "execute() done for env_id=%s" env_id);
818
-
IdlM.ErrM.return result
917
+
Lwt.return (Ok result)
819
918
820
919
let execute_incremental env_id (phrase : string) ~on_phrase_output =
821
920
Logs.info (fun m -> m "execute_incremental() for env_id=%s" env_id);
822
921
let env = resolve_env env_id in
823
922
let result = execute_in_env_incremental env phrase ~on_phrase_output in
824
923
Logs.info (fun m -> m "execute_incremental() done for env_id=%s" env_id);
825
-
IdlM.ErrM.return result
924
+
Lwt.return (Ok result)
826
925
827
926
(** {3 Merlin Integration}
828
927
···
966
1065
| `Type
967
1066
| `MethodCall
968
1067
| `Keyword ] ->
969
-
Toplevel_api_gen.kind_ty = function
1068
+
kind_ty = function
970
1069
| `Value -> Value
971
1070
| `Constructor -> Constructor
972
1071
| `Variant -> Variant
···
979
1078
in
980
1079
let position =
981
1080
match position with
982
-
| Toplevel_api_gen.Start -> `Offset (String.length line1)
1081
+
| Start -> `Offset (String.length line1)
983
1082
| Offset x -> `Offset (x + String.length line1)
984
1083
| Logical (x, y) -> `Logical (x + 1, y)
985
1084
| End -> `End
···
997
1096
List.map
998
1097
(fun (entry : Query_protocol.Compl.entry) ->
999
1098
{
1000
-
Toplevel_api_gen.name = entry.name;
1099
+
name = entry.name;
1001
1100
kind = map_kind entry.kind;
1002
1101
desc = entry.desc;
1003
1102
info = entry.info;
···
1006
1105
compl.entries
1007
1106
in
1008
1107
let l1l = String.length line1 in
1009
-
IdlM.ErrM.return { Toplevel_api_gen.from = from - l1l; to_ = to_ - l1l; entries }
1108
+
Lwt.return (Ok { from = from - l1l; to_ = to_ - l1l; entries })
1010
1109
| None ->
1011
-
IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
1110
+
Lwt.return (Ok { from = 0; to_ = 0; entries = [] })
1012
1111
with e ->
1013
1112
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1014
-
IdlM.ErrM.return_err
1015
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
1113
+
Lwt.return (Error
1114
+
(InternalError (Printexc.to_string e)))
1016
1115
1017
1116
let add_cmi execution_env id deps source =
1018
1117
Logs.info (fun m -> m "add_cmi");
···
1130
1229
else
1131
1230
Some
1132
1231
{
1133
-
Toplevel_api_gen.kind;
1232
+
kind;
1134
1233
loc;
1135
1234
main;
1136
1235
sub = StdLabels.List.map ~f:of_sub sub;
···
1145
1244
| None -> ());
1146
1245
1147
1246
(* Logs.info (fun m -> m "Got to end"); *)
1148
-
IdlM.ErrM.return errors
1247
+
Lwt.return (Ok errors)
1149
1248
with e ->
1150
1249
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1151
-
IdlM.ErrM.return_err
1152
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
1250
+
Lwt.return (Error
1251
+
(InternalError (Printexc.to_string e)))
1153
1252
1154
1253
let type_enclosing ?filename env_id _id deps is_toplevel orig_source position =
1155
1254
let execution_env = resolve_env env_id in
···
1161
1260
let src = line1 ^ src in
1162
1261
let position =
1163
1262
match position with
1164
-
| Toplevel_api_gen.Start -> `Start
1263
+
| Start -> `Start
1165
1264
| Offset x -> `Offset (x + String.length line1)
1166
1265
| Logical (x, y) -> `Logical (x + 1, y)
1167
1266
| End -> `End
···
1170
1269
let query = Query_protocol.Type_enclosing (None, position, None) in
1171
1270
let enclosing = wdispatch ?filename source query in
1172
1271
let map_index_or_string = function
1173
-
| `Index i -> Toplevel_api_gen.Index i
1272
+
| `Index i -> Index i
1174
1273
| `String s -> String s
1175
1274
in
1176
1275
let map_tail_position = function
1177
-
| `No -> Toplevel_api_gen.No
1276
+
| `No -> No
1178
1277
| `Tail_position -> Tail_position
1179
1278
| `Tail_call -> Tail_call
1180
1279
in
···
1184
1283
(map_loc line1 x, map_index_or_string y, map_tail_position z))
1185
1284
enclosing
1186
1285
in
1187
-
IdlM.ErrM.return enclosing
1286
+
Lwt.return (Ok enclosing)
1188
1287
with e ->
1189
1288
Logs.info (fun m -> m "Error: %s" (Printexc.to_string e));
1190
-
IdlM.ErrM.return_err
1191
-
(Toplevel_api_gen.InternalError (Printexc.to_string e))
1289
+
Lwt.return (Error
1290
+
(InternalError (Printexc.to_string e)))
1192
1291
1193
-
(** {3 Environment Management RPCs} *)
1292
+
(** {3 Environment Management} *)
1194
1293
1195
1294
let create_env env_id =
1196
1295
Lwt.catch
···
1200
1299
Lwt.return (Ok ()))
1201
1300
(fun e ->
1202
1301
Lwt.return
1203
-
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1302
+
(Error (InternalError (Printexc.to_string e))))
1204
1303
1205
1304
let destroy_env env_id =
1206
1305
Lwt.catch
···
1210
1309
Lwt.return (Ok ()))
1211
1310
(fun e ->
1212
1311
Lwt.return
1213
-
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1312
+
(Error (InternalError (Printexc.to_string e))))
1214
1313
1215
1314
let list_envs () =
1216
1315
Lwt.catch
···
1220
1319
Lwt.return (Ok envs))
1221
1320
(fun e ->
1222
1321
Lwt.return
1223
-
(Error (Toplevel_api_gen.InternalError (Printexc.to_string e))))
1322
+
(Error (InternalError (Printexc.to_string e))))
1224
1323
end
+29
-30
lib/worker.ml
+29
-30
lib/worker.ml
···
1
-
open Js_top_worker_rpc
2
1
open Js_top_worker
3
2
4
3
(* OCamlorg toplevel in a web worker
···
120
119
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string json)
121
120
122
121
(** Convert exec_result to Message.Output *)
123
-
let output_of_exec_result cell_id (r : Toplevel_api_gen.exec_result) =
124
-
let mime_vals = List.map (fun (mv : Toplevel_api_gen.mime_val) ->
122
+
let output_of_exec_result cell_id (r : Impl.exec_result) =
123
+
let mime_vals = List.map (fun (mv : Impl.mime_val) ->
125
124
{ Msg.mime_type = mv.mime_type; data = mv.data }
126
125
) r.mime_vals in
127
126
Msg.Output {
···
134
133
135
134
(** Convert phrase_output to Message.OutputAt *)
136
135
let output_at_of_phrase cell_id (p : Impl.Make(S).phrase_output) =
137
-
let mime_vals = List.map (fun (mv : Toplevel_api_gen.mime_val) ->
136
+
let mime_vals = List.map (fun (mv : Impl.mime_val) ->
138
137
{ Msg.mime_type = mv.mime_type; data = mv.data }
139
138
) p.mime_vals in
140
139
Msg.OutputAt {
···
145
144
}
146
145
147
146
(** Convert completions to Message.Completions *)
148
-
let completions_of_result cell_id (c : Toplevel_api_gen.completions) =
149
-
let entries = List.map (fun (e : Toplevel_api_gen.query_protocol_compl_entry) ->
147
+
let completions_of_result cell_id (c : Impl.completions) =
148
+
let entries = List.map (fun (e : Impl.query_protocol_compl_entry) ->
150
149
let kind = match e.kind with
151
150
| Constructor -> "Constructor"
152
151
| Keyword -> "Keyword"
···
166
165
}
167
166
168
167
(** Convert location to Message.location *)
169
-
let location_of_loc (loc : Toplevel_api_gen.location) : Msg.location =
168
+
let location_of_loc (loc : Impl.location) : Msg.location =
170
169
{
171
170
loc_start = {
172
171
pos_cnum = loc.loc_start.pos_cnum;
···
182
181
183
182
(** Convert error_kind to string *)
184
183
let string_of_error_kind = function
185
-
| Toplevel_api_gen.Report_error -> "error"
184
+
| Impl.Report_error -> "error"
186
185
| Report_warning s -> "warning:" ^ s
187
186
| Report_warning_as_error s -> "warning_as_error:" ^ s
188
187
| Report_alert s -> "alert:" ^ s
···
190
189
191
190
(** Convert error_source to string *)
192
191
let string_of_error_source = function
193
-
| Toplevel_api_gen.Lexer -> "lexer"
192
+
| Impl.Lexer -> "lexer"
194
193
| Parser -> "parser"
195
194
| Typer -> "typer"
196
195
| Warning -> "warning"
···
199
198
| Config -> "config"
200
199
201
200
(** Convert errors to Message.ErrorList *)
202
-
let errors_of_result cell_id (errors : Toplevel_api_gen.error list) =
203
-
let errors = List.map (fun (e : Toplevel_api_gen.error) ->
201
+
let errors_of_result cell_id (errors : Impl.error list) =
202
+
let errors = List.map (fun (e : Impl.error) ->
204
203
{
205
204
Msg.kind = string_of_error_kind e.kind;
206
205
loc = location_of_loc e.loc;
···
212
211
Msg.ErrorList { cell_id; errors }
213
212
214
213
(** Convert typed_enclosings to Message.Types *)
215
-
let types_of_result cell_id (enclosings : Toplevel_api_gen.typed_enclosings list) =
216
-
let types = List.map (fun ((loc, idx_or_str, tail) : Toplevel_api_gen.typed_enclosings) ->
214
+
let types_of_result cell_id (enclosings : Impl.typed_enclosings list) =
215
+
let types = List.map (fun ((loc, idx_or_str, tail) : Impl.typed_enclosings) ->
217
216
let type_str = match idx_or_str with
218
-
| Toplevel_api_gen.String s -> s
217
+
| Impl.String s -> s
219
218
| Index _ -> ""
220
219
in
221
220
let tail = match tail with
222
-
| Toplevel_api_gen.No -> "no"
221
+
| Impl.No -> "no"
223
222
| Tail_position -> "tail_position"
224
223
| Tail_call -> "tail_call"
225
224
in
···
231
230
) enclosings in
232
231
Msg.Types { cell_id; types }
233
232
234
-
(** Convert position from int to Toplevel_api_gen.msource_position *)
233
+
(** Convert position from int to Impl.msource_position *)
235
234
let position_of_int pos =
236
-
Toplevel_api_gen.Offset pos
235
+
Impl.Offset pos
237
236
238
237
(** Handle a client message *)
239
238
let handle_message msg =
240
239
let open Lwt.Infix in
241
240
match msg with
242
241
| Msg.Init config ->
243
-
let init_config : Toplevel_api_gen.init_config = {
242
+
let init_config : Impl.init_config = {
244
243
findlib_requires = config.findlib_requires;
245
244
stdlib_dcs = config.stdlib_dcs;
246
245
findlib_index = config.findlib_index;
···
253
252
M.setup "" >|= fun setup_result ->
254
253
(match setup_result with
255
254
| Ok _ -> send_message Msg.Ready
256
-
| Error (Toplevel_api_gen.InternalError msg) ->
255
+
| Error (Impl.InternalError msg) ->
257
256
send_message (Msg.InitError { message = msg }))
258
-
| Error (Toplevel_api_gen.InternalError msg) ->
257
+
| Error (Impl.InternalError msg) ->
259
258
send_message (Msg.InitError { message = msg });
260
259
Lwt.return_unit)
261
260
262
261
| Msg.Eval { cell_id; env_id; code } ->
263
262
Jslib.log "Eval cell_id=%d env_id=%s" cell_id env_id;
264
263
let on_phrase_output p = send_message (output_at_of_phrase cell_id p) in
265
-
Rpc_lwt.T.get (M.execute_incremental env_id code ~on_phrase_output) >|= fun result ->
264
+
M.execute_incremental env_id code ~on_phrase_output >|= fun result ->
266
265
(match result with
267
266
| Ok exec_result ->
268
267
send_message (output_of_exec_result cell_id exec_result)
269
-
| Error (Toplevel_api_gen.InternalError msg) ->
268
+
| Error (Impl.InternalError msg) ->
270
269
send_message (Msg.EvalError { cell_id; message = msg }))
271
270
272
271
| Msg.Complete { cell_id; env_id; source; position; filename } ->
273
272
let pos = position_of_int position in
274
-
Rpc_lwt.T.get (M.complete_prefix ?filename env_id None [] false source pos) >|= fun result ->
273
+
M.complete_prefix ?filename env_id None [] false source pos >|= fun result ->
275
274
(match result with
276
275
| Ok completions ->
277
276
send_message (completions_of_result cell_id completions)
278
-
| Error (Toplevel_api_gen.InternalError msg) ->
277
+
| Error (Impl.InternalError msg) ->
279
278
send_message (Msg.EvalError { cell_id; message = msg }))
280
279
281
280
| Msg.TypeAt { cell_id; env_id; source; position; filename } ->
282
281
let pos = position_of_int position in
283
-
Rpc_lwt.T.get (M.type_enclosing ?filename env_id None [] false source pos) >|= fun result ->
282
+
M.type_enclosing ?filename env_id None [] false source pos >|= fun result ->
284
283
(match result with
285
284
| Ok types ->
286
285
send_message (types_of_result cell_id types)
287
-
| Error (Toplevel_api_gen.InternalError msg) ->
286
+
| Error (Impl.InternalError msg) ->
288
287
send_message (Msg.EvalError { cell_id; message = msg }))
289
288
290
289
| Msg.Errors { cell_id; env_id; source; filename } ->
291
-
Rpc_lwt.T.get (M.query_errors ?filename env_id None [] false source) >|= fun result ->
290
+
M.query_errors ?filename env_id None [] false source >|= fun result ->
292
291
(match result with
293
292
| Ok errors ->
294
293
send_message (errors_of_result cell_id errors)
295
-
| Error (Toplevel_api_gen.InternalError msg) ->
294
+
| Error (Impl.InternalError msg) ->
296
295
send_message (Msg.EvalError { cell_id; message = msg }))
297
296
298
297
| Msg.CreateEnv { env_id } ->
299
298
M.create_env env_id >|= fun result ->
300
299
(match result with
301
300
| Ok () -> send_message (Msg.EnvCreated { env_id })
302
-
| Error (Toplevel_api_gen.InternalError msg) ->
301
+
| Error (Impl.InternalError msg) ->
303
302
send_message (Msg.InitError { message = msg }))
304
303
305
304
| Msg.DestroyEnv { env_id } ->
306
305
M.destroy_env env_id >|= fun result ->
307
306
(match result with
308
307
| Ok () -> send_message (Msg.EnvDestroyed { env_id })
309
-
| Error (Toplevel_api_gen.InternalError msg) ->
308
+
| Error (Impl.InternalError msg) ->
310
309
send_message (Msg.InitError { message = msg }))
311
310
312
311
let run () =
+22
-61
test/browser/client_test.ml
+22
-61
test/browser/client_test.ml
···
1
-
(** Browser test for js_top_worker_client library.
1
+
(** Browser test for js_top_worker_client_msg library.
2
2
3
3
This test runs in a browser via Playwright and exercises:
4
4
- Worker spawning
5
-
- RPC communication via postMessage
6
-
- Timeout handling
7
-
- All W module functions *)
5
+
- Message protocol communication via postMessage
6
+
- All client module functions *)
8
7
9
8
open Js_of_ocaml
10
-
open Js_top_worker_rpc
11
-
module W = Js_top_worker_client.W
9
+
module C = Js_top_worker_client_msg
10
+
module Msg = Js_top_worker_message.Message
12
11
13
12
(* Test result tracking *)
14
13
type test_result = { name : string; passed : bool; message : string }
···
40
39
val done_ = Js._true
41
40
end)
42
41
43
-
let test_init_and_setup rpc =
44
-
let ( let* ) = Lwt_result.bind in
45
-
let* () =
46
-
W.init rpc
47
-
Toplevel_api_gen.
48
-
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
42
+
let run_tests worker_url =
43
+
let open Lwt.Infix in
44
+
log (Printf.sprintf "Starting tests with worker: %s" worker_url);
45
+
let t = C.create ~timeout:30000 worker_url in
46
+
47
+
let config : Msg.init_config =
48
+
{ findlib_requires = []; stdlib_dcs = None; findlib_index = None }
49
49
in
50
+
C.init t config >>= fun () ->
50
51
add_result "init" true "Initialized successfully";
51
-
let* _o = W.setup rpc "" in
52
-
add_result "setup" true "Setup completed";
53
-
Lwt.return (Ok ())
54
52
55
-
let test_exec rpc =
56
-
let ( let* ) = Lwt_result.bind in
57
-
let* o = W.exec rpc "" "let x = 1 + 2;;" in
58
-
let has_output =
59
-
match o.caml_ppf with Some s -> String.length s > 0 | None -> false
60
-
in
53
+
C.eval t ~env_id:"default" "let _ = 1 + 2;;" >>= fun o ->
54
+
let has_output = String.length o.caml_ppf > 0 in
61
55
add_result "exec" has_output
62
-
(Printf.sprintf "caml_ppf=%s"
63
-
(Option.value ~default:"(none)" o.caml_ppf));
64
-
Lwt.return (Ok ())
56
+
(Printf.sprintf "caml_ppf=%s" o.caml_ppf);
65
57
66
-
let test_exec_with_output rpc =
67
-
let ( let* ) = Lwt_result.bind in
68
-
let* o = W.exec rpc "" "print_endline \"hello from test\";;" in
69
-
let has_stdout =
70
-
match o.stdout with
71
-
| Some s -> Astring.String.is_prefix ~affix:"hello" s
72
-
| None -> false
73
-
in
58
+
C.eval t ~env_id:"default" "print_endline \"hello from test\";;" >>= fun o ->
59
+
let has_stdout = Astring.String.is_prefix ~affix:"hello" o.stdout in
74
60
add_result "exec_stdout" has_stdout
75
-
(Printf.sprintf "stdout=%s" (Option.value ~default:"(none)" o.stdout));
76
-
Lwt.return (Ok ())
61
+
(Printf.sprintf "stdout=%s" o.stdout);
77
62
78
-
let test_query_errors rpc =
79
-
let ( let* ) = Lwt_result.bind in
80
-
(* Test that query_errors RPC call works - result depends on context *)
81
-
let* _errors = W.query_errors rpc "" (Some "test1") [] false "let x : int = \"foo\";;" in
82
-
(* Success = the RPC call completed without error *)
83
-
add_result "query_errors" true "query_errors RPC call succeeded";
84
-
Lwt.return (Ok ())
63
+
C.errors t ~env_id:"default" "let x : int = \"foo\";;" >>= fun _errors ->
64
+
add_result "query_errors" true "query_errors call succeeded";
85
65
86
-
let run_tests worker_url =
87
-
let ( let* ) = Lwt.bind in
88
-
log (Printf.sprintf "Starting tests with worker: %s" worker_url);
89
-
let rpc =
90
-
Js_top_worker_client.start worker_url 30000 (fun () ->
91
-
add_result "timeout" false "Unexpected timeout")
92
-
in
93
-
let test_sequence =
94
-
let ( let* ) = Lwt_result.bind in
95
-
let* () = test_init_and_setup rpc in
96
-
let* () = test_exec rpc in
97
-
let* () = test_exec_with_output rpc in
98
-
let* () = test_query_errors rpc in
99
-
Lwt.return (Ok ())
100
-
in
101
-
let* result = test_sequence in
102
-
(match result with
103
-
| Ok () -> add_result "all_tests" true "All tests completed"
104
-
| Error (Toplevel_api_gen.InternalError msg) ->
105
-
add_result "all_tests" false (Printf.sprintf "Error: %s" msg));
66
+
add_result "all_tests" true "All tests completed";
106
67
report_results ();
107
68
Lwt.return ()
108
69
+2
-2
test/browser/dune
+2
-2
test/browser/dune
···
6
6
(modes js)
7
7
(modules client_test)
8
8
(preprocess (pps js_of_ocaml-ppx))
9
-
(libraries js_top_worker-client js_top_worker-rpc astring lwt js_of_ocaml))
9
+
(libraries js_top_worker-client.msg astring lwt js_of_ocaml))
10
10
11
11
(executable
12
12
(name test_worker)
···
17
17
(js_of_ocaml
18
18
(javascript_files ../../lib/stubs.js)
19
19
(flags --effects=disabled --toplevel +toplevel.js +dynlink.js))
20
-
(libraries js_top_worker js_top_worker-rpc js_of_ocaml js_of_ocaml-toplevel lwt))
20
+
(libraries js_top_worker js_top_worker-web js_top_worker-rpc.message js_of_ocaml js_of_ocaml-toplevel lwt))
21
21
22
22
; Browser test alias - runs Playwright
23
23
; Requires: cd test/browser && npm install (once)
+105
-25
test/browser/test_worker.ml
+105
-25
test/browser/test_worker.ml
···
1
1
(** Minimal test worker for browser client tests.
2
2
3
3
This is a simplified worker that doesn't require dynamic package loading,
4
-
making it suitable for isolated browser testing. *)
4
+
making it suitable for isolated browser testing.
5
+
6
+
Uses the message protocol defined in {!Js_top_worker_message.Message}. *)
5
7
6
-
open Js_top_worker_rpc
7
8
open Js_top_worker
8
-
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
9
9
10
-
let server process e =
11
-
let _, id, call = Jsonrpc.version_id_and_call_of_string e in
12
-
Lwt.bind (process call) (fun response ->
13
-
let rtxt = Jsonrpc.string_of_response ~id response in
14
-
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string rtxt);
15
-
Lwt.return ())
10
+
module Msg = Js_top_worker_message.Message
16
11
17
12
module S : Impl.S = struct
18
13
type findlib_t = unit
···
40
35
41
36
module M = Impl.Make (S)
42
37
38
+
(** Send a message back to the client *)
39
+
let send_message msg =
40
+
let json = Msg.string_of_worker_msg msg in
41
+
Js_of_ocaml.Worker.post_message (Js_of_ocaml.Js.string json)
42
+
43
+
(** Convert exec_result to Message.Output *)
44
+
let output_of_exec_result cell_id (r : Impl.exec_result) =
45
+
let mime_vals = List.map (fun (mv : Impl.mime_val) ->
46
+
{ Msg.mime_type = mv.mime_type; data = mv.data }
47
+
) r.mime_vals in
48
+
Msg.Output {
49
+
cell_id;
50
+
stdout = Option.value ~default:"" r.stdout;
51
+
stderr = Option.value ~default:"" r.stderr;
52
+
caml_ppf = Option.value ~default:"" r.caml_ppf;
53
+
mime_vals;
54
+
}
55
+
56
+
(** Handle a client message *)
57
+
let handle_message msg =
58
+
let open Lwt.Infix in
59
+
match msg with
60
+
| Msg.Init config ->
61
+
let init_config : Impl.init_config = {
62
+
findlib_requires = config.findlib_requires;
63
+
stdlib_dcs = config.stdlib_dcs;
64
+
findlib_index = config.findlib_index;
65
+
execute = true;
66
+
} in
67
+
M.init init_config >>= fun result ->
68
+
(match result with
69
+
| Ok () ->
70
+
M.setup "" >|= fun setup_result ->
71
+
(match setup_result with
72
+
| Ok _ -> send_message Msg.Ready
73
+
| Error (Impl.InternalError msg) ->
74
+
send_message (Msg.InitError { message = msg }))
75
+
| Error (Impl.InternalError msg) ->
76
+
send_message (Msg.InitError { message = msg });
77
+
Lwt.return_unit)
78
+
79
+
| Msg.Eval { cell_id; env_id; code } ->
80
+
M.execute env_id code >|= fun result ->
81
+
(match result with
82
+
| Ok exec_result ->
83
+
send_message (output_of_exec_result cell_id exec_result)
84
+
| Error (Impl.InternalError msg) ->
85
+
send_message (Msg.EvalError { cell_id; message = msg }))
86
+
87
+
| Msg.Errors { cell_id; env_id; source; filename } ->
88
+
M.query_errors ?filename env_id None [] false source >|= fun result ->
89
+
(match result with
90
+
| Ok errors ->
91
+
let errors = List.map (fun (e : Impl.error) ->
92
+
{
93
+
Msg.kind = "error";
94
+
loc = {
95
+
loc_start = { pos_cnum = e.loc.loc_start.pos_cnum;
96
+
pos_lnum = e.loc.loc_start.pos_lnum;
97
+
pos_bol = e.loc.loc_start.pos_bol };
98
+
loc_end = { pos_cnum = e.loc.loc_end.pos_cnum;
99
+
pos_lnum = e.loc.loc_end.pos_lnum;
100
+
pos_bol = e.loc.loc_end.pos_bol };
101
+
};
102
+
main = e.main;
103
+
sub = e.sub;
104
+
source = "unknown";
105
+
}
106
+
) errors in
107
+
send_message (Msg.ErrorList { cell_id; errors })
108
+
| Error (Impl.InternalError msg) ->
109
+
send_message (Msg.EvalError { cell_id; message = msg }))
110
+
111
+
| Msg.CreateEnv { env_id } ->
112
+
M.create_env env_id >|= fun result ->
113
+
(match result with
114
+
| Ok () -> send_message (Msg.EnvCreated { env_id })
115
+
| Error (Impl.InternalError msg) ->
116
+
send_message (Msg.InitError { message = msg }))
117
+
118
+
| Msg.DestroyEnv { env_id } ->
119
+
M.destroy_env env_id >|= fun result ->
120
+
(match result with
121
+
| Ok () -> send_message (Msg.EnvDestroyed { env_id })
122
+
| Error (Impl.InternalError msg) ->
123
+
send_message (Msg.InitError { message = msg }))
124
+
125
+
| _ ->
126
+
send_message (Msg.EvalError { cell_id = 0; message = "Unsupported message" });
127
+
Lwt.return_unit
128
+
43
129
let run () =
44
130
let open Js_of_ocaml in
45
-
let open M in
46
-
Console.console##log (Js.string "Test worker starting...");
47
-
Server.init (Impl.IdlM.T.lift init);
48
-
Server.create_env (Impl.IdlM.T.lift create_env);
49
-
Server.destroy_env (Impl.IdlM.T.lift destroy_env);
50
-
Server.list_envs (Impl.IdlM.T.lift list_envs);
51
-
Server.setup (Impl.IdlM.T.lift setup);
52
-
Server.exec execute;
53
-
Server.complete_prefix complete_prefix;
54
-
Server.query_errors query_errors;
55
-
Server.type_enclosing type_enclosing;
56
-
Server.exec_toplevel exec_toplevel;
57
-
let rpc_fn = Impl.IdlM.server Server.implementation in
58
-
Worker.set_onmessage (fun x ->
59
-
let s = Js.to_string x in
60
-
ignore (server rpc_fn s));
131
+
Console.console##log (Js.string "Test worker starting (message protocol)...");
132
+
133
+
Js_of_ocaml.Worker.set_onmessage (fun x ->
134
+
let s = Js_of_ocaml.Js.to_string x in
135
+
try
136
+
let msg = Msg.client_msg_of_string s in
137
+
Lwt.async (fun () -> handle_message msg)
138
+
with e ->
139
+
send_message (Msg.InitError { message = Printexc.to_string e }));
140
+
61
141
Console.console##log (Js.string "Test worker ready")
62
142
63
143
let () = run ()
-14
test/node/dune
-14
test/node/dune
···
11
11
js_top_worker
12
12
logs
13
13
logs.fmt
14
-
rpclib.core
15
-
rpclib.json
16
14
findlib.top
17
15
js_of_ocaml-lwt
18
16
zarith_stubs_js))
···
76
74
js_top_worker
77
75
logs
78
76
logs.fmt
79
-
rpclib.core
80
-
rpclib.json
81
77
findlib.top
82
78
js_of_ocaml-lwt
83
79
zarith_stubs_js))
···
136
132
js_top_worker
137
133
logs
138
134
logs.fmt
139
-
rpclib.core
140
-
rpclib.json
141
135
findlib.top
142
136
js_of_ocaml-lwt
143
137
zarith_stubs_js))
···
195
189
js_top_worker
196
190
logs
197
191
logs.fmt
198
-
rpclib.core
199
-
rpclib.json
200
192
findlib.top
201
193
js_of_ocaml-lwt
202
194
zarith_stubs_js))
···
254
246
js_top_worker
255
247
logs
256
248
logs.fmt
257
-
rpclib.core
258
-
rpclib.json
259
249
findlib.top
260
250
js_of_ocaml-lwt
261
251
zarith_stubs_js))
···
313
303
js_top_worker
314
304
logs
315
305
logs.fmt
316
-
rpclib.core
317
-
rpclib.json
318
306
findlib.top
319
307
js_of_ocaml-lwt
320
308
zarith_stubs_js))
···
372
360
js_top_worker
373
361
logs
374
362
logs.fmt
375
-
rpclib.core
376
-
rpclib.json
377
363
findlib.top
378
364
js_of_ocaml-lwt
379
365
zarith_stubs_js))
+2
-2
test/node/node_dependency_test.expected
+2
-2
test/node/node_dependency_test.expected
···
161
161
162
162
--- Section 3: Missing Dependencies ---
163
163
[PASS] missing_dep_error: 2 errors (expected > 0)
164
-
node_dependency_test.js: [ERROR] Env.Error: File "_none_", line 1:
165
-
Error: Unbound module Cell__nonexistent
164
+
node_dependency_test.js: [ERROR] Env.Error: Line 1:
165
+
Error: Unbound module "Cell__nonexistent"
166
166
167
167
[PASS] missing_dep_simple_ok: 0 errors
168
168
+40
-54
test/node/node_dependency_test.ml
+40
-54
test/node/node_dependency_test.ml
···
9
9
*)
10
10
11
11
open Js_top_worker
12
-
open Js_top_worker_rpc.Toplevel_api_gen
13
12
open Impl
14
13
15
14
(* Flusher that writes to process.stdout in Node.js *)
···
34
33
in
35
34
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
36
35
(captured, x)
37
-
38
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
39
36
40
37
module S : Impl.S = struct
41
38
type findlib_t = Js_top_worker_web.Findlibish.t
···
87
84
88
85
module U = Impl.Make (S)
89
86
90
-
let start_server () =
91
-
let open U in
92
-
Logs.set_reporter (Logs_fmt.reporter ());
93
-
Logs.set_level (Some Logs.Warning);
94
-
Server.init (IdlM.T.lift init);
95
-
Server.create_env (IdlM.T.lift create_env);
96
-
Server.destroy_env (IdlM.T.lift destroy_env);
97
-
Server.list_envs (IdlM.T.lift list_envs);
98
-
Server.setup (IdlM.T.lift setup);
99
-
Server.exec execute;
100
-
Server.complete_prefix complete_prefix;
101
-
Server.query_errors query_errors;
102
-
Server.type_enclosing type_enclosing;
103
-
Server.exec_toplevel exec_toplevel;
104
-
IdlM.server Server.implementation
105
-
106
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
107
-
108
87
(* Test result tracking *)
109
88
let total_tests = ref 0
110
89
let passed_tests = ref 0
···
116
95
let status = if passed then "PASS" else "FAIL" in
117
96
Printf.printf "[%s] %s: %s\n%!" status name message
118
97
119
-
let query_errors rpc env_id cell_id deps source =
120
-
Client.query_errors rpc env_id cell_id deps false source
98
+
let query_errors env_id cell_id deps source =
99
+
U.query_errors env_id cell_id deps false source
121
100
122
101
let _ =
123
102
Printf.printf "=== Node.js Cell Dependency Tests ===\n\n%!";
124
103
125
-
let rpc = start_server () in
126
-
let ( let* ) = IdlM.ErrM.bind in
104
+
Logs.set_reporter (Logs_fmt.reporter ());
105
+
Logs.set_level (Some Logs.Warning);
106
+
107
+
let ( let* ) m f =
108
+
let open Lwt in
109
+
m >>= function
110
+
| Ok x -> f x
111
+
| Error e -> return (Error e)
112
+
in
127
113
128
114
let init_config =
129
115
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
···
131
117
132
118
let test_sequence =
133
119
(* Initialize and setup *)
134
-
let* _ = Client.init rpc init_config in
135
-
let* _ = Client.setup rpc "" in
120
+
let* _ = U.init init_config in
121
+
let* _ = U.setup "" in
136
122
test "init" true "Initialized and setup";
137
123
138
124
Printf.printf "\n--- Section 1: Linear Dependencies ---\n%!";
139
125
140
126
(* c1: base definition *)
141
-
let* errors = query_errors rpc "" (Some "c1") [] "type t = int;;" in
127
+
let* errors = query_errors "" (Some "c1") [] "type t = int;;" in
142
128
test "linear_c1" (List.length errors = 0)
143
129
(Printf.sprintf "%d errors" (List.length errors));
144
130
145
131
(* c2 depends on c1 *)
146
-
let* errors = query_errors rpc "" (Some "c2") ["c1"] "let x : t = 42;;" in
132
+
let* errors = query_errors "" (Some "c2") ["c1"] "let x : t = 42;;" in
147
133
test "linear_c2" (List.length errors = 0)
148
134
(Printf.sprintf "%d errors" (List.length errors));
149
135
150
136
(* c3 depends on c2 (and transitively c1) *)
151
-
let* errors = query_errors rpc "" (Some "c3") ["c2"] "let y = x + 1;;" in
137
+
let* errors = query_errors "" (Some "c3") ["c2"] "let y = x + 1;;" in
152
138
test "linear_c3" (List.length errors = 0)
153
139
(Printf.sprintf "%d errors" (List.length errors));
154
140
155
141
(* c4 depends on c3 *)
156
-
let* errors = query_errors rpc "" (Some "c4") ["c3"] "let z = y * 2;;" in
142
+
let* errors = query_errors "" (Some "c4") ["c3"] "let z = y * 2;;" in
157
143
test "linear_c4" (List.length errors = 0)
158
144
(Printf.sprintf "%d errors" (List.length errors));
159
145
160
146
Printf.printf "\n--- Section 2: Diamond Dependencies ---\n%!";
161
147
162
148
(* d1: base type *)
163
-
let* errors = query_errors rpc "" (Some "d1") []
149
+
let* errors = query_errors "" (Some "d1") []
164
150
"type point = { x: int; y: int };;" in
165
151
test "diamond_d1" (List.length errors = 0)
166
152
(Printf.sprintf "%d errors" (List.length errors));
167
153
168
154
(* d2 depends on d1 *)
169
-
let* errors = query_errors rpc "" (Some "d2") ["d1"]
155
+
let* errors = query_errors "" (Some "d2") ["d1"]
170
156
"let origin : point = { x = 0; y = 0 };;" in
171
157
test "diamond_d2" (List.length errors = 0)
172
158
(Printf.sprintf "%d errors" (List.length errors));
173
159
174
160
(* d3 depends on d1 (parallel to d2) *)
175
-
let* errors = query_errors rpc "" (Some "d3") ["d1"]
161
+
let* errors = query_errors "" (Some "d3") ["d1"]
176
162
"let unit_x : point = { x = 1; y = 0 };;" in
177
163
test "diamond_d3" (List.length errors = 0)
178
164
(Printf.sprintf "%d errors" (List.length errors));
179
165
180
166
(* d4 depends on d2, d3, and transitively needs d1 for the point type *)
181
-
let* errors = query_errors rpc "" (Some "d4") ["d1"; "d2"; "d3"]
167
+
let* errors = query_errors "" (Some "d4") ["d1"; "d2"; "d3"]
182
168
"let add p1 p2 : point = { x = p1.x + p2.x; y = p1.y + p2.y };;\n\
183
169
let result = add origin unit_x;;" in
184
170
test "diamond_d4" (List.length errors = 0)
···
187
173
Printf.printf "\n--- Section 3: Missing Dependencies ---\n%!";
188
174
189
175
(* Try to use a type from a cell that doesn't exist in deps *)
190
-
let* errors = query_errors rpc "" (Some "m1") []
176
+
let* errors = query_errors "" (Some "m1") []
191
177
"let bad : point = { x = 1; y = 2 };;" in
192
178
test "missing_dep_error" (List.length errors > 0)
193
179
(Printf.sprintf "%d errors (expected > 0)" (List.length errors));
194
180
195
181
(* Reference with missing dependency - should fail *)
196
-
let* errors = query_errors rpc "" (Some "m2") ["nonexistent"]
182
+
let* errors = query_errors "" (Some "m2") ["nonexistent"]
197
183
"let a = 1;;" in
198
184
(* Even with a missing dep in the list, simple code should work *)
199
185
test "missing_dep_simple_ok" (List.length errors = 0)
···
202
188
Printf.printf "\n--- Section 4: Dependency Update Propagation ---\n%!";
203
189
204
190
(* u1: initial type *)
205
-
let* errors = query_errors rpc "" (Some "u1") [] "type u = int;;" in
191
+
let* errors = query_errors "" (Some "u1") [] "type u = int;;" in
206
192
test "update_u1_initial" (List.length errors = 0)
207
193
(Printf.sprintf "%d errors" (List.length errors));
208
194
209
195
(* u2: depends on u1, uses type u as int *)
210
-
let* errors = query_errors rpc "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
196
+
let* errors = query_errors "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
211
197
test "update_u2_initial" (List.length errors = 0)
212
198
(Printf.sprintf "%d errors" (List.length errors));
213
199
214
200
(* Now update u1 to change type u to string *)
215
-
let* errors = query_errors rpc "" (Some "u1") [] "type u = string;;" in
201
+
let* errors = query_errors "" (Some "u1") [] "type u = string;;" in
216
202
test "update_u1_changed" (List.length errors = 0)
217
203
(Printf.sprintf "%d errors" (List.length errors));
218
204
219
205
(* u2 with same code should now error (42 is not string) *)
220
-
let* errors = query_errors rpc "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
206
+
let* errors = query_errors "" (Some "u2") ["u1"] "let val_u : u = 42;;" in
221
207
test "update_u2_error" (List.length errors > 0)
222
208
(Printf.sprintf "%d errors (expected > 0)" (List.length errors));
223
209
224
210
(* Fix u2 to work with string type *)
225
-
let* errors = query_errors rpc "" (Some "u2") ["u1"]
211
+
let* errors = query_errors "" (Some "u2") ["u1"]
226
212
"let val_u : u = \"hello\";;" in
227
213
test "update_u2_fixed" (List.length errors = 0)
228
214
(Printf.sprintf "%d errors" (List.length errors));
···
230
216
Printf.printf "\n--- Section 5: Type Shadowing ---\n%!";
231
217
232
218
(* s1: defines type t = int *)
233
-
let* errors = query_errors rpc "" (Some "s1") [] "type t = int;;" in
219
+
let* errors = query_errors "" (Some "s1") [] "type t = int;;" in
234
220
test "shadow_s1" (List.length errors = 0)
235
221
(Printf.sprintf "%d errors" (List.length errors));
236
222
237
223
(* s2: depends on s1, also defines type t = string (shadows) *)
238
-
let* errors = query_errors rpc "" (Some "s2") ["s1"]
224
+
let* errors = query_errors "" (Some "s2") ["s1"]
239
225
"type t = string;;" in
240
226
test "shadow_s2" (List.length errors = 0)
241
227
(Printf.sprintf "%d errors" (List.length errors));
242
228
243
229
(* s3: depends on s2 - should see t as string, not int *)
244
-
let* errors = query_errors rpc "" (Some "s3") ["s2"]
230
+
let* errors = query_errors "" (Some "s3") ["s2"]
245
231
"let shadowed : t = \"works\";;" in
246
232
test "shadow_s3_string" (List.length errors = 0)
247
233
(Printf.sprintf "%d errors" (List.length errors));
248
234
249
235
(* s4: depends only on s1 - should see t as int *)
250
-
let* errors = query_errors rpc "" (Some "s4") ["s1"]
236
+
let* errors = query_errors "" (Some "s4") ["s1"]
251
237
"let original : t = 123;;" in
252
238
test "shadow_s4_int" (List.length errors = 0)
253
239
(Printf.sprintf "%d errors" (List.length errors));
···
264
250
g4 depends on g2 and g3
265
251
*)
266
252
267
-
let* errors = query_errors rpc "" (Some "g1") []
253
+
let* errors = query_errors "" (Some "g1") []
268
254
"module Base = struct\n\
269
255
\ type id = int\n\
270
256
\ let make_id x = x\n\
···
272
258
test "graph_g1" (List.length errors = 0)
273
259
(Printf.sprintf "%d errors" (List.length errors));
274
260
275
-
let* errors = query_errors rpc "" (Some "g2") ["g1"]
261
+
let* errors = query_errors "" (Some "g2") ["g1"]
276
262
"module User = struct\n\
277
263
\ type t = { id: Base.id; name: string }\n\
278
264
\ let create id name = { id; name }\n\
···
280
266
test "graph_g2" (List.length errors = 0)
281
267
(Printf.sprintf "%d errors" (List.length errors));
282
268
283
-
let* errors = query_errors rpc "" (Some "g3") ["g1"]
269
+
let* errors = query_errors "" (Some "g3") ["g1"]
284
270
"module Item = struct\n\
285
271
\ type t = { id: Base.id; value: int }\n\
286
272
\ let create id value = { id; value }\n\
···
289
275
(Printf.sprintf "%d errors" (List.length errors));
290
276
291
277
(* g4 needs g1 for Base module, plus g2 and g3 *)
292
-
let* errors = query_errors rpc "" (Some "g4") ["g1"; "g2"; "g3"]
278
+
let* errors = query_errors "" (Some "g4") ["g1"; "g2"; "g3"]
293
279
"let user = User.create (Base.make_id 1) \"Alice\";;\n\
294
280
let item = Item.create (Base.make_id 100) 42;;" in
295
281
test "graph_g4" (List.length errors = 0)
···
298
284
Printf.printf "\n--- Section 7: Empty and Self Dependencies ---\n%!";
299
285
300
286
(* Cell with no deps *)
301
-
let* errors = query_errors rpc "" (Some "e1") []
287
+
let* errors = query_errors "" (Some "e1") []
302
288
"let standalone = 999;;" in
303
289
test "empty_deps" (List.length errors = 0)
304
290
(Printf.sprintf "%d errors" (List.length errors));
305
291
306
292
(* Cell that tries to reference itself should fail or have errors *)
307
-
let* errors = query_errors rpc "" (Some "self") []
293
+
let* errors = query_errors "" (Some "self") []
308
294
"let self_ref = 1;;" in
309
295
test "self_define" (List.length errors = 0)
310
296
(Printf.sprintf "%d errors" (List.length errors));
311
297
312
-
IdlM.ErrM.return ()
298
+
Lwt.return (Ok ())
313
299
in
314
300
315
-
let promise = test_sequence |> IdlM.T.get in
301
+
let promise = test_sequence in
316
302
(match Lwt.state promise with
317
303
| Lwt.Return (Ok ()) -> ()
318
304
| Lwt.Return (Error (InternalError s)) ->
+4
-5
test/node/node_directive_test.expected
+4
-5
test/node/node_directive_test.expected
···
145
145
Reading library: base.shadow_stdlib
146
146
Number of children: 0
147
147
node_directive_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
-
node_directive_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
148
+
node_directive_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
149
149
node_directive_test.js: [INFO] init() finished
150
150
node_directive_test.js: [INFO] setup() for env default...
151
151
node_directive_test.js: [INFO] Fetching stdlib__Format.cmi
···
186
186
val compare_length_with : 'a list -> int -> int
187
187
val is_empty : 'a list -> bool
188
188
val cons : 'a -> 'a list -> 'a list
189
-
val singleton : 'a -> 'a list
190
189
val hd : 'a list -> 'a
191
190
val tl : 'a list -> 'a list
192
191
val nth : 'a list -> int -> 'a
···
290
289
--- Section 6: #rectypes ---
291
290
292
291
Line 1, characters 0-23:
293
-
Error: The type abbreviation t is cyclic:
294
-
'a t = 'a t -> int,
295
-
'a t -> int contains 'a t
292
+
Error: The type abbreviation "t" is cyclic:
293
+
"'a t" = "'a t -> int",
294
+
"'a t -> int" contains "'a t"
296
295
[FAIL] rectypes_before: # type 'a t = 'a t -> int;;
297
296
[PASS] rectypes_after: # type 'a u = 'a u -> int;;
298
297
type 'a u = 'a u -> int
+67
-82
test/node/node_directive_test.ml
+67
-82
test/node/node_directive_test.ml
···
22
22
*)
23
23
24
24
open Js_top_worker
25
-
open Js_top_worker_rpc.Toplevel_api_gen
26
25
open Impl
27
26
28
27
(* Flusher that writes to process.stdout in Node.js *)
···
49
48
(* Restore flusher that writes to console so Printf.printf works for test output *)
50
49
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
51
50
(captured, x)
52
-
53
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
54
51
55
52
module S : Impl.S = struct
56
53
type findlib_t = Js_top_worker_web.Findlibish.t
···
102
99
103
100
module U = Impl.Make (S)
104
101
105
-
let start_server () =
106
-
let open U in
107
-
Logs.set_reporter (Logs_fmt.reporter ());
108
-
Logs.set_level (Some Logs.Info);
109
-
Server.init (IdlM.T.lift init);
110
-
Server.create_env (IdlM.T.lift create_env);
111
-
Server.destroy_env (IdlM.T.lift destroy_env);
112
-
Server.list_envs (IdlM.T.lift list_envs);
113
-
Server.setup (IdlM.T.lift setup);
114
-
Server.exec execute;
115
-
Server.complete_prefix complete_prefix;
116
-
Server.query_errors query_errors;
117
-
Server.type_enclosing type_enclosing;
118
-
Server.exec_toplevel exec_toplevel;
119
-
IdlM.server Server.implementation
120
-
121
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
122
-
123
102
(* Test result tracking *)
124
103
let total_tests = ref 0
125
104
let passed_tests = ref 0
···
137
116
true
138
117
with Not_found -> false
139
118
140
-
let run_directive rpc code =
141
-
let ( let* ) = IdlM.ErrM.bind in
142
-
let* result = Client.exec_toplevel rpc "" ("# " ^ code) in
143
-
IdlM.ErrM.return result.script
119
+
let run_directive code =
120
+
let open Lwt in
121
+
U.exec_toplevel "" ("# " ^ code) >|= Result.map (fun r -> r.script)
144
122
145
123
let _ =
146
124
Printf.printf "=== Node.js Directive Tests ===\n\n%!";
147
125
148
-
let rpc = start_server () in
149
-
let ( let* ) = IdlM.ErrM.bind in
126
+
Logs.set_reporter (Logs_fmt.reporter ());
127
+
Logs.set_level (Some Logs.Info);
128
+
129
+
let ( let* ) m f =
130
+
let open Lwt in
131
+
m >>= function
132
+
| Ok x -> f x
133
+
| Error e -> return (Error e)
134
+
in
150
135
151
136
let init_config =
152
137
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
···
154
139
155
140
let test_sequence =
156
141
(* Initialize *)
157
-
let* _ = Client.init rpc init_config in
158
-
let* _ = Client.setup rpc "" in
142
+
let* _ = U.init init_config in
143
+
let* _ = U.setup "" in
159
144
160
145
Printf.printf "--- Section 1: Basic Execution ---\n%!";
161
146
162
-
let* r = run_directive rpc "1 + 2;;" in
147
+
let* r = run_directive "1 + 2;;" in
163
148
test "basic_eval" (contains r "- : int = 3") r;
164
149
165
-
let* r = run_directive rpc "let x = 42;;" in
150
+
let* r = run_directive "let x = 42;;" in
166
151
test "let_binding" (contains r "val x : int = 42") r;
167
152
168
153
Printf.printf "\n--- Section 2: #show Directives ---\n%!";
169
154
170
155
(* Define types/values to query *)
171
-
let* _ = run_directive rpc "type point = { x: float; y: float };;" in
172
-
let* _ = run_directive rpc "let origin = { x = 0.0; y = 0.0 };;" in
156
+
let* _ = run_directive "type point = { x: float; y: float };;" in
157
+
let* _ = run_directive "let origin = { x = 0.0; y = 0.0 };;" in
173
158
let* _ =
174
-
run_directive rpc
159
+
run_directive
175
160
"module MyMod = struct type t = int let zero = 0 end;;"
176
161
in
177
-
let* _ = run_directive rpc "exception My_error of string;;" in
162
+
let* _ = run_directive "exception My_error of string;;" in
178
163
179
-
let* r = run_directive rpc "#show point;;" in
164
+
let* r = run_directive "#show point;;" in
180
165
test "show_type_point" (contains r "type point") r;
181
166
182
-
let* r = run_directive rpc "#show origin;;" in
167
+
let* r = run_directive "#show origin;;" in
183
168
test "show_val_origin" (contains r "val origin") r;
184
169
185
-
let* r = run_directive rpc "#show MyMod;;" in
170
+
let* r = run_directive "#show MyMod;;" in
186
171
test "show_module" (contains r "module MyMod") r;
187
172
188
-
let* r = run_directive rpc "#show My_error;;" in
173
+
let* r = run_directive "#show My_error;;" in
189
174
test "show_exception" (contains r "exception My_error") r;
190
175
191
-
let* r = run_directive rpc "#show_type list;;" in
176
+
let* r = run_directive "#show_type list;;" in
192
177
test "show_type_list" (contains r "type 'a list") r;
193
178
194
-
let* r = run_directive rpc "#show_val List.map;;" in
179
+
let* r = run_directive "#show_val List.map;;" in
195
180
test "show_val_list_map" (contains r "val map") r;
196
181
197
-
let* r = run_directive rpc "#show_module List;;" in
182
+
let* r = run_directive "#show_module List;;" in
198
183
test "show_module_list" (contains r "module List") r;
199
184
200
-
let* r = run_directive rpc "#show_exception Not_found;;" in
185
+
let* r = run_directive "#show_exception Not_found;;" in
201
186
test "show_exception_not_found" (contains r "exception Not_found") r;
202
187
203
188
Printf.printf "\n--- Section 3: #print_depth and #print_length ---\n%!";
204
189
205
-
let* _ = run_directive rpc "let nested = [[[[1;2;3]]]];;" in
206
-
let* _ = run_directive rpc "#print_depth 2;;" in
207
-
let* r = run_directive rpc "nested;;" in
190
+
let* _ = run_directive "let nested = [[[[1;2;3]]]];;" in
191
+
let* _ = run_directive "#print_depth 2;;" in
192
+
let* r = run_directive "nested;;" in
208
193
test "print_depth_truncated" (contains r "...") r;
209
194
210
-
let* _ = run_directive rpc "#print_depth 100;;" in
211
-
let* r = run_directive rpc "nested;;" in
195
+
let* _ = run_directive "#print_depth 100;;" in
196
+
let* r = run_directive "nested;;" in
212
197
test "print_depth_full" (contains r "1; 2; 3") r;
213
198
214
-
let* _ = run_directive rpc "let long_list = [1;2;3;4;5;6;7;8;9;10];;" in
215
-
let* _ = run_directive rpc "#print_length 3;;" in
216
-
let* r = run_directive rpc "long_list;;" in
199
+
let* _ = run_directive "let long_list = [1;2;3;4;5;6;7;8;9;10];;" in
200
+
let* _ = run_directive "#print_length 3;;" in
201
+
let* r = run_directive "long_list;;" in
217
202
test "print_length_truncated" (contains r "...") r;
218
203
219
-
let* _ = run_directive rpc "#print_length 100;;" in
220
-
let* r = run_directive rpc "long_list;;" in
204
+
let* _ = run_directive "#print_length 100;;" in
205
+
let* r = run_directive "long_list;;" in
221
206
test "print_length_full" (contains r "10") r;
222
207
223
208
Printf.printf "\n--- Section 4: #install_printer / #remove_printer ---\n%!";
224
209
225
-
let* _ = run_directive rpc "type color = Red | Green | Blue;;" in
210
+
let* _ = run_directive "type color = Red | Green | Blue;;" in
226
211
let* _ =
227
-
run_directive rpc
212
+
run_directive
228
213
{|let pp_color fmt c = Format.fprintf fmt "<color:%s>" (match c with Red -> "red" | Green -> "green" | Blue -> "blue");;|}
229
214
in
230
-
let* _ = run_directive rpc "#install_printer pp_color;;" in
231
-
let* r = run_directive rpc "Red;;" in
215
+
let* _ = run_directive "#install_printer pp_color;;" in
216
+
let* r = run_directive "Red;;" in
232
217
test "install_printer" (contains r "<color:red>") r;
233
218
234
-
let* _ = run_directive rpc "#remove_printer pp_color;;" in
235
-
let* r = run_directive rpc "Red;;" in
219
+
let* _ = run_directive "#remove_printer pp_color;;" in
220
+
let* r = run_directive "Red;;" in
236
221
test "remove_printer" (contains r "Red" && not (contains r "<color:red>")) r;
237
222
238
223
Printf.printf "\n--- Section 5: #warnings / #warn_error ---\n%!";
239
224
240
-
let* _ = run_directive rpc "#warnings \"-26\";;" in
241
-
let* r = run_directive rpc "let _ = let unused = 1 in 2;;" in
225
+
let* _ = run_directive "#warnings \"-26\";;" in
226
+
let* r = run_directive "let _ = let unused = 1 in 2;;" in
242
227
test "warnings_disabled"
243
228
(not (contains r "Warning") || contains r "- : int = 2")
244
229
r;
245
230
246
-
let* _ = run_directive rpc "#warnings \"+26\";;" in
247
-
let* r = run_directive rpc "let _ = let unused2 = 1 in 2;;" in
231
+
let* _ = run_directive "#warnings \"+26\";;" in
232
+
let* r = run_directive "let _ = let unused2 = 1 in 2;;" in
248
233
test "warnings_enabled" (contains r "Warning" || contains r "unused2") r;
249
234
250
-
let* _ = run_directive rpc "#warn_error \"+26\";;" in
251
-
let* r = run_directive rpc "let _ = let unused3 = 1 in 2;;" in
235
+
let* _ = run_directive "#warn_error \"+26\";;" in
236
+
let* r = run_directive "let _ = let unused3 = 1 in 2;;" in
252
237
test "warn_error" (contains r "Error") r;
253
238
254
-
let* _ = run_directive rpc "#warn_error \"-a\";;" in
239
+
let* _ = run_directive "#warn_error \"-a\";;" in
255
240
256
241
Printf.printf "\n--- Section 6: #rectypes ---\n%!";
257
242
258
-
let* r = run_directive rpc "type 'a t = 'a t -> int;;" in
243
+
let* r = run_directive "type 'a t = 'a t -> int;;" in
259
244
test "rectypes_before" (contains r "Error" || contains r "cyclic") r;
260
245
261
-
let* _ = run_directive rpc "#rectypes;;" in
262
-
let* r = run_directive rpc "type 'a u = 'a u -> int;;" in
246
+
let* _ = run_directive "#rectypes;;" in
247
+
let* r = run_directive "type 'a u = 'a u -> int;;" in
263
248
test "rectypes_after" (contains r "type 'a u") r;
264
249
265
250
Printf.printf "\n--- Section 7: #directory ---\n%!";
266
251
267
-
let* r = run_directive rpc "#directory \"/tmp\";;" in
252
+
let* r = run_directive "#directory \"/tmp\";;" in
268
253
test "directory_add" (String.length r >= 0) "(no error)";
269
254
270
-
let* r = run_directive rpc "#remove_directory \"/tmp\";;" in
255
+
let* r = run_directive "#remove_directory \"/tmp\";;" in
271
256
test "directory_remove" (String.length r >= 0) "(no error)";
272
257
273
258
Printf.printf "\n--- Section 8: #help ---\n%!";
274
259
275
-
let* r = run_directive rpc "#help;;" in
260
+
let* r = run_directive "#help;;" in
276
261
test "help"
277
262
(contains r "directive" || contains r "Directive" || contains r "#")
278
263
(String.sub r 0 (min 100 (String.length r)) ^ "...");
279
264
280
265
Printf.printf "\n--- Section 9: #labels / #principal ---\n%!";
281
266
282
-
let* r = run_directive rpc "#labels true;;" in
267
+
let* r = run_directive "#labels true;;" in
283
268
test "labels_true" (String.length r >= 0) "(no error)";
284
269
285
-
let* r = run_directive rpc "#labels false;;" in
270
+
let* r = run_directive "#labels false;;" in
286
271
test "labels_false" (String.length r >= 0) "(no error)";
287
272
288
-
let* r = run_directive rpc "#principal true;;" in
273
+
let* r = run_directive "#principal true;;" in
289
274
test "principal_true" (String.length r >= 0) "(no error)";
290
275
291
-
let* r = run_directive rpc "#principal false;;" in
276
+
let* r = run_directive "#principal false;;" in
292
277
test "principal_false" (String.length r >= 0) "(no error)";
293
278
294
279
Printf.printf "\n--- Section 10: Error Cases ---\n%!";
295
280
296
-
let* r = run_directive rpc "#unknown_directive;;" in
281
+
let* r = run_directive "#unknown_directive;;" in
297
282
test "unknown_directive" (contains r "Unknown") r;
298
283
299
-
let* r = run_directive rpc "#show nonexistent_value;;" in
284
+
let* r = run_directive "#show nonexistent_value;;" in
300
285
test "show_nonexistent" (contains r "Unknown" || contains r "not found") r;
301
286
302
287
Printf.printf "\n--- Section 11: Classes ---\n%!";
303
288
304
289
let* _ =
305
-
run_directive rpc
290
+
run_directive
306
291
"class counter = object val mutable n = 0 method incr = n <- n + 1 \
307
292
method get = n end;;"
308
293
in
309
-
let* r = run_directive rpc "#show_class counter;;" in
294
+
let* r = run_directive "#show_class counter;;" in
310
295
test "show_class" (contains r "class counter") r;
311
296
312
-
IdlM.ErrM.return ()
297
+
Lwt.return (Ok ())
313
298
in
314
299
315
-
let promise = test_sequence |> IdlM.T.get in
300
+
let promise = test_sequence in
316
301
(match Lwt.state promise with
317
302
| Lwt.Return (Ok ()) -> ()
318
303
| Lwt.Return (Error (InternalError s)) ->
+8
-8
test/node/node_env_test.expected
+8
-8
test/node/node_env_test.expected
···
145
145
Reading library: base.shadow_stdlib
146
146
Number of children: 0
147
147
node_env_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
-
node_env_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
148
+
node_env_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
149
149
node_env_test.js: [INFO] init() finished
150
150
--- Section 1: Default Environment ---
151
151
node_env_test.js: [INFO] setup() for env default...
···
175
175
176
176
--- Section 3: Environment Isolation ---
177
177
Line 1, characters 0-11:
178
-
Error: Unbound value default_val
178
+
Error: Unbound value "default_val"
179
179
[PASS] isolation_default_from_env1: No leakage: # default_val;;
180
180
181
181
Line 1, characters 0-8:
182
-
Error: Unbound value env1_val
182
+
Error: Unbound value "env1_val"
183
183
[PASS] isolation_env1_from_default: No leakage: # env1_val;;
184
184
[PASS] default_still_works: # default_val;;
185
185
- : int = 42
···
196
196
val env2_val : int = 200
197
197
198
198
Line 1, characters 0-8:
199
-
Error: Unbound value env1_val
200
-
Hint: Did you mean env2_val?
199
+
Error: Unbound value "env1_val"
200
+
Hint: Did you mean "env2_val"?
201
201
[PASS] isolation_env1_from_env2: No leakage: # env1_val;;
202
202
203
203
Line 1, characters 0-8:
204
-
Error: Unbound value env2_val
205
-
Hint: Did you mean env1_val?
204
+
Error: Unbound value "env2_val"
205
+
Hint: Did you mean "env1_val"?
206
206
[PASS] isolation_env2_from_env1: No leakage: # env2_val;;
207
207
208
208
--- Section 5: List Environments ---
···
228
228
node_env_test.js: [INFO] setup() finished for env env2
229
229
230
230
Line 1, characters 0-8:
231
-
Error: Unbound value env2_val
231
+
Error: Unbound value "env2_val"
232
232
[PASS] new_env2_clean: Old value gone: # env2_val;;
233
233
[PASS] new_env2_define: # let new_env2_val = 999;;
234
234
val new_env2_val : int = 999
+41
-50
test/node/node_env_test.ml
+41
-50
test/node/node_env_test.ml
···
9
9
*)
10
10
11
11
open Js_top_worker
12
-
open Js_top_worker_rpc.Toplevel_api_gen
13
12
open Impl
14
13
15
14
(* Flusher that writes to process.stdout in Node.js *)
···
34
33
in
35
34
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
36
35
(captured, x)
37
-
38
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
39
36
40
37
module S : Impl.S = struct
41
38
type findlib_t = Js_top_worker_web.Findlibish.t
···
87
84
88
85
module U = Impl.Make (S)
89
86
90
-
let start_server () =
91
-
let open U in
92
-
Logs.set_reporter (Logs_fmt.reporter ());
93
-
Logs.set_level (Some Logs.Info);
94
-
Server.init (IdlM.T.lift init);
95
-
Server.create_env (IdlM.T.lift create_env);
96
-
Server.destroy_env (IdlM.T.lift destroy_env);
97
-
Server.list_envs (IdlM.T.lift list_envs);
98
-
Server.setup (IdlM.T.lift setup);
99
-
Server.exec execute;
100
-
Server.complete_prefix complete_prefix;
101
-
Server.query_errors query_errors;
102
-
Server.type_enclosing type_enclosing;
103
-
Server.exec_toplevel exec_toplevel;
104
-
IdlM.server Server.implementation
105
-
106
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
107
-
108
87
(* Test result tracking *)
109
88
let total_tests = ref 0
110
89
let passed_tests = ref 0
···
122
101
true
123
102
with Not_found -> false
124
103
125
-
let run_toplevel rpc env_id code =
126
-
let ( let* ) = IdlM.ErrM.bind in
127
-
let* result = Client.exec_toplevel rpc env_id ("# " ^ code) in
128
-
IdlM.ErrM.return result.script
104
+
let run_toplevel env_id code =
105
+
let ( let* ) m f =
106
+
let open Lwt in
107
+
m >>= function
108
+
| Ok x -> f x
109
+
| Error e -> return (Error e)
110
+
in
111
+
let* result = U.exec_toplevel env_id ("# " ^ code) in
112
+
Lwt.return (Ok result.script)
129
113
130
114
let _ =
131
115
Printf.printf "=== Node.js Environment Tests ===\n\n%!";
132
116
133
-
let rpc = start_server () in
134
-
let ( let* ) = IdlM.ErrM.bind in
117
+
Logs.set_reporter (Logs_fmt.reporter ());
118
+
Logs.set_level (Some Logs.Info);
119
+
120
+
let ( let* ) m f =
121
+
let open Lwt in
122
+
m >>= function
123
+
| Ok x -> f x
124
+
| Error e -> return (Error e)
125
+
in
135
126
136
127
let init_config =
137
128
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
···
139
130
140
131
let test_sequence =
141
132
(* Initialize *)
142
-
let* _ = Client.init rpc init_config in
133
+
let* _ = U.init init_config in
143
134
144
135
Printf.printf "--- Section 1: Default Environment ---\n%!";
145
136
146
137
(* Setup default environment *)
147
-
let* _ = Client.setup rpc "" in
138
+
let* _ = U.setup "" in
148
139
test "default_setup" true "Default environment setup";
149
140
150
141
(* Define a value in default environment *)
151
-
let* r = run_toplevel rpc "" "let default_val = 42;;" in
142
+
let* r = run_toplevel "" "let default_val = 42;;" in
152
143
test "default_define" (contains r "val default_val : int = 42") r;
153
144
154
145
Printf.printf "\n--- Section 2: Creating New Environments ---\n%!";
155
146
156
147
(* Create a new environment "env1" *)
157
-
let* _ = Client.create_env rpc "env1" in
148
+
let* _ = U.create_env "env1" in
158
149
test "create_env1" true "Created environment env1";
159
150
160
151
(* Setup env1 *)
161
-
let* _ = Client.setup rpc "env1" in
152
+
let* _ = U.setup "env1" in
162
153
test "setup_env1" true "Setup environment env1";
163
154
164
155
(* Define a different value in env1 *)
165
-
let* r = run_toplevel rpc "env1" "let env1_val = 100;;" in
156
+
let* r = run_toplevel "env1" "let env1_val = 100;;" in
166
157
test "env1_define" (contains r "val env1_val : int = 100") r;
167
158
168
159
Printf.printf "\n--- Section 3: Environment Isolation ---\n%!";
169
160
170
161
(* Check that default_val is NOT visible in env1 - the script output
171
162
should NOT contain "val default_val" if there was an error *)
172
-
let* r = run_toplevel rpc "env1" "default_val;;" in
163
+
let* r = run_toplevel "env1" "default_val;;" in
173
164
test "isolation_default_from_env1" (not (contains r "val default_val"))
174
165
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
175
166
176
167
(* Check that env1_val is NOT visible in default env *)
177
-
let* r = run_toplevel rpc "" "env1_val;;" in
168
+
let* r = run_toplevel "" "env1_val;;" in
178
169
test "isolation_env1_from_default" (not (contains r "val env1_val"))
179
170
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
180
171
181
172
(* Check that default_val IS still visible in default env *)
182
-
let* r = run_toplevel rpc "" "default_val;;" in
173
+
let* r = run_toplevel "" "default_val;;" in
183
174
test "default_still_works" (contains r "- : int = 42") r;
184
175
185
176
Printf.printf "\n--- Section 4: Multiple Environments ---\n%!";
186
177
187
178
(* Create a second environment *)
188
-
let* _ = Client.create_env rpc "env2" in
189
-
let* _ = Client.setup rpc "env2" in
179
+
let* _ = U.create_env "env2" in
180
+
let* _ = U.setup "env2" in
190
181
test "create_and_setup_env2" true "Created and setup env2";
191
182
192
183
(* Define value in env2 *)
193
-
let* r = run_toplevel rpc "env2" "let env2_val = 200;;" in
184
+
let* r = run_toplevel "env2" "let env2_val = 200;;" in
194
185
test "env2_define" (contains r "val env2_val : int = 200") r;
195
186
196
187
(* Verify isolation between all three environments *)
197
-
let* r = run_toplevel rpc "env2" "env1_val;;" in
188
+
let* r = run_toplevel "env2" "env1_val;;" in
198
189
test "isolation_env1_from_env2" (not (contains r "val env1_val"))
199
190
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
200
191
201
-
let* r = run_toplevel rpc "env1" "env2_val;;" in
192
+
let* r = run_toplevel "env1" "env2_val;;" in
202
193
test "isolation_env2_from_env1" (not (contains r "val env2_val"))
203
194
("No leakage: " ^ String.sub r 0 (min 40 (String.length r)));
204
195
205
196
Printf.printf "\n--- Section 5: List Environments ---\n%!";
206
197
207
198
(* List all environments *)
208
-
let* envs = Client.list_envs rpc () in
199
+
let* envs = U.list_envs () in
209
200
test "list_envs_count" (List.length envs >= 3)
210
201
(Printf.sprintf "Found %d environments" (List.length envs));
211
202
test "list_envs_has_default" (List.mem "default" envs)
···
218
209
Printf.printf "\n--- Section 6: Destroy Environment ---\n%!";
219
210
220
211
(* Destroy env2 *)
221
-
let* _ = Client.destroy_env rpc "env2" in
212
+
let* _ = U.destroy_env "env2" in
222
213
test "destroy_env2" true "Destroyed env2";
223
214
224
215
(* Verify env2 is gone from list *)
225
-
let* envs = Client.list_envs rpc () in
216
+
let* envs = U.list_envs () in
226
217
test "env2_destroyed" (not (List.mem "env2" envs))
227
218
(String.concat ", " envs);
228
219
···
233
224
Printf.printf "\n--- Section 7: Reuse Environment Name ---\n%!";
234
225
235
226
(* Re-create env2 *)
236
-
let* _ = Client.create_env rpc "env2" in
237
-
let* _ = Client.setup rpc "env2" in
227
+
let* _ = U.create_env "env2" in
228
+
let* _ = U.setup "env2" in
238
229
239
230
(* Old values should not exist - checking that it doesn't find the old value *)
240
-
let* r = run_toplevel rpc "env2" "env2_val;;" in
231
+
let* r = run_toplevel "env2" "env2_val;;" in
241
232
test "new_env2_clean" (not (contains r "- : int = 200"))
242
233
("Old value gone: " ^ String.sub r 0 (min 40 (String.length r)));
243
234
244
235
(* Define new value *)
245
-
let* r = run_toplevel rpc "env2" "let new_env2_val = 999;;" in
236
+
let* r = run_toplevel "env2" "let new_env2_val = 999;;" in
246
237
test "new_env2_define" (contains r "val new_env2_val : int = 999") r;
247
238
248
-
IdlM.ErrM.return ()
239
+
Lwt.return (Ok ())
249
240
in
250
241
251
-
let promise = test_sequence |> IdlM.T.get in
242
+
let promise = test_sequence in
252
243
(match Lwt.state promise with
253
244
| Lwt.Return (Ok ()) -> ()
254
245
| Lwt.Return (Error (InternalError s)) ->
+6
-6
test/node/node_incremental_test.expected
+6
-6
test/node/node_incremental_test.expected
···
155
155
Number of children: 0
156
156
node_incremental_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
157
157
node_incremental_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
158
-
node_incremental_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
158
+
node_incremental_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
159
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
160
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
159
161
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
160
-
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
161
-
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
162
-
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
163
162
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
164
-
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
165
-
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
163
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
164
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
165
+
node_incremental_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
166
166
node_incremental_test.js: [INFO] init() finished
167
167
node_incremental_test.js: [INFO] setup() for env default...
168
168
node_incremental_test.js: [INFO] Fetching stdlib__Format.cmi
+10
-6
test/node/node_incremental_test.ml
+10
-6
test/node/node_incremental_test.ml
···
1
1
(* Test incremental output *)
2
2
open Js_top_worker
3
-
open Js_top_worker_rpc.Toplevel_api_gen
4
3
open Impl
5
4
6
5
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
···
78
77
Logs.set_reporter (Logs_fmt.reporter ());
79
78
Logs.set_level (Some Logs.Info);
80
79
81
-
let ( let* ) = IdlM.ErrM.bind in
80
+
let ( let* ) m f =
81
+
let open Lwt in
82
+
m >>= function
83
+
| Ok x -> f x
84
+
| Error e -> return (Error e)
85
+
in
82
86
83
87
let init_config =
84
88
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
85
89
in
86
90
87
91
let x =
88
-
let* _ = IdlM.T.lift U.init init_config in
89
-
let* _ = IdlM.T.lift U.setup "" in
92
+
let* _ = U.init init_config in
93
+
let* _ = U.setup "" in
90
94
Logs.info (fun m -> m "Setup complete, testing incremental output...");
91
95
92
96
(* Test incremental output with multiple phrases *)
···
127
131
Logs.info (fun m -> m "Final result stdout: %s"
128
132
(Option.value ~default:"<none>" result.stdout));
129
133
130
-
IdlM.ErrM.return ()
134
+
Lwt.return (Ok ())
131
135
in
132
136
133
-
let promise = x |> IdlM.T.get in
137
+
let promise = x in
134
138
match Lwt.state promise with
135
139
| Lwt.Return (Ok ()) -> Logs.info (fun m -> m "Test completed successfully")
136
140
| Lwt.Return (Error (InternalError s)) -> Logs.err (fun m -> m "Error: %s" s)
+1
-1
test/node/node_mime_test.expected
+1
-1
test/node/node_mime_test.expected
···
145
145
Reading library: base.shadow_stdlib
146
146
Number of children: 0
147
147
node_mime_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
-
node_mime_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
148
+
node_mime_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
149
149
node_mime_test.js: [INFO] init() finished
150
150
node_mime_test.js: [INFO] setup() for env default...
151
151
node_mime_test.js: [INFO] Fetching stdlib__Format.cmi
+24
-41
test/node/node_mime_test.ml
+24
-41
test/node/node_mime_test.ml
···
11
11
*)
12
12
13
13
open Js_top_worker
14
-
open Js_top_worker_rpc.Toplevel_api_gen
15
14
open Impl
16
15
17
16
(* Flusher that writes to process.stdout in Node.js *)
···
36
35
in
37
36
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
38
37
(captured, x)
39
-
40
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
41
38
42
39
module S : Impl.S = struct
43
40
type findlib_t = Js_top_worker_web.Findlibish.t
···
89
86
90
87
module U = Impl.Make (S)
91
88
92
-
let start_server () =
93
-
let open U in
94
-
Logs.set_reporter (Logs_fmt.reporter ());
95
-
Logs.set_level (Some Logs.Info);
96
-
Server.init (IdlM.T.lift init);
97
-
Server.create_env (IdlM.T.lift create_env);
98
-
Server.destroy_env (IdlM.T.lift destroy_env);
99
-
Server.list_envs (IdlM.T.lift list_envs);
100
-
Server.setup (IdlM.T.lift setup);
101
-
Server.exec execute;
102
-
Server.complete_prefix complete_prefix;
103
-
Server.query_errors query_errors;
104
-
Server.type_enclosing type_enclosing;
105
-
Server.exec_toplevel exec_toplevel;
106
-
IdlM.server Server.implementation
107
-
108
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
109
-
110
89
(* Test result tracking *)
111
90
let total_tests = ref 0
112
91
let passed_tests = ref 0
···
118
97
let status = if passed then "PASS" else "FAIL" in
119
98
Printf.printf "[%s] %s: %s\n%!" status name message
120
99
121
-
let run_exec rpc code =
122
-
let ( let* ) = IdlM.ErrM.bind in
123
-
let* result = Client.exec rpc "" code in
124
-
IdlM.ErrM.return result
125
-
126
100
let _ =
127
101
Printf.printf "=== Node.js MIME Infrastructure Tests ===\n\n%!";
128
102
129
-
let rpc = start_server () in
130
-
let ( let* ) = IdlM.ErrM.bind in
103
+
Logs.set_reporter (Logs_fmt.reporter ());
104
+
Logs.set_level (Some Logs.Info);
105
+
106
+
let ( let* ) m f =
107
+
let open Lwt in
108
+
m >>= function
109
+
| Ok x -> f x
110
+
| Error e -> return (Error e)
111
+
in
112
+
113
+
let run_exec code = U.execute "" code in
131
114
132
115
let init_config =
133
116
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
···
135
118
136
119
let test_sequence =
137
120
(* Initialize *)
138
-
let* _ = Client.init rpc init_config in
139
-
let* _ = Client.setup rpc "" in
121
+
let* _ = U.init init_config in
122
+
let* _ = U.setup "" in
140
123
141
124
Printf.printf "--- Section 1: exec_result Has mime_vals Field ---\n%!";
142
125
143
126
(* Basic execution returns a result with mime_vals *)
144
-
let* r = run_exec rpc {|let x = 1 + 2;;|} in
127
+
let* r = run_exec {|let x = 1 + 2;;|} in
145
128
test "has_mime_vals_field" true "exec_result has mime_vals field";
146
129
test "mime_vals_is_list" (List.length r.mime_vals >= 0)
147
130
(Printf.sprintf "mime_vals is a list (length=%d)" (List.length r.mime_vals));
···
153
136
(* Verify API types are accessible *)
154
137
let mime_val_example : mime_val = {
155
138
mime_type = "text/html";
156
-
encoding = Noencoding;
139
+
encoding = Mime_printer.Noencoding;
157
140
data = "<b>test</b>";
158
141
} in
159
142
test "mime_type_field" (mime_val_example.mime_type = "text/html")
160
143
"mime_val has mime_type field";
161
-
test "encoding_noencoding" (mime_val_example.encoding = Noencoding)
144
+
test "encoding_noencoding" (mime_val_example.encoding = Mime_printer.Noencoding)
162
145
"Noencoding variant works";
163
146
test "data_field" (mime_val_example.data = "<b>test</b>")
164
147
"mime_val has data field";
165
148
166
149
let mime_val_base64 : mime_val = {
167
150
mime_type = "image/png";
168
-
encoding = Base64;
151
+
encoding = Mime_printer.Base64;
169
152
data = "iVBORw0KGgo=";
170
153
} in
171
-
test "encoding_base64" (mime_val_base64.encoding = Base64)
154
+
test "encoding_base64" (mime_val_base64.encoding = Mime_printer.Base64)
172
155
"Base64 variant works";
173
156
174
157
Printf.printf "\n--- Section 3: Multiple Executions ---\n%!";
175
158
176
159
(* Verify mime_vals is fresh for each execution *)
177
-
let* r1 = run_exec rpc {|let a = 1;;|} in
178
-
let* r2 = run_exec rpc {|let b = 2;;|} in
179
-
let* r3 = run_exec rpc {|let c = 3;;|} in
160
+
let* r1 = run_exec {|let a = 1;;|} in
161
+
let* r2 = run_exec {|let b = 2;;|} in
162
+
let* r3 = run_exec {|let c = 3;;|} in
180
163
test "r1_mime_empty" (List.length r1.mime_vals = 0) "First exec: mime_vals empty";
181
164
test "r2_mime_empty" (List.length r2.mime_vals = 0) "Second exec: mime_vals empty";
182
165
test "r3_mime_empty" (List.length r3.mime_vals = 0) "Third exec: mime_vals empty";
···
184
167
Printf.printf "\n--- Section 4: exec_toplevel Has mime_vals ---\n%!";
185
168
186
169
(* exec_toplevel also returns mime_vals *)
187
-
let* tr = Client.exec_toplevel rpc "" "# let z = 42;;" in
170
+
let* tr = U.exec_toplevel "" "# let z = 42;;" in
188
171
test "toplevel_has_mime_vals" true "exec_toplevel_result has mime_vals field";
189
172
test "toplevel_mime_vals_list" (List.length tr.mime_vals >= 0)
190
173
(Printf.sprintf "toplevel mime_vals is a list (length=%d)" (List.length tr.mime_vals));
191
174
192
-
IdlM.ErrM.return ()
175
+
Lwt.return (Ok ())
193
176
in
194
177
195
-
let promise = test_sequence |> IdlM.T.get in
178
+
let promise = test_sequence in
196
179
(match Lwt.state promise with
197
180
| Lwt.Return (Ok ()) -> ()
198
181
| Lwt.Return (Error (InternalError s)) ->
+1
-1
test/node/node_ppx_test.expected
+1
-1
test/node/node_ppx_test.expected
···
145
145
Reading library: base.shadow_stdlib
146
146
Number of children: 0
147
147
node_ppx_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
148
-
node_ppx_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
148
+
node_ppx_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
149
149
node_ppx_test.js: [INFO] init() finished
150
150
node_ppx_test.js: [INFO] setup() for env default...
151
151
node_ppx_test.js: [INFO] Fetching stdlib__Format.cmi
+37
-51
test/node/node_ppx_test.ml
+37
-51
test/node/node_ppx_test.ml
···
12
12
*)
13
13
14
14
open Js_top_worker
15
-
open Js_top_worker_rpc.Toplevel_api_gen
16
15
open Impl
17
16
18
17
(* Flusher that writes to process.stdout in Node.js *)
···
37
36
in
38
37
Js_of_ocaml.Sys_js.set_channel_flusher stdout console_flusher;
39
38
(captured, x)
40
-
41
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
42
39
43
40
module S : Impl.S = struct
44
41
type findlib_t = Js_top_worker_web.Findlibish.t
···
88
85
89
86
module U = Impl.Make (S)
90
87
91
-
let start_server () =
92
-
let open U in
93
-
Logs.set_reporter (Logs_fmt.reporter ());
94
-
Logs.set_level (Some Logs.Info);
95
-
Server.init (IdlM.T.lift init);
96
-
Server.create_env (IdlM.T.lift create_env);
97
-
Server.destroy_env (IdlM.T.lift destroy_env);
98
-
Server.list_envs (IdlM.T.lift list_envs);
99
-
Server.setup (IdlM.T.lift setup);
100
-
Server.exec execute;
101
-
Server.complete_prefix complete_prefix;
102
-
Server.query_errors query_errors;
103
-
Server.type_enclosing type_enclosing;
104
-
Server.exec_toplevel exec_toplevel;
105
-
IdlM.server Server.implementation
106
-
107
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
108
-
109
88
(* Test state *)
110
89
let passed_tests = ref 0
111
90
let total_tests = ref 0
···
121
100
true
122
101
with Not_found -> false
123
102
124
-
let run_toplevel rpc code =
125
-
let ( let* ) = IdlM.ErrM.bind in
126
-
let* result = Client.exec_toplevel rpc "" ("# " ^ code) in
127
-
IdlM.ErrM.return result.script
128
-
129
103
let _ =
130
104
Printf.printf "=== Node.js PPX Tests ===\n\n%!";
131
105
132
-
let rpc = start_server () in
133
-
let ( let* ) = IdlM.ErrM.bind in
106
+
Logs.set_reporter (Logs_fmt.reporter ());
107
+
Logs.set_level (Some Logs.Info);
108
+
109
+
let ( let* ) m f =
110
+
let open Lwt in
111
+
m >>= function
112
+
| Ok x -> f x
113
+
| Error e -> return (Error e)
114
+
in
115
+
116
+
let run_toplevel code =
117
+
let* result = U.exec_toplevel "" ("# " ^ code) in
118
+
Lwt.return (Ok result.script)
119
+
in
134
120
135
121
let init_config =
136
122
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
···
138
124
139
125
let test_sequence =
140
126
(* Initialize *)
141
-
let* _ = Client.init rpc init_config in
142
-
let* _ = Client.setup rpc "" in
127
+
let* _ = U.init init_config in
128
+
let* _ = U.setup "" in
143
129
144
130
Printf.printf "--- Loading PPX dynamically ---\n%!";
145
131
146
132
(* Dynamically load ppx_deriving.show - this should:
147
133
1. Load the PPX deriver (registers with ppxlib)
148
134
2. Auto-load ppx_deriving.runtime (via findlibish -ppx_driver predicate) *)
149
-
let* r = run_toplevel rpc "#require \"ppx_deriving.show\";;" in
135
+
let* r = run_toplevel "#require \"ppx_deriving.show\";;" in
150
136
test "load_ppx_show" (not (contains r "Error"))
151
137
(if contains r "Error" then r else "ppx_deriving.show loaded");
152
138
153
139
(* Also load eq deriver *)
154
-
let* r = run_toplevel rpc "#require \"ppx_deriving.eq\";;" in
140
+
let* r = run_toplevel "#require \"ppx_deriving.eq\";;" in
155
141
test "load_ppx_eq" (not (contains r "Error"))
156
142
(if contains r "Error" then r else "ppx_deriving.eq loaded");
157
143
158
144
Printf.printf "\n--- Section 1: ppx_deriving.show ---\n%!";
159
145
160
146
(* Test [@@deriving show] generates pp and show functions *)
161
-
let* r = run_toplevel rpc "type color = Red | Green | Blue [@@deriving show];;" in
147
+
let* r = run_toplevel "type color = Red | Green | Blue [@@deriving show];;" in
162
148
test "show_type_defined" (contains r "type color") "type color defined";
163
149
test "show_pp_generated" (contains r "val pp_color")
164
150
(if contains r "val pp_color" then "pp_color generated" else r);
···
166
152
(if contains r "val show_color" then "show_color generated" else r);
167
153
168
154
(* Test the generated show function works *)
169
-
let* r = run_toplevel rpc "show_color Red;;" in
155
+
let* r = run_toplevel "show_color Red;;" in
170
156
test "show_fn_works" (contains r "Red")
171
157
(String.sub r 0 (min 60 (String.length r)));
172
158
173
159
(* Test with a record type *)
174
-
let* r = run_toplevel rpc "type point = { x: int; y: int } [@@deriving show];;" in
160
+
let* r = run_toplevel "type point = { x: int; y: int } [@@deriving show];;" in
175
161
test "show_record_type" (contains r "type point") "point type defined";
176
162
test "show_record_pp" (contains r "val pp_point")
177
163
(if contains r "val pp_point" then "pp_point generated" else r);
178
164
179
-
let* r = run_toplevel rpc "show_point { x = 10; y = 20 };;" in
165
+
let* r = run_toplevel "show_point { x = 10; y = 20 };;" in
180
166
test "show_record_works" (contains r "10" && contains r "20")
181
167
(String.sub r 0 (min 60 (String.length r)));
182
168
183
169
Printf.printf "\n--- Section 2: ppx_deriving.eq ---\n%!";
184
170
185
171
(* Test [@@deriving eq] generates equal function *)
186
-
let* r = run_toplevel rpc "type status = Active | Inactive [@@deriving eq];;" in
172
+
let* r = run_toplevel "type status = Active | Inactive [@@deriving eq];;" in
187
173
test "eq_type_defined" (contains r "type status") "status type defined";
188
174
test "eq_fn_generated" (contains r "val equal_status")
189
175
(if contains r "val equal_status" then "equal_status generated" else r);
190
176
191
177
(* Test the generated equal function works *)
192
-
let* r = run_toplevel rpc "equal_status Active Active;;" in
178
+
let* r = run_toplevel "equal_status Active Active;;" in
193
179
test "eq_same_true" (contains r "true") r;
194
180
195
-
let* r = run_toplevel rpc "equal_status Active Inactive;;" in
181
+
let* r = run_toplevel "equal_status Active Inactive;;" in
196
182
test "eq_diff_false" (contains r "false") r;
197
183
198
184
Printf.printf "\n--- Section 3: Combined Derivers ---\n%!";
199
185
200
186
(* Test multiple derivers on one type *)
201
-
let* r = run_toplevel rpc "type expr = Num of int | Add of expr * expr [@@deriving show, eq];;" in
187
+
let* r = run_toplevel "type expr = Num of int | Add of expr * expr [@@deriving show, eq];;" in
202
188
test "combined_type" (contains r "type expr") "expr type defined";
203
189
test "combined_pp" (contains r "val pp_expr")
204
190
(if contains r "val pp_expr" then "pp_expr generated" else r);
···
206
192
(if contains r "val equal_expr" then "equal_expr generated" else r);
207
193
208
194
(* Test they work together *)
209
-
let* r = run_toplevel rpc "let e1 = Add (Num 1, Num 2);;" in
195
+
let* r = run_toplevel "let e1 = Add (Num 1, Num 2);;" in
210
196
test "combined_value" (contains r "val e1") r;
211
197
212
-
let* r = run_toplevel rpc "show_expr e1;;" in
198
+
let* r = run_toplevel "show_expr e1;;" in
213
199
test "combined_show_works" (contains r "Add" || contains r "Num")
214
200
(String.sub r 0 (min 80 (String.length r)));
215
201
216
-
let* r = run_toplevel rpc "equal_expr e1 e1;;" in
202
+
let* r = run_toplevel "equal_expr e1 e1;;" in
217
203
test "combined_eq_self" (contains r "true") r;
218
204
219
-
let* r = run_toplevel rpc "equal_expr e1 (Num 1);;" in
205
+
let* r = run_toplevel "equal_expr e1 (Num 1);;" in
220
206
test "combined_eq_diff" (contains r "false") r;
221
207
222
208
Printf.printf "\n--- Section 4: Basic Code Still Works ---\n%!";
223
209
224
210
(* Verify normal code without PPX still works *)
225
-
let* r = run_toplevel rpc "let x = 1 + 2;;" in
211
+
let* r = run_toplevel "let x = 1 + 2;;" in
226
212
test "basic_arithmetic" (contains r "val x : int = 3") r;
227
213
228
-
let* r = run_toplevel rpc "let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;" in
214
+
let* r = run_toplevel "let rec fib n = if n <= 1 then n else fib (n-1) + fib (n-2);;" in
229
215
test "recursive_fn" (contains r "val fib : int -> int") r;
230
216
231
-
let* r = run_toplevel rpc "fib 10;;" in
217
+
let* r = run_toplevel "fib 10;;" in
232
218
test "fib_result" (contains r "55") r;
233
219
234
220
Printf.printf "\n--- Section 5: Module Support ---\n%!";
235
221
236
-
let* r = run_toplevel rpc "module M = struct type t = A | B [@@deriving show] end;;" in
222
+
let* r = run_toplevel "module M = struct type t = A | B [@@deriving show] end;;" in
237
223
test "module_with_deriving" (contains r "module M") r;
238
224
239
-
let* r = run_toplevel rpc "M.show_t M.A;;" in
225
+
let* r = run_toplevel "M.show_t M.A;;" in
240
226
test "module_show_works" (contains r "A")
241
227
(String.sub r 0 (min 60 (String.length r)));
242
228
243
-
IdlM.ErrM.return ()
229
+
Lwt.return (Ok ())
244
230
in
245
231
246
-
let promise = test_sequence |> IdlM.T.get in
232
+
let promise = test_sequence in
247
233
(match Lwt.state promise with
248
234
| Lwt.Return (Ok ()) -> ()
249
235
| Lwt.Return (Error (InternalError s)) ->
+7
-6
test/node/node_test.expected
+7
-6
test/node/node_test.expected
···
1
+
node_test.js: [INFO] Starting server...
1
2
node_test.js: [INFO] init()
2
3
Initializing findlib
3
4
node_test.js: [INFO] async_get: _opam/findlib_index.json
···
155
156
Number of children: 0
156
157
node_test.js: [INFO] sync_get: _opam/lib/ocaml/dynamic_cmis.json
157
158
node_test.js: [INFO] Adding toplevel modules for dynamic cmis from lib/ocaml/
158
-
node_test.js: [INFO] toplevel modules: CamlinternalFormat, CamlinternalLazy, CamlinternalFormatBasics, CamlinternalMod, Std_exit, Stdlib, CamlinternalOO
159
+
node_test.js: [INFO] toplevel modules: CamlinternalOO, Stdlib, CamlinternalFormat, Std_exit, CamlinternalMod, CamlinternalFormatBasics, CamlinternalLazy
160
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
161
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
159
162
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormat.cmi
160
-
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
161
-
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
162
-
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
163
163
node_test.js: [INFO] async_get: _opam/lib/ocaml/std_exit.cmi
164
-
node_test.js: [INFO] async_get: _opam/lib/ocaml/stdlib.cmi
165
-
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalOO.cmi
164
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalMod.cmi
165
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalFormatBasics.cmi
166
+
node_test.js: [INFO] async_get: _opam/lib/ocaml/camlinternalLazy.cmi
166
167
node_test.js: [INFO] init() finished
167
168
node_test.js: [INFO] setup() for env default...
168
169
node_test.js: [INFO] Fetching stdlib__Format.cmi
+24
-42
test/node/node_test.ml
+24
-42
test/node/node_test.ml
···
1
1
(* Unix worker *)
2
2
open Js_top_worker
3
-
open Js_top_worker_rpc.Toplevel_api_gen
4
3
open Impl
5
4
6
5
let capture : (unit -> 'a) -> unit -> Impl.captured * 'a =
···
17
16
}
18
17
in
19
18
(captured, x)
20
-
21
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
22
19
23
20
module S : Impl.S = struct
24
21
type findlib_t = Js_top_worker_web.Findlibish.t
···
77
74
78
75
module U = Impl.Make (S)
79
76
80
-
let start_server () =
81
-
let open U in
77
+
let _ =
82
78
Logs.set_reporter (Logs_fmt.reporter ());
83
79
Logs.set_level (Some Logs.Info);
84
-
(* let pid = Unix.getpid () in *)
85
-
Server.init (IdlM.T.lift init);
86
-
Server.create_env (IdlM.T.lift create_env);
87
-
Server.destroy_env (IdlM.T.lift destroy_env);
88
-
Server.list_envs (IdlM.T.lift list_envs);
89
-
Server.setup (IdlM.T.lift setup);
90
-
Server.exec execute;
91
-
Server.complete_prefix complete_prefix;
92
-
Server.query_errors query_errors;
93
-
Server.type_enclosing type_enclosing;
94
-
Server.exec_toplevel exec_toplevel;
95
-
IdlM.server Server.implementation
96
-
97
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenClient ())
98
-
99
-
let _ =
100
80
Logs.info (fun m -> m "Starting server...");
101
-
let rpc = start_server () in
102
-
let ( let* ) = IdlM.ErrM.bind in
81
+
let ( let* ) m f =
82
+
let open Lwt in
83
+
m >>= function
84
+
| Ok x -> f x
85
+
| Error e -> return (Error e)
86
+
in
103
87
let init_config =
104
-
Js_top_worker_rpc.Toplevel_api_gen.
105
-
{ stdlib_dcs = None; findlib_requires = [ "base" ]; findlib_index = None; execute = true }
88
+
{ stdlib_dcs = None; findlib_requires = [ "base" ]; findlib_index = None; execute = true }
106
89
in
107
90
let x =
108
-
let open Client in
109
-
let* _ = init rpc init_config in
110
-
let* o = setup rpc "" in
91
+
let* _ = U.init init_config in
92
+
let* o = U.setup "" in
111
93
Logs.info (fun m ->
112
94
m "setup output: %s" (Option.value ~default:"" o.stdout));
113
-
let* _ = query_errors rpc "" (Some "c1") [] false "type xxxx = int;;\n" in
95
+
let* _ = U.query_errors "" (Some "c1") [] false "type xxxx = int;;\n" in
114
96
let* o1 =
115
-
query_errors rpc "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
97
+
U.query_errors "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
116
98
in
117
99
Logs.info (fun m -> m "Number of errors: %d (should be 1)" (List.length o1));
118
-
let* _ = query_errors rpc "" (Some "c1") [] false "type xxx = int;;\n" in
100
+
let* _ = U.query_errors "" (Some "c1") [] false "type xxx = int;;\n" in
119
101
let* o2 =
120
-
query_errors rpc "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
102
+
U.query_errors "" (Some "c2") [ "c1" ] false "type yyy = xxx;;\n"
121
103
in
122
104
Logs.info (fun m ->
123
105
m "Number of errors1: %d (should be 1)" (List.length o1));
···
127
109
(* Test completion for List.leng *)
128
110
let* completions1 =
129
111
let text = "let _ = List.leng" in
130
-
Client.complete_prefix rpc "" (Some "c_comp1") [] false text
112
+
U.complete_prefix "" (Some "c_comp1") [] false text
131
113
(Offset (String.length text))
132
114
in
133
115
Logs.info (fun m ->
···
153
135
(* Test completion for List. (should show all List module functions) *)
154
136
let* completions2 =
155
137
let text = "# let _ = List." in
156
-
Client.complete_prefix rpc "" (Some "c_comp2") [] true text
138
+
U.complete_prefix "" (Some "c_comp2") [] true text
157
139
(Offset (String.length text))
158
140
in
159
141
Logs.info (fun m ->
···
179
161
(* Test completion for partial identifier *)
180
162
let* completions3 =
181
163
let text = "# let _ = ma" in
182
-
Client.complete_prefix rpc "" (Some "c_comp3") [] true text
164
+
U.complete_prefix "" (Some "c_comp3") [] true text
183
165
(Offset (String.length text))
184
166
in
185
167
Logs.info (fun m ->
···
204
186
(* Test completion in non-toplevel context *)
205
187
let* completions4 =
206
188
let text = "let _ = List.leng" in
207
-
Client.complete_prefix rpc "" (Some "c_comp4") [] false text
189
+
U.complete_prefix "" (Some "c_comp4") [] false text
208
190
(Offset (String.length text))
209
191
in
210
192
Logs.info (fun m ->
···
230
212
(* Test completion using Logical position constructor *)
231
213
let* completions5 =
232
214
let text = "# let _ = List.leng\n let foo=1.0;;" in
233
-
Client.complete_prefix rpc "" (Some "c_comp5") [] true text
215
+
U.complete_prefix "" (Some "c_comp5") [] true text
234
216
(Logical (1, 16))
235
217
in
236
218
Logs.info (fun m ->
···
256
238
(* Test toplevel completion with variable binding *)
257
239
let* completions6 =
258
240
let s = "# let my_var = 42;;\n# let x = 1 + my_v" in
259
-
Client.complete_prefix rpc "" (Some "c_comp6") [] true
241
+
U.complete_prefix "" (Some "c_comp6") [] true
260
242
s
261
243
(Offset (String.length s))
262
244
in
···
282
264
283
265
(* Test toplevel completion with function definition *)
284
266
let* completions7 =
285
-
Client.complete_prefix rpc "" (Some "c_comp7") [] true
267
+
U.complete_prefix "" (Some "c_comp7") [] true
286
268
"# let rec factorial n = if n <= 1 then 1 else n * facto"
287
269
(Offset 55)
288
270
in
···
308
290
309
291
(* Test toplevel completion with module paths *)
310
292
let* completions8 =
311
-
Client.complete_prefix rpc "" (Some "c_comp8") [] true
293
+
U.complete_prefix "" (Some "c_comp8") [] true
312
294
"# String.lengt"
313
295
(Offset 14)
314
296
in
···
336
318
Client.exec_toplevel rpc
337
319
"# Stringext.of_list ['a';'b';'c'];;\n" in
338
320
Logs.info (fun m -> m "Exec toplevel output: %s" o3.script); *)
339
-
IdlM.ErrM.return ()
321
+
Lwt.return (Ok ())
340
322
in
341
323
(* The operations are actually synchronous in this test context *)
342
-
let promise = x |> IdlM.T.get in
324
+
let promise = x in
343
325
match Lwt.state promise with
344
326
| Lwt.Return (Ok ()) -> Logs.info (fun m -> m "Success")
345
327
| Lwt.Return (Error (InternalError s)) -> Logs.err (fun m -> m "Error: %s" s)
-2
test/unix/dune
-2
test/unix/dune
+17
-33
test/unix/unix_test.ml
+17
-33
test/unix/unix_test.ml
···
59
59
Printf.fprintf stderr "Package requires itself: %s\n" pkg
60
60
| exn -> raise exn
61
61
62
-
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenServer ())
63
-
64
62
module S : Impl.S = struct
65
63
type findlib_t = unit
66
64
···
92
90
93
91
module U = Impl.Make (S)
94
92
95
-
let start_server () =
96
-
(try Unix.mkdir S.path 0o777 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
97
-
let open U in
98
-
Logs.set_reporter (Logs_fmt.reporter ());
99
-
Logs.set_level (Some Logs.Info);
100
-
(* let pid = Unix.getpid () in *)
101
-
Server.init (IdlM.T.lift init);
102
-
Server.create_env (IdlM.T.lift create_env);
103
-
Server.destroy_env (IdlM.T.lift destroy_env);
104
-
Server.list_envs (IdlM.T.lift list_envs);
105
-
Server.setup (IdlM.T.lift setup);
106
-
Server.exec execute;
107
-
Server.complete_prefix complete_prefix;
108
-
Server.query_errors query_errors;
109
-
Server.type_enclosing type_enclosing;
110
-
Server.exec_toplevel exec_toplevel;
111
-
IdlM.server Server.implementation
112
-
113
-
module Client = Js_top_worker_rpc.Toplevel_api_gen.Make (IdlM.GenClient ())
114
-
115
93
let c1, c2, c3, c4 = ("c1", "c2", "c3", "c4")
116
94
117
95
let notebook =
···
123
101
]
124
102
125
103
let _ =
126
-
let rpc = start_server () in
104
+
(try Unix.mkdir S.path 0o777 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
105
+
Logs.set_reporter (Logs_fmt.reporter ());
106
+
Logs.set_level (Some Logs.Info);
127
107
Printf.printf "Starting worker...\n%!";
128
-
let ( let* ) = IdlM.ErrM.bind in
108
+
let ( let* ) m f =
109
+
let open Lwt in
110
+
m >>= function
111
+
| Ok x -> f x
112
+
| Error e -> return (Error e)
113
+
in
129
114
let init =
130
-
Js_top_worker_rpc.Toplevel_api_gen.
131
-
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
115
+
{ stdlib_dcs = None; findlib_requires = []; findlib_index = None; execute = true }
132
116
in
133
117
let x =
134
118
let rec run notebook =
135
119
match notebook with
136
120
| (id, deps, cell) :: cells ->
137
-
let* errs = Client.query_errors rpc "" (Some id) deps false cell in
121
+
let* errs = U.query_errors "" (Some id) deps false cell in
138
122
Printf.printf "Cell %s: %d errors\n%!" id (List.length errs);
139
123
run cells
140
-
| [] -> IdlM.ErrM.return ()
124
+
| [] -> Lwt.return (Ok ())
141
125
in
142
-
let* _ = Client.init rpc init in
143
-
let* _ = Client.setup rpc "" in
126
+
let* _ = U.init init in
127
+
let* _ = U.setup "" in
144
128
let* _ = run notebook in
145
-
IdlM.ErrM.return ()
129
+
Lwt.return (Ok ())
146
130
in
147
-
match x |> IdlM.T.get |> Lwt_main.run with
131
+
match x |> Lwt_main.run with
148
132
| Ok () -> Printf.printf "Success\n%!"
149
-
| Error (InternalError s) -> Printf.printf "Error: %s\n%!" s
133
+
| Error (InternalError s) -> Printf.printf "Error: %s\n%!" s