jon.recoil.org
this repo has no description
Many changes
+483
-286
+1
-1
example/dune
+1
-1
example/dune
+1
-1
example/example.ml
+1
-1
example/example.ml
+17
-4
example/example2.ml
+17
-4
example/example2.ml
···
3
open Js_top_worker_rpc
4
module W = Js_top_worker_client.W
5
6
-
let dcs = Js_top_worker_rpc.Toplevel_api_gen.{dcs_url="cmis/";
7
-
dcs_toplevel_modules = ["CamlinternalOO";"Stdlib";"CamlinternalFormat";"Std_exit";"CamlinternalMod";"CamlinternalFormatBasics";"CamlinternalLazy"];
8
-
dcs_file_prefixes = ["stdlib__"];}
9
10
let log s = Console.console##log (Js.string s)
11
···
18
{
19
path = "/static/cmis";
20
cmas = [];
21
-
cmis = { dynamic_cmis = [dcs]; static_cmis = [] };
22
stdlib_dcs = "/lib/ocaml/dynamic_cmis.json";
23
findlib_index = "/lib/findlib_index";
24
findlib_requires = [];
···
3
open Js_top_worker_rpc
4
module W = Js_top_worker_client.W
5
6
+
let dcs =
7
+
Js_top_worker_rpc.Toplevel_api_gen.
8
+
{
9
+
dcs_url = "cmis/";
10
+
dcs_toplevel_modules =
11
+
[
12
+
"CamlinternalOO";
13
+
"Stdlib";
14
+
"CamlinternalFormat";
15
+
"Std_exit";
16
+
"CamlinternalMod";
17
+
"CamlinternalFormatBasics";
18
+
"CamlinternalLazy";
19
+
];
20
+
dcs_file_prefixes = [ "stdlib__" ];
21
+
}
22
23
let log s = Console.console##log (Js.string s)
24
···
31
{
32
path = "/static/cmis";
33
cmas = [];
34
+
cmis = { dynamic_cmis = [ dcs ]; static_cmis = [] };
35
stdlib_dcs = "/lib/ocaml/dynamic_cmis.json";
36
findlib_index = "/lib/findlib_index";
37
findlib_requires = [];
+16
-16
example/unix_worker.ml
+16
-16
example/unix_worker.ml
···
93
done
94
95
let handle_findlib_error = function
96
-
| Failure msg ->
97
-
Printf.fprintf stderr "%s" msg
98
-
| Fl_package_base.No_such_package(pkg, reason) ->
99
-
Printf.fprintf stderr "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else "")
100
| Fl_package_base.Package_loop pkg ->
101
Printf.fprintf stderr "Package requires itself: %s\n" pkg
102
-
| exn ->
103
-
raise exn
104
105
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
106
···
111
let sync_get _ = None
112
let create_file ~name:_ ~content:_ = failwith "Not implemented"
113
114
-
let import_scripts urls = if List.length urls > 0 then failwith "Not implemented" else ()
115
116
let init_function _ () = failwith "Not implemented"
117
-
118
let findlib_init _ = ()
119
-
120
-
let get_stdlib_dcs _uri =
121
-
[]
122
123
let require () packages =
124
try
125
-
let eff_packages = Findlib.package_deep_ancestors !Topfind.predicates packages in
126
-
Topfind.load eff_packages; []
127
with exn ->
128
-
handle_findlib_error exn; []
129
end
130
131
module U = Impl.Make (S)
···
150
rpc_fn (Jsonrpc.call_of_string (Bytes.unsafe_to_string x))
151
>>= fun response -> Jsonrpc.string_of_response response |> return
152
in
153
-
serve_requests process
154
-
(Js_top_worker_rpc.Toplevel_api_gen.sockpath)
155
156
let _ = start_server ()
···
93
done
94
95
let handle_findlib_error = function
96
+
| Failure msg -> Printf.fprintf stderr "%s" msg
97
+
| Fl_package_base.No_such_package (pkg, reason) ->
98
+
Printf.fprintf stderr "No such package: %s%s\n" pkg
99
+
(if reason <> "" then " - " ^ reason else "")
100
| Fl_package_base.Package_loop pkg ->
101
Printf.fprintf stderr "Package requires itself: %s\n" pkg
102
+
| exn -> raise exn
103
104
module Server = Js_top_worker_rpc.Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
105
···
110
let sync_get _ = None
111
let create_file ~name:_ ~content:_ = failwith "Not implemented"
112
113
+
let import_scripts urls =
114
+
if List.length urls > 0 then failwith "Not implemented" else ()
115
116
let init_function _ () = failwith "Not implemented"
117
let findlib_init _ = ()
118
+
let get_stdlib_dcs _uri = []
119
120
let require () packages =
121
try
122
+
let eff_packages =
123
+
Findlib.package_deep_ancestors !Topfind.predicates packages
124
+
in
125
+
Topfind.load eff_packages;
126
+
[]
127
with exn ->
128
+
handle_findlib_error exn;
129
+
[]
130
end
131
132
module U = Impl.Make (S)
···
151
rpc_fn (Jsonrpc.call_of_string (Bytes.unsafe_to_string x))
152
>>= fun response -> Jsonrpc.string_of_response response |> return
153
in
154
+
serve_requests process Js_top_worker_rpc.Toplevel_api_gen.sockpath
155
156
let _ = start_server ()
+5
-1
idl/js_top_worker_client.ml
+5
-1
idl/js_top_worker_client.ml
···
89
string ->
90
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
91
92
+
val compile_js :
93
+
rpc ->
94
+
string option ->
95
+
string ->
96
+
(string, Toplevel_api_gen.err) result Lwt.t
97
end = struct
98
type init_libs = Toplevel_api_gen.init_libs
99
type err = Toplevel_api_gen.err
+14
-16
idl/js_top_worker_client.mli
+14
-16
idl/js_top_worker_client.mli
···
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
13
-
RPC 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
20
-
in the 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_libs = Toplevel_api_gen.init_libs
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
35
-
the worker by the timeout set in the {!val-start} call, the {!Lwt}
36
-
thread will be {{!Lwt.fail}failed}.
37
-
*)
38
39
val init : rpc -> init_libs -> (unit, err) result Lwt.t
40
(** Initialise the toplevel. This must be called before any other API. *)
41
42
val setup : rpc -> unit -> (exec_result, err) result Lwt.t
43
-
(** Start the toplevel. Return value is the initial blurb
44
-
printed when starting a toplevel. Note that the toplevel
45
-
must be initialised first. *)
46
47
val typecheck : rpc -> string -> (exec_result, err) result Lwt.t
48
(** Typecheck a phrase using the toplevel. The toplevel must have been
···
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_libs = Toplevel_api_gen.init_libs
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_libs -> (unit, err) result Lwt.t
39
(** Initialise the toplevel. This must be called before any other API. *)
40
41
val setup : rpc -> unit -> (exec_result, err) result Lwt.t
42
+
(** Start the toplevel. Return value is the initial blurb printed when
43
+
starting a toplevel. Note that the toplevel must be initialised first. *)
44
45
val typecheck : rpc -> string -> (exec_result, err) result Lwt.t
46
(** Typecheck a phrase using the toplevel. The toplevel must have been
+1
-1
idl/js_top_worker_client_fut.ml
+1
-1
idl/js_top_worker_client_fut.ml
···
81
let compile_js rpc id s = Wraw.compile_js rpc id s |> Rpc_fut.T.get
82
let query_errors rpc doc = Wraw.query_errors rpc doc |> Rpc_fut.T.get
83
let exec_toplevel rpc doc = Wraw.exec_toplevel rpc doc |> Rpc_fut.T.get
84
-
85
let complete_prefix rpc doc pos =
86
Wraw.complete_prefix rpc doc pos |> Rpc_fut.T.get
87
···
81
let compile_js rpc id s = Wraw.compile_js rpc id s |> Rpc_fut.T.get
82
let query_errors rpc doc = Wraw.query_errors rpc doc |> Rpc_fut.T.get
83
let exec_toplevel rpc doc = Wraw.exec_toplevel rpc doc |> Rpc_fut.T.get
84
+
85
let complete_prefix rpc doc pos =
86
Wraw.complete_prefix rpc doc pos |> Rpc_fut.T.get
87
+11
-2
lib/dune
+11
-2
lib/dune
···
18
merlin-lib.query_commands
19
merlin-lib.ocaml_parsing
20
findlib
21
-
findlib.top)
22
(preprocess
23
(per_module
24
((action
···
34
(modules worker findlibish jslib)
35
(preprocess
36
(pps js_of_ocaml-ppx))
37
-
(libraries js_top_worker js_of_ocaml-toplevel logs.browser uri angstrom findlib fpath))
38
39
(ocamllex uTop_lexer)
···
18
merlin-lib.query_commands
19
merlin-lib.ocaml_parsing
20
findlib
21
+
findlib.top
22
+
)
23
(preprocess
24
(per_module
25
((action
···
35
(modules worker findlibish jslib)
36
(preprocess
37
(pps js_of_ocaml-ppx))
38
+
(libraries
39
+
js_top_worker
40
+
js_of_ocaml-ppx
41
+
js_of_ocaml-toplevel
42
+
logs.browser
43
+
uri
44
+
angstrom
45
+
findlib
46
+
fpath))
47
48
(ocamllex uTop_lexer)
+145
-83
lib/findlibish.ml
+145
-83
lib/findlibish.ml
···
1
(* Kinda findlib, sorta *)
2
3
-
4
type library = {
5
name : string;
6
meta_uri : Uri.t;
7
archive_name : string option;
8
dir : string option;
9
deps : string list;
10
mutable loaded : bool;
11
}
12
13
-
let read_libraries_from_pkg_defs ~library_name meta_uri pkg_defs =
14
try
15
let archive_filename =
16
try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
17
with _ -> (
···
21
22
let deps_str = Fl_metascanner.lookup "requires" [] pkg_defs in
23
let deps = Astring.String.fields ~empty:false deps_str in
24
-
let dir =
25
List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
26
in
27
-
let dir = Option.map (fun d -> d.Fl_metascanner.def_value) dir in
28
let archive_name =
29
Option.bind archive_filename (fun a ->
30
let file_name_len = String.length a in
31
if file_name_len > 0 then Some (Filename.chop_extension a) else None)
32
in
33
-
[ { name = library_name; archive_name; dir; deps; meta_uri; loaded=false } ]
34
-
with Not_found -> []
35
-
36
37
type t = library list
38
···
41
let fetch_dynamic_cmis url =
42
match Jslib.sync_get url with
43
| None -> Error (`Msg "Failed to fetch dynamic cmis")
44
-
| Some json ->
45
-
let rpc = Jsonrpc.of_string json in
46
-
Rpcmarshal.unmarshal Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis rpc
47
48
let init findlib_index : t =
49
-
let findlib_metas =
50
match Jslib.sync_get findlib_index with
51
| None -> []
52
-
| Some txt ->
53
-
Astring.String.fields ~empty:false txt
54
in
55
-
let metas = List.filter_map (fun x ->
56
-
match Jslib.sync_get x with
57
-
| Some meta -> Some (x, meta)
58
-
| None -> None) findlib_metas in
59
-
List.flatten @@ List.filter_map (fun (x, meta) ->
60
-
match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference x with
61
-
| Ok uri -> (
62
-
Jslib.log "Parsed uri: %s" (Uri.path uri);
63
-
let path = Uri.path uri in
64
-
let file = Fpath.v path in
65
-
let base_library_name =
66
-
if Fpath.basename file = "META" then Fpath.parent file |> Fpath.basename
67
-
else Fpath.get_ext file
68
-
in
69
70
-
let lexing = Lexing.from_string meta in
71
-
try
72
-
let meta = Fl_metascanner.parse_lexing lexing in
73
-
let rec extract_name_and_archive ~prefix
74
-
((name, pkg_expr) : string * Fl_metascanner.pkg_expr) =
75
-
let library_name = prefix ^ "." ^ name in
76
-
let libraries =
77
-
read_libraries_from_pkg_defs ~library_name uri pkg_expr.pkg_defs
78
-
in
79
-
let child_libraries =
80
-
pkg_expr.pkg_children
81
-
|> List.map (extract_name_and_archive ~prefix:library_name)
82
-
|> List.flatten
83
-
in
84
-
libraries @ child_libraries
85
-
in
86
-
let libraries =
87
-
read_libraries_from_pkg_defs ~library_name:base_library_name uri meta.pkg_defs
88
-
in
89
-
let libraries =
90
-
libraries
91
-
@ (meta.pkg_children
92
-
|> List.map (extract_name_and_archive ~prefix:base_library_name)
93
-
|> List.flatten) in
94
-
Some libraries
95
-
with _ ->
96
-
Jslib.log "Failed to parse meta: %s" (Uri.path uri);
97
-
None)
98
-
| Error m ->
99
-
Jslib.log "Failed to parse uri: %s" m; None) metas
100
-
101
102
let require v packages =
103
-
let rec require dcss package : Js_top_worker_rpc.Toplevel_api_gen.dynamic_cmis list =
104
match List.find (fun lib -> lib.name = package) v with
105
| exception Not_found ->
106
-
Jslib.log "Package %s not found" package;
107
-
dcss
108
| lib ->
109
-
if lib.loaded
110
-
then dcss
111
-
else begin
112
-
let dep_dcs = List.fold_left require dcss lib.deps in
113
-
let path = Uri.path lib.meta_uri in
114
-
let dir = Fpath.v path |> Fpath.parent in
115
-
let dcs = Fpath.(dir / dcs_filename |> to_string) in
116
-
let uri = Uri.with_path lib.meta_uri dcs in
117
-
match fetch_dynamic_cmis (Uri.to_string uri) with
118
-
| Ok dcs ->
119
-
let () = match lib.archive_name with
120
-
| None -> ()
121
-
| Some archive ->
122
-
let dir = match lib.dir with None -> dir | Some d -> Fpath.append dir (Fpath.v d) in
123
-
let archive_js = Fpath.(dir / (archive ^ ".cma.js") |> to_string) in
124
-
Js_of_ocaml.Worker.import_scripts [(Uri.with_path uri archive_js |> Uri.to_string)];
125
-
lib.loaded <- true
126
in
127
-
dcs :: dep_dcs
128
-
| Error (`Msg m) ->
129
-
Jslib.log "Failed to unmarshal dynamic_cms from url %s: %s" (Uri.to_string uri) m;
130
-
dcss
131
-
end
132
in
133
List.fold_left require [] packages
···
1
(* Kinda findlib, sorta *)
2
3
type library = {
4
name : string;
5
meta_uri : Uri.t;
6
archive_name : string option;
7
dir : string option;
8
deps : string list;
9
+
children : library list;
10
mutable loaded : bool;
11
}
12
13
+
let rec flatten_libs libs =
14
+
let handle_lib l =
15
+
let children = flatten_libs l.children in
16
+
l :: children
17
+
in
18
+
List.map handle_lib libs |> List.flatten
19
+
20
+
let preloaded =
21
+
[
22
+
"logs";
23
+
"js_top_worker-rpc";
24
+
"js_of_ocaml-compiler";
25
+
"js_of_ocaml-ppx";
26
+
"astring";
27
+
"mime_printer";
28
+
"compiler-libs.common";
29
+
"compiler-libs.toplevel";
30
+
"merlin-lib.kernel";
31
+
"merlin-lib.utils";
32
+
"merlin-lib.query_protocol";
33
+
"merlin-lib.query_commands";
34
+
"merlin-lib.ocaml_parsing";
35
+
"findlib";
36
+
"findlib.top";
37
+
"js_top_worker";
38
+
"js_of_ocaml-ppx";
39
+
"js_of_ocaml-toplevel";
40
+
"logs.browser";
41
+
"uri";
42
+
"angstrom";
43
+
"findlib";
44
+
"fpath";
45
+
]
46
+
47
+
let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
48
try
49
+
let pkg_defs = pkg_expr.Fl_metascanner.pkg_defs in
50
let archive_filename =
51
try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
52
with _ -> (
···
56
57
let deps_str = Fl_metascanner.lookup "requires" [] pkg_defs in
58
let deps = Astring.String.fields ~empty:false deps_str in
59
+
let subdir =
60
List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
61
+
|> Option.map (fun d -> d.Fl_metascanner.def_value)
62
in
63
+
let dir =
64
+
match (dir, subdir) with
65
+
| None, None -> None
66
+
| Some d, None -> Some d
67
+
| None, Some d -> Some d
68
+
| Some d1, Some d2 -> Some (Filename.concat d1 d2)
69
+
in
70
let archive_name =
71
Option.bind archive_filename (fun a ->
72
let file_name_len = String.length a in
73
if file_name_len > 0 then Some (Filename.chop_extension a) else None)
74
in
75
+
let children =
76
+
List.filter_map
77
+
(fun (n, expr) ->
78
+
let library_name = library_name ^ "." ^ n in
79
+
match
80
+
read_libraries_from_pkg_defs ~library_name ~dir meta_uri expr
81
+
with
82
+
| Ok l -> Some l
83
+
| Error (`Msg m) ->
84
+
Jslib.log "Error reading sub-library: %s" m;
85
+
None)
86
+
pkg_expr.pkg_children
87
+
in
88
+
Ok
89
+
{
90
+
name = library_name;
91
+
archive_name;
92
+
dir;
93
+
deps;
94
+
meta_uri;
95
+
loaded = false;
96
+
children;
97
+
}
98
+
with Not_found -> Error (`Msg "Failed to read libraries from pkg_defs")
99
100
type t = library list
101
···
104
let fetch_dynamic_cmis url =
105
match Jslib.sync_get url with
106
| None -> Error (`Msg "Failed to fetch dynamic cmis")
107
+
| Some json ->
108
+
let rpc = Jsonrpc.of_string json in
109
+
Rpcmarshal.unmarshal
110
+
Js_top_worker_rpc.Toplevel_api_gen.typ_of_dynamic_cmis rpc
111
112
let init findlib_index : t =
113
+
let findlib_metas =
114
match Jslib.sync_get findlib_index with
115
| None -> []
116
+
| Some txt -> Astring.String.fields ~empty:false txt
117
in
118
+
let metas =
119
+
List.filter_map
120
+
(fun x ->
121
+
match Jslib.sync_get x with Some meta -> Some (x, meta) | None -> None)
122
+
findlib_metas
123
+
in
124
+
List.filter_map
125
+
(fun (x, meta) ->
126
+
match Angstrom.parse_string ~consume:All Uri.Parser.uri_reference x with
127
+
| Ok uri -> (
128
+
Jslib.log "Parsed uri: %s" (Uri.path uri);
129
+
let path = Uri.path uri in
130
+
let file = Fpath.v path in
131
+
let base_library_name =
132
+
if Fpath.basename file = "META" then
133
+
Fpath.parent file |> Fpath.basename
134
+
else Fpath.get_ext file
135
+
in
136
137
+
let lexing = Lexing.from_string meta in
138
+
try
139
+
let meta = Fl_metascanner.parse_lexing lexing in
140
+
let libraries =
141
+
read_libraries_from_pkg_defs ~library_name:base_library_name
142
+
~dir:None uri meta
143
+
in
144
+
Result.to_option libraries
145
+
with _ ->
146
+
Jslib.log "Failed to parse meta: %s" (Uri.path uri);
147
+
None)
148
+
| Error m ->
149
+
Jslib.log "Failed to parse uri: %s" m;
150
+
None)
151
+
metas |> flatten_libs
152
153
let require v packages =
154
+
let rec require dcss package :
155
+
Js_top_worker_rpc.Toplevel_api_gen.dynamic_cmis list =
156
match List.find (fun lib -> lib.name = package) v with
157
| exception Not_found ->
158
+
Jslib.log "Package %s not found" package;
159
+
dcss
160
| lib ->
161
+
if lib.loaded then dcss
162
+
else (
163
+
Jslib.log "Loading package %s" lib.name;
164
+
Jslib.log "lib.dir: %s" (Option.value ~default:"None" lib.dir);
165
+
let dep_dcs = List.fold_left require dcss lib.deps in
166
+
let path = Fpath.(v (Uri.path lib.meta_uri) |> parent) in
167
+
let dir =
168
+
match lib.dir with None -> path | Some d -> Fpath.(path // v d)
169
in
170
+
let dcs = Fpath.(dir / dcs_filename |> to_string) in
171
+
let uri = Uri.with_path lib.meta_uri dcs in
172
+
Jslib.log "uri: %s" (Uri.to_string uri);
173
+
match fetch_dynamic_cmis (Uri.to_string uri) with
174
+
| Ok dcs ->
175
+
let () =
176
+
match lib.archive_name with
177
+
| None -> ()
178
+
| Some archive ->
179
+
let archive_js =
180
+
Fpath.(dir / (archive ^ ".cma.js") |> to_string)
181
+
in
182
+
if List.mem lib.name preloaded then ()
183
+
else
184
+
Js_of_ocaml.Worker.import_scripts
185
+
[ Uri.with_path uri archive_js |> Uri.to_string ];
186
+
lib.loaded <- true
187
+
in
188
+
Jslib.log "Finished loading package %s" lib.name;
189
+
dcs :: dep_dcs
190
+
| Error (`Msg m) ->
191
+
Jslib.log "Failed to unmarshal dynamic_cms from url %s: %s"
192
+
(Uri.to_string uri) m;
193
+
dcss)
194
in
195
List.fold_left require [] packages
+154
-122
lib/impl.ml
+154
-122
lib/impl.ml
···
5
6
type captured = { stdout : string; stderr : string }
7
8
-
9
module JsooTopPpx = struct
10
open Js_of_ocaml_compiler.Stdlib
11
12
-
let ppx_rewriters = ref [fun _ -> Ppx_js.mapper]
13
14
-
let () = Ast_mapper.register_function := fun _ f -> ppx_rewriters := f :: !ppx_rewriters
15
16
let preprocess_structure str =
17
let open Ast_mapper in
18
-
Printf.eprintf "Rewriting...\n%!";
19
List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
20
let mapper = ppx_rewriter [] in
21
mapper.structure mapper str)
···
31
match phrase with
32
| Ptop_def str -> Ptop_def (preprocess_structure str)
33
| Ptop_dir _ as x -> x
34
-
35
end
36
module type S = sig
37
type findlib_t
38
val capture : (unit -> 'a) -> unit -> captured * 'a
39
val create_file : name:string -> content:string -> unit
40
val sync_get : string -> string option
41
-
42
val import_scripts : string list -> unit
43
-
val init_function : string -> (unit -> unit )
44
-
45
val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
46
-
47
val findlib_init : string -> findlib_t
48
-
49
val require : findlib_t -> string list -> Toplevel_api_gen.dynamic_cmis list
50
end
51
···
148
let execute printval ?pp_code ?highlight_location pp_answer s =
149
let s =
150
let l = String.length s in
151
-
if String.sub s (l-2) 2 = ";;" then s else s ^ ";;" in
152
let lb = Lexing.from_function (refill_lexbuf s (ref 0) pp_code) in
153
(try
154
while true do
···
219
let dirs = get_paths () in
220
reset ();
221
List.iter (fun p -> prepend_dir (Dir.create p)) dirs
222
-
223
let add_dynamic_cmis dcs =
224
let fetch filename =
225
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
···
233
(fun name ->
234
let filename = filename_of_module name in
235
match fetch (filename_of_module name) with
236
-
| Some content ->
237
let name = Filename.(concat path filename) in
238
-
(try S.create_file ~name ~content with _ -> ())
239
| None -> ())
240
dcs.dcs_toplevel_modules;
241
···
247
(* Check if it's already been downloaded. This will be the
248
case for all toplevel cmis. Also check whether we're supposed
249
to handle this cmi *)
250
-
(if Sys.file_exists fs_name then
251
-
Logs.info (fun m -> m "Found: %s" fs_name));
252
-
(if
253
-
(not (Sys.file_exists fs_name))
254
-
&& List.exists
255
-
(fun prefix -> String.starts_with ~prefix filename)
256
-
dcs.dcs_file_prefixes
257
-
then (
258
-
Logs.info (fun m -> m "Fetching %s\n%!" filename);
259
-
match fetch filename with
260
-
| Some x ->
261
-
S.create_file ~name:fs_name ~content:x;
262
-
(* At this point we need to tell merlin that the dir contents
263
have changed *)
264
-
if s = "merl" then reset_dirs () else reset_dirs_comp ()
265
-
| None ->
266
-
Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
267
-
(Filename.concat dcs.Toplevel_api_gen.dcs_url filename)));
268
old_loader ~unit_name
269
in
270
let furl = "file://" in
271
let l = String.length furl in
272
-
if String.length dcs.dcs_url > l && String.sub dcs.dcs_url 0 l = furl then begin
273
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
274
Topdirs.dir_directory path
275
-
end else begin
276
let open Persistent_env.Persistent_signature in
277
let old_loader = !load in
278
-
load := (new_load ~s:"comp" ~old_loader);
279
280
let open Ocaml_typing.Persistent_env.Persistent_signature in
281
let old_loader = !load in
282
-
load := (new_load ~s:"merl" ~old_loader)
283
-
end
284
285
let init (init_libs : Toplevel_api_gen.init_libs) =
286
try
···
290
findlib_v := Some (S.findlib_init init_libs.findlib_index);
291
292
(match S.get_stdlib_dcs init_libs.stdlib_dcs with
293
-
|[dcs] -> add_dynamic_cmis dcs
294
| _ -> ());
295
Clflags.no_check_prims := true;
296
List.iter
···
304
List.iter add_dynamic_cmis init_libs.cmis.dynamic_cmis;
305
306
S.import_scripts
307
-
(List.map (fun cma -> cma.Toplevel_api_gen.url) init_libs.cmas);
308
309
requires := init_libs.findlib_requires;
310
functions :=
311
Some
312
(List.map
313
-
(fun func_name ->
314
-
Logs.info (fun m -> m "Function: %s" func_name);
315
-
S.init_function func_name)
316
-
(List.map (fun cma -> cma.Toplevel_api_gen.fn) init_libs.cmas));
317
-
(*
318
-
*)
319
functions := Some [];
320
Logs.info (fun m -> m "init() finished");
321
···
329
Logs.info (fun m -> m "setup() ...");
330
331
let o =
332
-
333
-
(try
334
match !functions with
335
| Some l -> setup l ()
336
| None -> failwith "Error: toplevel has not been initialised"
337
-
with
338
-
| Persistent_env.Error e ->
339
-
Persistent_env.report_error Format.err_formatter e;
340
-
let err = Format.asprintf "%a" Persistent_env.report_error e in
341
-
failwith ("Error: " ^ err)
342
-
| Env.Error e ->
343
-
Env.report_error Format.err_formatter e;
344
-
let err = Format.asprintf "%a" Env.report_error e in
345
-
failwith ("Error: " ^ err))
346
-
in
347
-
348
-
let dcs = (match !findlib_v with
349
-
| Some v ->
350
-
S.require v !requires
351
-
| None -> []) in
352
List.iter add_dynamic_cmis dcs;
353
354
Logs.info (fun m -> m "setup() finished");
···
439
440
let compile_js (id : string option) prog =
441
try
442
-
443
let l = Lexing.from_string prog in
444
let phr = Parse.toplevel_phrase l in
445
Typecore.reset_delayed_checks ();
···
490
cu_debugsize = 0;
491
}
492
in
493
-
494
let fmt = Js_of_ocaml_compiler.Pretty_print.to_buffer b in
495
(* Symtable.patch_object code reloc;
496
Symtable.check_global_initialized reloc;
···
505
let ic = open_in "/tmp/test.cmo" in
506
let p = Js_of_ocaml_compiler.Parse_bytecode.from_cmo cmo ic in
507
let wrap_with_fun =
508
-
match id with
509
-
| Some id -> `Named id
510
-
| None -> `Iife
511
in
512
-
Js_of_ocaml_compiler.Driver.f' ~standalone:false ~wrap_with_fun ~link:`No
513
-
fmt p.debug p.code;
514
Format.(pp_print_flush std_formatter ());
515
Format.(pp_print_flush err_formatter ());
516
flush stdout;
···
521
with e -> IdlM.ErrM.return ("Exception: %s" ^ Printexc.to_string e)
522
523
let handle_toplevel stripped =
524
-
if String.length stripped < 2 || stripped.[0] <> '#' || stripped.[1] <> ' ' then begin
525
-
Printf.eprintf "Warning, ignoring toplevel block without a leading '# '.\n";
526
-
IdlM.ErrM.return { Toplevel_api_gen.script=stripped; mime_vals=[] }
527
-
end else begin
528
let s = String.sub stripped 2 (String.length stripped - 2) in
529
let list = Ocamltop.parse_toplevel s in
530
let buf = Buffer.create 1024 in
531
-
let mime_vals = List.fold_left (fun acc (phr, _output) ->
532
-
let new_output = execute phr |> IdlM.T.get |> M.run |> Result.get_ok in
533
-
Printf.bprintf buf "# %s\n" phr;
534
-
let r = (Option.to_list new_output.stdout) @ (Option.to_list new_output.stderr) @ (Option.to_list new_output.caml_ppf) in
535
-
let r = List.concat_map (fun l -> Astring.String.cuts ~sep:"\n" l) r in
536
-
List.iter (fun x -> Printf.bprintf buf " %s\n" x) r;
537
-
let mime_vals = new_output.mime_vals in
538
-
acc @ mime_vals
539
-
) [] list in
540
let content_txt = Buffer.contents buf in
541
-
let content_txt = String.sub content_txt 0 (String.length content_txt - 1) in
542
-
let result = { Toplevel_api_gen.script=content_txt; mime_vals } in
543
IdlM.ErrM.return result
544
-
end
545
-
546
-
let exec_toplevel (phrase : string) =
547
-
handle_toplevel phrase
548
549
let config () =
550
let path =
···
658
659
let complete_prefix source position =
660
let source = Merlin_kernel.Msource.make source in
661
-
let map_kind : [`Value|`Constructor|`Variant|`Label|
662
-
`Module|`Modtype|`Type|`MethodCall|`Keyword] -> Toplevel_api_gen.kind_ty = function
663
| `Value -> Value
664
| `Constructor -> Constructor
665
| `Variant -> Variant
···
668
| `Modtype -> Modtype
669
| `Type -> Type
670
| `MethodCall -> MethodCall
671
-
| `Keyword -> Keyword in
672
let position =
673
match position with
674
| Toplevel_api_gen.Start -> `Start
675
| Offset x -> `Offset x
676
| Logical (x, y) -> `Logical (x, y)
677
-
| End -> `End in
678
match Completion.at_pos source position with
679
| Some (from, to_, compl) ->
680
let entries =
681
-
List.map (fun (entry : Query_protocol.Compl.entry) ->
682
-
{
683
-
Toplevel_api_gen.name = entry.name;
684
-
kind = map_kind entry.kind;
685
-
desc = entry.desc;
686
-
info = entry.info;
687
-
deprecated = entry.deprecated;
688
-
} ) compl.entries in
689
IdlM.ErrM.return { Toplevel_api_gen.from; to_; entries }
690
| None ->
691
IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
···
699
let errors =
700
wdispatch source query
701
|> StdLabels.List.map
702
-
~f:(fun
703
-
(Ocaml_parsing.Location.{ kind; main = _; sub; source } as error)
704
-
->
705
-
let of_sub sub =
706
-
Ocaml_parsing.Location.print_sub_msg Format.str_formatter sub;
707
-
String.trim (Format.flush_str_formatter ())
708
-
in
709
-
let loc = Ocaml_parsing.Location.loc_of_report error in
710
-
let main =
711
-
Format.asprintf "@[%a@]" Ocaml_parsing.Location.print_main error
712
-
|> String.trim
713
-
in
714
-
{
715
-
Toplevel_api_gen.kind;
716
-
loc;
717
-
main;
718
-
sub = StdLabels.List.map ~f:of_sub sub;
719
-
source;
720
-
})
721
in
722
IdlM.ErrM.return errors
723
with e ->
···
730
| Toplevel_api_gen.Start -> `Start
731
| Offset x -> `Offset x
732
| Logical (x, y) -> `Logical (x, y)
733
-
| End -> `End in
734
let source = Merlin_kernel.Msource.make source in
735
let query = Query_protocol.Type_enclosing (None, position, None) in
736
let enclosing = wdispatch source query in
737
-
let map_index_or_string = function | `Index i -> Toplevel_api_gen.Index i | `String s -> String s in
738
-
let map_tail_position = function | `No -> Toplevel_api_gen.No | `Tail_position -> Tail_position | `Tail_call -> Tail_call in
739
-
let enclosing = List.map (fun (x,y,z) -> (x,map_index_or_string y,map_tail_position z)) enclosing in
740
IdlM.ErrM.return enclosing
741
end
···
5
6
type captured = { stdout : string; stderr : string }
7
8
module JsooTopPpx = struct
9
open Js_of_ocaml_compiler.Stdlib
10
11
+
let ppx_rewriters = ref [ (fun _ -> Ppx_js.mapper) ]
12
13
+
let () =
14
+
Ast_mapper.register_function :=
15
+
fun _ f -> ppx_rewriters := f :: !ppx_rewriters
16
17
let preprocess_structure str =
18
let open Ast_mapper in
19
+
Printf.eprintf "Rewriting...\n%!";
20
List.fold_right !ppx_rewriters ~init:str ~f:(fun ppx_rewriter str ->
21
let mapper = ppx_rewriter [] in
22
mapper.structure mapper str)
···
32
match phrase with
33
| Ptop_def str -> Ptop_def (preprocess_structure str)
34
| Ptop_dir _ as x -> x
35
end
36
+
37
module type S = sig
38
type findlib_t
39
+
40
val capture : (unit -> 'a) -> unit -> captured * 'a
41
val create_file : name:string -> content:string -> unit
42
val sync_get : string -> string option
43
val import_scripts : string list -> unit
44
+
val init_function : string -> unit -> unit
45
val get_stdlib_dcs : string -> Toplevel_api_gen.dynamic_cmis list
46
val findlib_init : string -> findlib_t
47
val require : findlib_t -> string list -> Toplevel_api_gen.dynamic_cmis list
48
end
49
···
146
let execute printval ?pp_code ?highlight_location pp_answer s =
147
let s =
148
let l = String.length s in
149
+
if String.sub s (l - 2) 2 = ";;" then s else s ^ ";;"
150
+
in
151
let lb = Lexing.from_function (refill_lexbuf s (ref 0) pp_code) in
152
(try
153
while true do
···
218
let dirs = get_paths () in
219
reset ();
220
List.iter (fun p -> prepend_dir (Dir.create p)) dirs
221
+
222
let add_dynamic_cmis dcs =
223
let fetch filename =
224
let url = Filename.concat dcs.Toplevel_api_gen.dcs_url filename in
···
232
(fun name ->
233
let filename = filename_of_module name in
234
match fetch (filename_of_module name) with
235
+
| Some content -> (
236
let name = Filename.(concat path filename) in
237
+
try S.create_file ~name ~content with _ -> ())
238
| None -> ())
239
dcs.dcs_toplevel_modules;
240
···
246
(* Check if it's already been downloaded. This will be the
247
case for all toplevel cmis. Also check whether we're supposed
248
to handle this cmi *)
249
+
if Sys.file_exists fs_name then Logs.info (fun m -> m "Found: %s" fs_name);
250
+
if
251
+
(not (Sys.file_exists fs_name))
252
+
&& List.exists
253
+
(fun prefix -> String.starts_with ~prefix filename)
254
+
dcs.dcs_file_prefixes
255
+
then (
256
+
Logs.info (fun m -> m "Fetching %s\n%!" filename);
257
+
match fetch filename with
258
+
| Some x ->
259
+
S.create_file ~name:fs_name ~content:x;
260
+
(* At this point we need to tell merlin that the dir contents
261
have changed *)
262
+
if s = "merl" then reset_dirs () else reset_dirs_comp ()
263
+
| None ->
264
+
Printf.eprintf "Warning: Expected to find cmi at: %s\n%!"
265
+
(Filename.concat dcs.Toplevel_api_gen.dcs_url filename));
266
old_loader ~unit_name
267
in
268
let furl = "file://" in
269
let l = String.length furl in
270
+
if String.length dcs.dcs_url > l && String.sub dcs.dcs_url 0 l = furl then
271
let path = String.sub dcs.dcs_url l (String.length dcs.dcs_url - l) in
272
Topdirs.dir_directory path
273
+
else
274
let open Persistent_env.Persistent_signature in
275
let old_loader = !load in
276
+
load := new_load ~s:"comp" ~old_loader;
277
278
let open Ocaml_typing.Persistent_env.Persistent_signature in
279
let old_loader = !load in
280
+
load := new_load ~s:"merl" ~old_loader
281
282
let init (init_libs : Toplevel_api_gen.init_libs) =
283
try
···
287
findlib_v := Some (S.findlib_init init_libs.findlib_index);
288
289
(match S.get_stdlib_dcs init_libs.stdlib_dcs with
290
+
| [ dcs ] -> add_dynamic_cmis dcs
291
| _ -> ());
292
Clflags.no_check_prims := true;
293
List.iter
···
301
List.iter add_dynamic_cmis init_libs.cmis.dynamic_cmis;
302
303
S.import_scripts
304
+
(List.map (fun cma -> cma.Toplevel_api_gen.url) init_libs.cmas);
305
306
requires := init_libs.findlib_requires;
307
functions :=
308
Some
309
(List.map
310
+
(fun func_name ->
311
+
Logs.info (fun m -> m "Function: %s" func_name);
312
+
S.init_function func_name)
313
+
(List.map (fun cma -> cma.Toplevel_api_gen.fn) init_libs.cmas));
314
+
(* *)
315
functions := Some [];
316
Logs.info (fun m -> m "init() finished");
317
···
325
Logs.info (fun m -> m "setup() ...");
326
327
let o =
328
+
try
329
match !functions with
330
| Some l -> setup l ()
331
| None -> failwith "Error: toplevel has not been initialised"
332
+
with
333
+
| Persistent_env.Error e ->
334
+
Persistent_env.report_error Format.err_formatter e;
335
+
let err = Format.asprintf "%a" Persistent_env.report_error e in
336
+
failwith ("Error: " ^ err)
337
+
| Env.Error e ->
338
+
Env.report_error Format.err_formatter e;
339
+
let err = Format.asprintf "%a" Env.report_error e in
340
+
failwith ("Error: " ^ err)
341
+
in
342
+
343
+
let dcs =
344
+
match !findlib_v with Some v -> S.require v !requires | None -> []
345
+
in
346
List.iter add_dynamic_cmis dcs;
347
348
Logs.info (fun m -> m "setup() finished");
···
433
434
let compile_js (id : string option) prog =
435
try
436
let l = Lexing.from_string prog in
437
let phr = Parse.toplevel_phrase l in
438
Typecore.reset_delayed_checks ();
···
483
cu_debugsize = 0;
484
}
485
in
486
+
487
let fmt = Js_of_ocaml_compiler.Pretty_print.to_buffer b in
488
(* Symtable.patch_object code reloc;
489
Symtable.check_global_initialized reloc;
···
498
let ic = open_in "/tmp/test.cmo" in
499
let p = Js_of_ocaml_compiler.Parse_bytecode.from_cmo cmo ic in
500
let wrap_with_fun =
501
+
match id with Some id -> `Named id | None -> `Iife
502
in
503
+
Js_of_ocaml_compiler.Driver.f' ~standalone:false ~wrap_with_fun
504
+
~link:`No fmt p.debug p.code;
505
Format.(pp_print_flush std_formatter ());
506
Format.(pp_print_flush err_formatter ());
507
flush stdout;
···
512
with e -> IdlM.ErrM.return ("Exception: %s" ^ Printexc.to_string e)
513
514
let handle_toplevel stripped =
515
+
if String.length stripped < 2 || stripped.[0] <> '#' || stripped.[1] <> ' '
516
+
then (
517
+
Printf.eprintf
518
+
"Warning, ignoring toplevel block without a leading '# '.\n";
519
+
IdlM.ErrM.return { Toplevel_api_gen.script = stripped; mime_vals = [] })
520
+
else
521
let s = String.sub stripped 2 (String.length stripped - 2) in
522
let list = Ocamltop.parse_toplevel s in
523
let buf = Buffer.create 1024 in
524
+
let mime_vals =
525
+
List.fold_left
526
+
(fun acc (phr, _output) ->
527
+
let new_output =
528
+
execute phr |> IdlM.T.get |> M.run |> Result.get_ok
529
+
in
530
+
Printf.bprintf buf "# %s\n" phr;
531
+
let r =
532
+
Option.to_list new_output.stdout
533
+
@ Option.to_list new_output.stderr
534
+
@ Option.to_list new_output.caml_ppf
535
+
in
536
+
let r =
537
+
List.concat_map (fun l -> Astring.String.cuts ~sep:"\n" l) r
538
+
in
539
+
List.iter (fun x -> Printf.bprintf buf " %s\n" x) r;
540
+
let mime_vals = new_output.mime_vals in
541
+
acc @ mime_vals)
542
+
[] list
543
+
in
544
let content_txt = Buffer.contents buf in
545
+
let content_txt =
546
+
String.sub content_txt 0 (String.length content_txt - 1)
547
+
in
548
+
let result = { Toplevel_api_gen.script = content_txt; mime_vals } in
549
IdlM.ErrM.return result
550
+
551
+
let exec_toplevel (phrase : string) = handle_toplevel phrase
552
553
let config () =
554
let path =
···
662
663
let complete_prefix source position =
664
let source = Merlin_kernel.Msource.make source in
665
+
let map_kind :
666
+
[ `Value
667
+
| `Constructor
668
+
| `Variant
669
+
| `Label
670
+
| `Module
671
+
| `Modtype
672
+
| `Type
673
+
| `MethodCall
674
+
| `Keyword ] ->
675
+
Toplevel_api_gen.kind_ty = function
676
| `Value -> Value
677
| `Constructor -> Constructor
678
| `Variant -> Variant
···
681
| `Modtype -> Modtype
682
| `Type -> Type
683
| `MethodCall -> MethodCall
684
+
| `Keyword -> Keyword
685
+
in
686
let position =
687
match position with
688
| Toplevel_api_gen.Start -> `Start
689
| Offset x -> `Offset x
690
| Logical (x, y) -> `Logical (x, y)
691
+
| End -> `End
692
+
in
693
match Completion.at_pos source position with
694
| Some (from, to_, compl) ->
695
let entries =
696
+
List.map
697
+
(fun (entry : Query_protocol.Compl.entry) ->
698
+
{
699
+
Toplevel_api_gen.name = entry.name;
700
+
kind = map_kind entry.kind;
701
+
desc = entry.desc;
702
+
info = entry.info;
703
+
deprecated = entry.deprecated;
704
+
})
705
+
compl.entries
706
+
in
707
IdlM.ErrM.return { Toplevel_api_gen.from; to_; entries }
708
| None ->
709
IdlM.ErrM.return { Toplevel_api_gen.from = 0; to_ = 0; entries = [] }
···
717
let errors =
718
wdispatch source query
719
|> StdLabels.List.map
720
+
~f:(fun
721
+
(Ocaml_parsing.Location.{ kind; main = _; sub; source } as
722
+
error)
723
+
->
724
+
let of_sub sub =
725
+
Ocaml_parsing.Location.print_sub_msg Format.str_formatter sub;
726
+
String.trim (Format.flush_str_formatter ())
727
+
in
728
+
let loc = Ocaml_parsing.Location.loc_of_report error in
729
+
let main =
730
+
Format.asprintf "@[%a@]" Ocaml_parsing.Location.print_main
731
+
error
732
+
|> String.trim
733
+
in
734
+
{
735
+
Toplevel_api_gen.kind;
736
+
loc;
737
+
main;
738
+
sub = StdLabels.List.map ~f:of_sub sub;
739
+
source;
740
+
})
741
in
742
IdlM.ErrM.return errors
743
with e ->
···
750
| Toplevel_api_gen.Start -> `Start
751
| Offset x -> `Offset x
752
| Logical (x, y) -> `Logical (x, y)
753
+
| End -> `End
754
+
in
755
let source = Merlin_kernel.Msource.make source in
756
let query = Query_protocol.Type_enclosing (None, position, None) in
757
let enclosing = wdispatch source query in
758
+
let map_index_or_string = function
759
+
| `Index i -> Toplevel_api_gen.Index i
760
+
| `String s -> String s
761
+
in
762
+
let map_tail_position = function
763
+
| `No -> Toplevel_api_gen.No
764
+
| `Tail_position -> Tail_position
765
+
| `Tail_call -> Tail_call
766
+
in
767
+
let enclosing =
768
+
List.map
769
+
(fun (x, y, z) -> (x, map_index_or_string y, map_tail_position z))
770
+
enclosing
771
+
in
772
IdlM.ErrM.return enclosing
773
end
-1
lib/jslib.ml
-1
lib/jslib.ml
+7
-6
lib/ocamltop.ml
+7
-6
lib/ocamltop.ml
···
2
if !p = String.length s then 0
3
else
4
let len' =
5
-
try (String.index_from s !p '\n' - !p + 1)
6
-
with _ -> (String.length s - !p)
7
in
8
let len'' = min len len' in
9
String.blit s !p buffer 0 len'';
···
11
len''
12
13
let parse_toplevel s =
14
-
let s = s in
15
let lexbuf = Lexing.from_string s in
16
let rec loop pos =
17
let _phr = !Toploop.parse_toplevel_phrase lexbuf in
18
let new_pos = Lexing.lexeme_end lexbuf in
19
let phr = String.sub s pos (new_pos - pos) in
20
-
let (cont, output) = Toplexer.entry lexbuf in
21
let new_pos = Lexing.lexeme_end lexbuf in
22
-
if cont then (phr, output) :: loop new_pos else [(phr, output)]
23
in
24
-
loop 0
···
2
if !p = String.length s then 0
3
else
4
let len' =
5
+
try String.index_from s !p '\n' - !p + 1 with _ -> String.length s - !p
6
in
7
let len'' = min len len' in
8
String.blit s !p buffer 0 len'';
···
10
len''
11
12
let parse_toplevel s =
13
+
Logs.warn (fun m -> m "Parsing toplevel phrases");
14
let lexbuf = Lexing.from_string s in
15
let rec loop pos =
16
let _phr = !Toploop.parse_toplevel_phrase lexbuf in
17
let new_pos = Lexing.lexeme_end lexbuf in
18
let phr = String.sub s pos (new_pos - pos) in
19
+
let cont, is_legacy, output = Toplexer.entry lexbuf in
20
+
if is_legacy then
21
+
Logs.warn (fun m -> m "Warning: Legacy toplevel output detected");
22
let new_pos = Lexing.lexeme_end lexbuf in
23
+
if cont then (phr, output) :: loop new_pos else [ (phr, output) ]
24
in
25
+
loop 0
+32
-9
lib/toplexer.mll
+32
-9
lib/toplexer.mll
···
2
3
rule entry = parse
4
| (_ # '\n')* "\n" {
5
-
output_line [] lexbuf
6
}
7
-
| _ | eof { false, [] }
8
9
-
and output_line acc = parse
10
-
| " " ((_ # '\n')* as line) "\n" {
11
-
output_line (line :: acc) lexbuf
12
}
13
| "# " {
14
-
true, List.rev acc
15
}
16
| eof {
17
-
false, List.rev acc
18
}
19
-
| _ {
20
-
false, List.rev acc
21
}
···
2
3
rule entry = parse
4
| (_ # '\n')* "\n" {
5
+
line_prefix [] lexbuf
6
}
7
+
| _ | eof { false, false, [] }
8
9
+
and line_prefix acc = parse
10
+
| " " {
11
+
line acc lexbuf
12
}
13
| "# " {
14
+
true, false, List.rev acc
15
+
}
16
+
| _ as c {
17
+
output_line_legacy c acc lexbuf
18
}
19
| eof {
20
+
false, false, List.rev acc
21
+
}
22
+
23
+
and line acc = parse
24
+
| ((_ # '\n')* as line) "\n" {
25
+
line_prefix (line :: acc) lexbuf
26
}
27
+
| ((_ # '\n')* as line) eof {
28
+
false, false, List.rev (line :: acc)
29
+
}
30
+
31
+
and output_line_legacy c acc = parse
32
+
| ((_ # '\n')* as line) "\n# " {
33
+
true, true, List.rev ((String.make 1 c ^ line) :: acc)
34
}
35
+
| ((_ # '\n')* as line) "\n" (_ as c') {
36
+
output_line_legacy c' ((String.make 1 c ^ line) :: acc) lexbuf
37
+
}
38
+
| (_ # '\n')* as line eof {
39
+
false, true, List.rev ((String.make 1 c ^ line) :: acc)
40
+
}
41
+
| eof {
42
+
false, true, List.rev ((String.make 1 c) :: acc)
43
+
}
44
+
+12
-14
lib/uTop.mli
+12
-14
lib/uTop.mli
···
21
(** {6 Parsing} *)
22
23
type location = int * int
24
-
(** Type of a string-location. It is composed of a start and stop
25
-
offsets (in bytes). *)
26
27
type lines = { start : int; stop : int }
28
(** Type for a range of lines in a buffer from start to stop. *)
···
57
58
val parse_toplevel_phrase_default :
59
string -> bool -> Parsetree.toplevel_phrase result
60
-
(** The default parser for toplevel phrases. It uses the standard ocaml parser. *)
61
62
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
63
(** The default parser. It uses the standard ocaml parser. *)
···
67
toplevel. *)
68
69
val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf
70
-
(** [lexbuf_of_string eof str] is the same as [Lexing.from_string
71
-
str]
72
-
except that if the lexer reach the end of [str] then [eof] is set to [true]. *)
73
74
(** {6 Helpers} *)
75
···
78
prints as a string. *)
79
80
val get_ocaml_error_message : exn -> location * string * lines option
81
-
(** [get_ocaml_error_message exn] returns the location and error
82
-
message for the exception [exn] which must be an exception from
83
-
the compiler. *)
84
85
val check_phrase :
86
Parsetree.toplevel_phrase ->
87
(location list * string * lines option list) option
88
-
(** [check_phrase phrase] checks that [phrase] can be executed
89
-
without typing or compilation errors. It returns [None] if
90
-
[phrase] is OK and an error message otherwise.
91
-
If the result is [None] it is guaranteed that
92
-
[Toploop.execute_phrase] won't raise any exception. *)
93
94
val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a
95
(** [collect_formatters buf pps f] executes [f] and redirect everything it
···
21
(** {6 Parsing} *)
22
23
type location = int * int
24
+
(** Type of a string-location. It is composed of a start and stop offsets (in
25
+
bytes). *)
26
27
type lines = { start : int; stop : int }
28
(** Type for a range of lines in a buffer from start to stop. *)
···
57
58
val parse_toplevel_phrase_default :
59
string -> bool -> Parsetree.toplevel_phrase result
60
+
(** The default parser for toplevel phrases. It uses the standard ocaml parser.
61
+
*)
62
63
val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result
64
(** The default parser. It uses the standard ocaml parser. *)
···
68
toplevel. *)
69
70
val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf
71
+
(** [lexbuf_of_string eof str] is the same as [Lexing.from_string str] except
72
+
that if the lexer reach the end of [str] then [eof] is set to [true]. *)
73
74
(** {6 Helpers} *)
75
···
78
prints as a string. *)
79
80
val get_ocaml_error_message : exn -> location * string * lines option
81
+
(** [get_ocaml_error_message exn] returns the location and error message for the
82
+
exception [exn] which must be an exception from the compiler. *)
83
84
val check_phrase :
85
Parsetree.toplevel_phrase ->
86
(location list * string * lines option list) option
87
+
(** [check_phrase phrase] checks that [phrase] can be executed without typing or
88
+
compilation errors. It returns [None] if [phrase] is OK and an error message
89
+
otherwise. If the result is [None] it is guaranteed that
90
+
[Toploop.execute_phrase] won't raise any exception. *)
91
92
val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a
93
(** [collect_formatters buf pps f] executes [f] and redirect everything it
+2
-8
lib/worker.ml
+2
-8
lib/worker.ml
···
1
open Js_top_worker_rpc
2
open Js_top_worker
3
-
4
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
5
6
(* OCamlorg toplevel in a web worker
···
54
55
let sync_get = Jslib.sync_get
56
let create_file = Js_of_ocaml.Sys_js.create_file
57
-
58
-
let get_stdlib_dcs uri =
59
-
Findlibish.fetch_dynamic_cmis uri |> Result.to_list
60
-
61
let import_scripts = Js_of_ocaml.Worker.import_scripts
62
-
63
let findlib_init = Findlibish.init
64
65
let require v = function
···
69
let init_function func_name =
70
let open Js_of_ocaml in
71
let func = Js.Unsafe.js_expr func_name in
72
-
fun () ->
73
-
Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |]
74
end
75
76
module M = Impl.Make (S)
···
1
open Js_top_worker_rpc
2
open Js_top_worker
3
module Server = Toplevel_api_gen.Make (Impl.IdlM.GenServer ())
4
5
(* OCamlorg toplevel in a web worker
···
53
54
let sync_get = Jslib.sync_get
55
let create_file = Js_of_ocaml.Sys_js.create_file
56
+
let get_stdlib_dcs uri = Findlibish.fetch_dynamic_cmis uri |> Result.to_list
57
let import_scripts = Js_of_ocaml.Worker.import_scripts
58
let findlib_init = Findlibish.init
59
60
let require v = function
···
64
let init_function func_name =
65
let open Js_of_ocaml in
66
let func = Js.Unsafe.js_expr func_name in
67
+
fun () -> Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |]
68
end
69
70
module M = Impl.Make (S)
+25
test/cram/simple.t/run.t
+25
test/cram/simple.t/run.t
···
···
1
+
$ ./script.sh
2
+
unix_worker: [INFO] init()
3
+
unix_worker: [INFO] init() finished
4
+
N
5
+
unix_worker: [INFO] setup() ...
6
+
unix_worker: [INFO] Setup complete
7
+
unix_worker: [INFO] setup() finished
8
+
{mime_vals:[];stderr:S(error while evaluating #enable "pretty";;
9
+
error while evaluating #disable "shortvar";;);stdout:S(OCaml version 5.1.0
10
+
Unknown directive `enable'.
11
+
Unknown directive `disable'.)}
12
+
unix_worker: [WARNING] Parsing toplevel phrases
13
+
{mime_vals:[];script:S(# Printf.printf "Hello, world\n";;
14
+
Hello, world
15
+
- : unit = ())}
16
+
unix_worker: [WARNING] Parsing toplevel phrases
17
+
unix_worker: [WARNING] Warning: Legacy toplevel output detected
18
+
unix_worker: [WARNING] Warning: Legacy toplevel output detected
19
+
{mime_vals:[];script:S(# let x = 1 + 2;;
20
+
val x : int = 3
21
+
# let x = 2+3;;
22
+
val x : int = 5)}
23
+
unix_worker: [WARNING] Parsing toplevel phrases
24
+
{mime_vals:[];script:S(# let x = 1 + 2;;
25
+
val x : int = 3)}
+4
test/cram/simple.t/s1
+4
test/cram/simple.t/s1
+4
test/cram/simple.t/s2
+4
test/cram/simple.t/s2
+18
test/cram/simple.t/script.sh
+18
test/cram/simple.t/script.sh
···
···
1
+
#!/bin/bash
2
+
3
+
4
+
export OCAMLRUNPARAM=b
5
+
6
+
unix_worker &
7
+
pid=$!
8
+
9
+
sleep 1
10
+
11
+
unix_client init '{ init_libs:[], stdlib_dcs:"", findlib_requires:[], findlib_index:"", cmas:[], cmis:{dynamic_cmis:[], static_cmis:[]}, path:"" }'
12
+
unix_client setup
13
+
unix_client exec_toplevel '# Printf.printf "Hello, world\n";;'
14
+
unix_client exec_toplevel "$(cat s1)"
15
+
unix_client exec_toplevel "$(cat s2)"
16
+
17
+
kill $pid
18
+
+4
test/libtest/dune
+4
test/libtest/dune