this repo has no description
Tidying interface
+315
-98
+12
README.md
+12
README.md
···
1
1
An OCaml toplevel designed to run in a web worker
2
+
3
+
To run the example, the worker needs to be served by an http server rather
4
+
than loaded from the filesystem. Therefore the example may be run in the
5
+
following way:
6
+
7
+
```
8
+
$ dune build
9
+
$ cd _build/default/example
10
+
$ python3 -m http.server 8000
11
+
```
12
+
13
+
and then opening the URL `http://localhost:8000/`
+26
example/dune
+26
example/dune
···
1
+
(executable
2
+
(name example)
3
+
(preprocess
4
+
(pps js_of_ocaml-ppx))
5
+
(modes js)
6
+
(modules example)
7
+
(libraries js_top_worker_client lwt js_of_ocaml))
8
+
9
+
(executable
10
+
(name worker)
11
+
(modes byte)
12
+
(modules worker)
13
+
(libraries js_top_worker))
14
+
15
+
(rule
16
+
(targets worker.js)
17
+
(action
18
+
(run
19
+
%{bin:js_of_ocaml}
20
+
--toplevel
21
+
--pretty
22
+
+toplevel.js
23
+
+dynlink.js
24
+
%{dep:worker.bc}
25
+
-o
26
+
%{targets})))
+37
example/example.ml
+37
example/example.ml
···
1
+
(* Simplest example *)
2
+
open Js_of_ocaml
3
+
open Js_top_worker_rpc
4
+
module W = Js_top_worker_client.W
5
+
6
+
let log s = Firebug.console##log (Js.string s)
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* () = W.init rpc Toplevel_api_gen.{ cmas = []; cmi_urls = [] } in
12
+
Lwt.return (Ok rpc)
13
+
14
+
let log_output (o : Toplevel_api_gen.exec_result) =
15
+
Option.iter (fun s -> log ("stdout: " ^ s)) o.stdout;
16
+
Option.iter (fun s -> log ("stderr: " ^ s)) o.stderr;
17
+
Option.iter (fun s -> log ("sharp_ppf: " ^ s)) o.sharp_ppf;
18
+
Option.iter (fun s -> log ("caml_ppf: " ^ s)) o.caml_ppf
19
+
20
+
let start rpc =
21
+
let ( let* ) = Lwt_result.bind in
22
+
let* o = W.setup rpc () in
23
+
log_output o;
24
+
Lwt.return (Ok o)
25
+
26
+
let exec rpc txt =
27
+
let ( let* ) = Lwt_result.bind in
28
+
let* o = W.exec rpc txt in
29
+
log_output o;
30
+
Lwt.return (Ok o)
31
+
32
+
let _ =
33
+
let ( let* ) = Lwt_result.bind in
34
+
let* rpc = initialise "worker.js" (fun _ -> log "Timeout") in
35
+
let* _ = start rpc in
36
+
let* _ = exec rpc "2*2;;" in
37
+
Lwt.return (Ok ())
+10
example/index.html
+10
example/index.html
+1
example/worker.ml
+1
example/worker.ml
···
1
+
let _ = Js_top_worker.Worker.run ()
+1
-1
idl/dune
+1
-1
idl/dune
+39
idl/js_top_worker_client.mli
+39
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
+
13
+
val start : string -> int -> (unit -> unit) -> rpc
14
+
(** [start url timeout timeout_fn] initialises a web worker from [url] and
15
+
starts communications with it. [timeout] is the number of seconds to wait
16
+
for a response from any RPC before raising an error, and [timeout_fn] is
17
+
called when a timeout occurs. *)
18
+
19
+
module W : sig
20
+
val init :
21
+
rpc ->
22
+
Toplevel_api_gen.init_libs ->
23
+
(unit, Toplevel_api_gen.err) result Lwt.t
24
+
25
+
val setup :
26
+
rpc ->
27
+
unit ->
28
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
29
+
30
+
val exec :
31
+
rpc ->
32
+
string ->
33
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
34
+
35
+
val complete :
36
+
rpc ->
37
+
string ->
38
+
(Toplevel_api_gen.completion_result, Toplevel_api_gen.err) result Lwt.t
39
+
end
+14
-23
idl/toplevel_api.ml
+14
-23
idl/toplevel_api.ml
···
20
20
type completion_result = {
21
21
n : int;
22
22
(** The position in the input string from where the completions may be
23
-
inserted *)
23
+
inserted *)
24
24
completions : string list; (** The list of possible completions *)
25
25
}
26
26
[@@deriving rpcty]
27
27
(** The result returned by a 'complete' call. *)
28
28
29
-
type string_list = string list [@@deriving rpcty]
30
-
(** Used by setup *)
29
+
type cma = {
30
+
url : string; (** URL where the cma is available *)
31
+
fn : string; (** Name of the 'wrapping' function *)
32
+
}
33
+
[@@deriving rpcty]
31
34
32
-
type string_string_list = (string * string) list [@@deriving rpcty]
33
-
(** Used by setup *)
35
+
type init_libs = { cmi_urls : string list; cmas : cma list } [@@deriving rpcty]
34
36
35
37
(** For now we are only using a simple error type *)
36
38
type err = InternalError of string [@@deriving rpcty]
···
63
65
let exec_result_p = Param.mk exec_result
64
66
let completion_p = Param.mk completion_result
65
67
66
-
let cmas =
67
-
Param.mk ~name:"cmas"
68
+
let init_libs =
69
+
Param.mk ~name:"init_libs"
68
70
~description:
69
71
[
70
-
"A list of pairs. The first element of the pair is a urls to a";
71
-
"cma file pre-compiled to javascript. The second item is the";
72
-
"name of the function to be invoked to load the cma file";
73
-
"(ie, the cma was compiled with --wrap-func).";
74
-
"These will be loaded synchronously during the init call.";
72
+
"Libraries to load during the initialisation of the toplevel. ";
73
+
"If the stdlib cmis have not been compiled into the worker this ";
74
+
"MUST include the urls from which they may be fetched";
75
75
]
76
-
string_string_list
77
-
78
-
let cmis =
79
-
Param.mk ~name:"cmis"
80
-
~description:
81
-
[
82
-
"A list of urls of cmi files. These files will be loaded on demand";
83
-
"during evaluation of toplevel phrases.";
84
-
]
85
-
string_list
76
+
init_libs
86
77
87
78
let init =
88
79
declare "init"
89
80
[ "Initialise the toplevel." ]
90
-
(cmas @-> cmis @-> returning unit_p err)
81
+
(init_libs @-> returning unit_p err)
91
82
92
83
let setup =
93
84
declare "setup"
+121
-36
idl/toplevel_api_gen.ml
+121
-36
idl/toplevel_api_gen.ml
···
251
251
{
252
252
n: int
253
253
[@ocaml.doc
254
-
" The position in the input string from where the completions may be\n inserted "];
254
+
" The position in the input string from where the completions may be\n inserted "];
255
255
completions: string list [@ocaml.doc " The list of possible completions "]}
256
256
[@@deriving rpcty][@@ocaml.doc " The result returned by a 'complete' call. "]
257
257
include
···
317
317
and _ = typ_of_completion_result
318
318
and _ = completion_result
319
319
end[@@ocaml.doc "@inline"][@@merlin.hide ]
320
-
type string_list = string list[@@deriving rpcty][@@ocaml.doc
321
-
" Used by setup "]
320
+
type cma =
321
+
{
322
+
url: string [@ocaml.doc " URL where the cma is available "];
323
+
fn: string [@ocaml.doc " Name of the 'wrapping' function "]}[@@deriving
324
+
rpcty]
322
325
include
323
326
struct
324
-
let _ = fun (_ : string_list) -> ()
325
-
let rec typ_of_string_list =
326
-
Rpc.Types.List (let open Rpc.Types in Basic String)
327
-
and string_list =
327
+
let _ = fun (_ : cma) -> ()
328
+
let rec (cma_url : (_, cma) Rpc.Types.field) =
329
+
{
330
+
Rpc.Types.fname = "url";
331
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
332
+
Rpc.Types.fdefault = None;
333
+
Rpc.Types.fdescription = ["URL where the cma is available"];
334
+
Rpc.Types.fversion = None;
335
+
Rpc.Types.fget = (fun _r -> _r.url);
336
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with url = v })
337
+
}
338
+
and (cma_fn : (_, cma) Rpc.Types.field) =
339
+
{
340
+
Rpc.Types.fname = "fn";
341
+
Rpc.Types.field = (let open Rpc.Types in Basic String);
342
+
Rpc.Types.fdefault = None;
343
+
Rpc.Types.fdescription = ["Name of the 'wrapping' function"];
344
+
Rpc.Types.fversion = None;
345
+
Rpc.Types.fget = (fun _r -> _r.fn);
346
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with fn = v })
347
+
}
348
+
and typ_of_cma =
349
+
Rpc.Types.Struct
350
+
({
351
+
Rpc.Types.fields =
352
+
[Rpc.Types.BoxedField cma_url; Rpc.Types.BoxedField cma_fn];
353
+
Rpc.Types.sname = "cma";
354
+
Rpc.Types.version = None;
355
+
Rpc.Types.constructor =
356
+
(fun getter ->
357
+
let open Rresult.R in
358
+
(getter.Rpc.Types.field_get "fn"
359
+
(let open Rpc.Types in Basic String))
360
+
>>=
361
+
(fun cma_fn ->
362
+
(getter.Rpc.Types.field_get "url"
363
+
(let open Rpc.Types in Basic String))
364
+
>>=
365
+
(fun cma_url ->
366
+
return { url = cma_url; fn = cma_fn })))
367
+
} : cma Rpc.Types.structure)
368
+
and cma =
328
369
{
329
-
Rpc.Types.name = "string_list";
330
-
Rpc.Types.description = ["Used by setup"];
331
-
Rpc.Types.ty = typ_of_string_list
370
+
Rpc.Types.name = "cma";
371
+
Rpc.Types.description = [];
372
+
Rpc.Types.ty = typ_of_cma
332
373
}
333
-
let _ = typ_of_string_list
334
-
and _ = string_list
374
+
let _ = cma_url
375
+
and _ = cma_fn
376
+
and _ = typ_of_cma
377
+
and _ = cma
335
378
end[@@ocaml.doc "@inline"][@@merlin.hide ]
336
-
type string_string_list = (string * string) list[@@deriving rpcty][@@ocaml.doc
337
-
" Used by setup "]
379
+
type init_libs = {
380
+
cmi_urls: string list ;
381
+
cmas: cma list }[@@deriving rpcty]
338
382
include
339
383
struct
340
-
let _ = fun (_ : string_string_list) -> ()
341
-
let rec typ_of_string_string_list =
342
-
Rpc.Types.Dict (Rpc.Types.String, (let open Rpc.Types in Basic String))
343
-
and string_string_list =
384
+
let _ = fun (_ : init_libs) -> ()
385
+
let rec (init_libs_cmi_urls : (_, init_libs) Rpc.Types.field) =
386
+
{
387
+
Rpc.Types.fname = "cmi_urls";
388
+
Rpc.Types.field =
389
+
(Rpc.Types.List (let open Rpc.Types in Basic String));
390
+
Rpc.Types.fdefault = None;
391
+
Rpc.Types.fdescription = [];
392
+
Rpc.Types.fversion = None;
393
+
Rpc.Types.fget = (fun _r -> _r.cmi_urls);
394
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with cmi_urls = v })
395
+
}
396
+
and (init_libs_cmas : (_, init_libs) Rpc.Types.field) =
344
397
{
345
-
Rpc.Types.name = "string_string_list";
346
-
Rpc.Types.description = ["Used by setup"];
347
-
Rpc.Types.ty = typ_of_string_string_list
398
+
Rpc.Types.fname = "cmas";
399
+
Rpc.Types.field = (Rpc.Types.List typ_of_cma);
400
+
Rpc.Types.fdefault = None;
401
+
Rpc.Types.fdescription = [];
402
+
Rpc.Types.fversion = None;
403
+
Rpc.Types.fget = (fun _r -> _r.cmas);
404
+
Rpc.Types.fset = (fun v -> fun _s -> { _s with cmas = v })
348
405
}
349
-
let _ = typ_of_string_string_list
350
-
and _ = string_string_list
406
+
and typ_of_init_libs =
407
+
Rpc.Types.Struct
408
+
({
409
+
Rpc.Types.fields =
410
+
[Rpc.Types.BoxedField init_libs_cmi_urls;
411
+
Rpc.Types.BoxedField init_libs_cmas];
412
+
Rpc.Types.sname = "init_libs";
413
+
Rpc.Types.version = None;
414
+
Rpc.Types.constructor =
415
+
(fun getter ->
416
+
let open Rresult.R in
417
+
(getter.Rpc.Types.field_get "cmas"
418
+
(Rpc.Types.List typ_of_cma))
419
+
>>=
420
+
(fun init_libs_cmas ->
421
+
(getter.Rpc.Types.field_get "cmi_urls"
422
+
(Rpc.Types.List
423
+
(let open Rpc.Types in Basic String)))
424
+
>>=
425
+
(fun init_libs_cmi_urls ->
426
+
return
427
+
{
428
+
cmi_urls = init_libs_cmi_urls;
429
+
cmas = init_libs_cmas
430
+
})))
431
+
} : init_libs Rpc.Types.structure)
432
+
and init_libs =
433
+
{
434
+
Rpc.Types.name = "init_libs";
435
+
Rpc.Types.description = [];
436
+
Rpc.Types.ty = typ_of_init_libs
437
+
}
438
+
let _ = init_libs_cmi_urls
439
+
and _ = init_libs_cmas
440
+
and _ = typ_of_init_libs
441
+
and _ = init_libs
351
442
end[@@ocaml.doc "@inline"][@@merlin.hide ]
352
443
type err =
353
444
| InternalError of string [@@ocaml.doc
···
422
513
let phrase_p = Param.mk Types.string
423
514
let exec_result_p = Param.mk exec_result
424
515
let completion_p = Param.mk completion_result
425
-
let cmas =
426
-
Param.mk ~name:"cmas"
427
-
~description:["A list of pairs. The first element of the pair is a urls to a";
428
-
"cma file pre-compiled to javascript. The second item is the";
429
-
"name of the function to be invoked to load the cma file";
430
-
"(ie, the cma was compiled with --wrap-func).";
431
-
"These will be loaded synchronously during the init call."]
432
-
string_string_list
433
-
let cmis =
434
-
Param.mk ~name:"cmis"
435
-
~description:["A list of urls of cmi files. These files will be loaded on demand";
436
-
"during evaluation of toplevel phrases."] string_list
516
+
let init_libs =
517
+
Param.mk ~name:"init_libs"
518
+
~description:["Libraries to load during the initialisation of the toplevel. ";
519
+
"If the stdlib cmis have not been compiled into the worker this ";
520
+
"MUST include the urls from which they may be fetched"]
521
+
init_libs
437
522
let init =
438
523
declare "init" ["Initialise the toplevel."]
439
-
(cmas @-> (cmis @-> (returning unit_p err)))
524
+
(init_libs @-> (returning unit_p err))
440
525
let setup =
441
526
declare "setup"
442
527
["Start the toplevel. Return value is the initial blurb ";
+41
-7
idl/worker_rpc.ml
idl/js_top_worker_client.ml
+41
-7
idl/worker_rpc.ml
idl/js_top_worker_client.ml
···
16
16
waiting : ((Rpc.response, exn) Result.t Lwt_mvar.t * int) Queue.t;
17
17
}
18
18
19
+
type rpc = Rpc.call -> Rpc.response Lwt.t
20
+
19
21
exception Timeout
20
22
21
23
let demux context msg =
···
27
29
let msg : string = Message.Ev.data (Brr.Ev.as_type msg) in
28
30
Lwt_mvar.put mv (Ok (Marshal.from_string msg 0)))
29
31
30
-
let start worker timeout timeout_fn =
31
-
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
32
-
let () =
33
-
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
34
-
in
35
-
context
36
-
37
32
let rpc : context -> Rpc.call -> Rpc.response Lwt.t =
38
33
fun context call ->
39
34
let open Lwt in
···
42
37
let outstanding_execution =
43
38
Brr.G.set_timeout ~ms:context.timeout (fun () ->
44
39
Lwt.async (fun () -> Lwt_mvar.put mv (Error Timeout));
40
+
Worker.terminate context.worker;
45
41
context.timeout_fn ())
46
42
in
47
43
Queue.push (mv, outstanding_execution) context.waiting;
···
52
48
let response = jv in
53
49
Lwt.return response
54
50
| Error exn -> Lwt.fail exn
51
+
52
+
let start url timeout timeout_fn : rpc =
53
+
let worker = Worker.create (Jstr.v url) in
54
+
let context = { worker; timeout; timeout_fn; waiting = Queue.create () } in
55
+
let () =
56
+
Brr.Ev.listen Message.Ev.message (demux context) (Worker.as_target worker)
57
+
in
58
+
rpc context
59
+
60
+
module Rpc_lwt = Idl.Make (Lwt)
61
+
module Wraw = Toplevel_api_gen.Make (Rpc_lwt.GenClient ())
62
+
63
+
module W : sig
64
+
val init :
65
+
rpc ->
66
+
Toplevel_api_gen.init_libs ->
67
+
(unit, Toplevel_api_gen.err) result Lwt.t
68
+
69
+
val setup :
70
+
rpc ->
71
+
unit ->
72
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
73
+
74
+
val exec :
75
+
rpc ->
76
+
string ->
77
+
(Toplevel_api_gen.exec_result, Toplevel_api_gen.err) result Lwt.t
78
+
79
+
val complete :
80
+
rpc ->
81
+
string ->
82
+
(Toplevel_api_gen.completion_result, Toplevel_api_gen.err) result Lwt.t
83
+
end = struct
84
+
let init rpc a = Wraw.init rpc a |> Rpc_lwt.T.get
85
+
let setup rpc a = Wraw.setup rpc a |> Rpc_lwt.T.get
86
+
let exec rpc a = Wraw.exec rpc a |> Rpc_lwt.T.get
87
+
let complete rpc a = Wraw.complete rpc a |> Rpc_lwt.T.get
88
+
end
-26
idl/worker_rpc.mli
-26
idl/worker_rpc.mli
···
1
-
(* Worker_rpc *)
2
-
3
-
(** Functions to facilitate RPC calls to web workers.
4
-
5
-
The assumption made in this module is that RPCs are answered in the order
6
-
they are made. *)
7
-
8
-
type context
9
-
(** Represents the channel used to communicate with the worker *)
10
-
11
-
exception Timeout
12
-
(** When RPC calls take too long, the Lwt promise is set to failed state with
13
-
this exception. *)
14
-
15
-
val start : Brr_webworkers.Worker.t -> int -> (unit -> unit) -> context
16
-
(** [start worker timeout timeout_fn] initialises communications with a web
17
-
worker. [timeout] is the number of seconds to wait for a response from any
18
-
RPC before raising an error, and [timeout_fn] is called when a timeout
19
-
occurs. *)
20
-
21
-
open Js_top_worker_rpc
22
-
23
-
val rpc : context -> Rpc.call -> Rpc.response Lwt.t
24
-
(** [rpc context call] returns a promise containing the result from the worker.
25
-
If we wait longer than the timeout specified in [context] for a response,
26
-
the Lwt promise will fail with exception {!Timeout}. *)
+13
-5
lib/worker.ml
+13
-5
lib/worker.ml
···
1
1
open Js_of_ocaml_toplevel
2
2
open Js_top_worker_rpc
3
3
4
-
let log fmt = Format.kasprintf (fun s -> Js_of_ocaml.(Firebug.console##log (Js.string s))) fmt
4
+
let log fmt =
5
+
Format.kasprintf
6
+
(fun s -> Js_of_ocaml.(Firebug.console##log (Js.string s)))
7
+
fmt
5
8
6
9
(* OCamlorg toplevel in a web worker
7
10
···
176
179
177
180
let functions : (unit -> unit) list option ref = ref None
178
181
179
-
let init cmas cmis =
182
+
let init (init_libs : Toplevel_api_gen.init_libs) =
180
183
let open Js_of_ocaml in
181
184
try
182
185
Clflags.no_check_prims := true;
183
-
let cmi_files = List.map (fun cmi -> (Filename.basename cmi |> Filename.chop_extension, cmi)) cmis in
186
+
let cmi_files =
187
+
List.map
188
+
(fun cmi -> (Filename.basename cmi |> Filename.chop_extension, cmi))
189
+
init_libs.cmi_urls
190
+
in
184
191
let old_loader = !Persistent_env.Persistent_signature.load in
185
192
(Persistent_env.Persistent_signature.load :=
186
193
fun ~unit_name ->
···
198
205
cmi = read_cmi unit_name (Bytes.of_string x);
199
206
}
200
207
| _ -> old_loader ~unit_name);
201
-
Js_of_ocaml.Worker.import_scripts (List.map fst cmas);
208
+
Js_of_ocaml.Worker.import_scripts
209
+
(List.map (fun cma -> cma.Toplevel_api_gen.url) init_libs.cmas);
202
210
functions :=
203
211
Some
204
212
(List.map
···
207
215
let func = Js.Unsafe.js_expr func_name in
208
216
fun () ->
209
217
Js.Unsafe.fun_call func [| Js.Unsafe.inject Dom_html.window |])
210
-
(List.map snd cmas));
218
+
(List.map (fun cma -> cma.Toplevel_api_gen.fn) init_libs.cmas));
211
219
IdlM.ErrM.return ()
212
220
with e ->
213
221
IdlM.ErrM.return_err (Toplevel_api_gen.InternalError (Printexc.to_string e))