Skip to content

Commit 1968e81

Browse files
hhugohhugo
committed
jsoo-top-wrapped
1 parent ae0adf1 commit 1968e81

File tree

11 files changed

+1144
-2
lines changed

11 files changed

+1144
-2
lines changed

‎toplevel/lib/dune‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
(public_name js_of_ocaml-toplevel)
44
(synopsis "Js_of_ocaml toplevel library")
55
(wrapped (transition "Will be removed past 2019-04-01"))
6-
(libraries
6+
(libraries lwt
77
js_of_ocaml-compiler js_of_ocaml bytes
88
compiler-libs.bytecomp compiler-libs.toplevel)
9-
(preprocess (pps js_of_ocaml-ppx)))
9+
(preprocess (pps js_of_ocaml-ppx)))

‎toplevel/lib/jsooTopAsynchronous.ml‎

Lines changed: 301 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,301 @@
1+
(* Js_of_ocaml library
2+
* http://www.ocsigen.org/js_of_ocaml/
3+
* Copyright (C) 2016 OCamlPro
4+
*
5+
* This program is free software; you can redistribute it and/or modify
6+
* it under the terms of the GNU Library General Public License as published by
7+
* the Free Software Foundation, with linking exception;
8+
* either version 2.1 of the License, or (at your option) any later version.
9+
*
10+
* This program is distributed in the hope that it will be useful,
11+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
12+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+
* GNU Library General Public License for more details.
14+
*
15+
* You should have received a copy of the GNU Library General Public License
16+
* along with this program; if not, write to the Free Software
17+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
18+
*)
19+
open Js_of_ocaml
20+
open JsooTopWorkerIntf
21+
22+
type 'a result = 'a JsooTopWrapped.result Lwt.t
23+
24+
let ( >>= ) = Lwt.bind
25+
26+
let ( >>? ) o f =
27+
let open! JsooTopWrapped in
28+
o
29+
>>= function
30+
| Error (err, w) -> Lwt.return (Error (err, w))
31+
| Success (x, w) -> (
32+
f x
33+
>>= function
34+
| Error (err, w') -> Lwt.return (Error (err, w @ w'))
35+
| Success (x, w') -> Lwt.return (Success (x, w @ w')))
36+
37+
let return_success e = Lwt.return (JsooTopWrapped.Success (e, []))
38+
39+
let return_unit_success = return_success ()
40+
41+
(* let return_error e = Lwt.return (JsooTopWrapped.Error (e, [])) *)
42+
(* let return_exn exn = return_error (JsooTopWrapped.error_of_exn exn) *)
43+
44+
(* let wrap pp = *)
45+
(* let buf = Buffer.create 503 in *)
46+
(* let flush () = *)
47+
(* let s = Buffer.contents buf in *)
48+
(* if s <> "" then begin *)
49+
(* Buffer.reset buf; *)
50+
(* pp s *)
51+
(* end in *)
52+
(* Format.make_formatter (Buffer.add_substring buf) flush *)
53+
54+
(* let () = *)
55+
(* Location.register_error_of_exn *)
56+
(* (function *)
57+
(* | Js.Error e -> *)
58+
(* Firebug.console##log(e##stack); *)
59+
(* let msg = Js.to_string e##message in *)
60+
(* Some { Location.msg; if_highlight = msg; sub = []; loc = Location.none } *)
61+
(* | _ -> None) *)
62+
63+
module IntMap = Map.Make (Int)
64+
65+
let map_option f o =
66+
match o with
67+
| None -> None
68+
| Some o -> Some (f o)
69+
70+
let iter_option f o =
71+
match o with
72+
| None -> ()
73+
| Some o -> f o
74+
75+
type u =
76+
| U : 'a msg_ty * 'a JsooTopWrapped.result Lwt.u * 'a JsooTopWrapped.result Lwt.t -> u
77+
78+
type output = string -> unit
79+
80+
type toplevel =
81+
{ cmis_prefix : string
82+
; js_file : string
83+
; mutable imported : string list
84+
; mutable worker : (Js.js_string Js.t, Js.js_string Js.t) Worker.worker Js.t
85+
; mutable wakeners : u IntMap.t
86+
; mutable counter : int
87+
; mutable fds : output IntMap.t
88+
; mutable fd_counter : int
89+
; mutable reset_worker : toplevel -> unit Lwt.t
90+
; mutable after_init : toplevel -> unit Lwt.t
91+
; pp_stdout : output
92+
; pp_stderr : output }
93+
94+
exception Not_equal
95+
96+
let check_equal : type t1 t2. t1 msg_ty -> t2 msg_ty -> (t1, t2) eq =
97+
fun ty1 ty2 ->
98+
match ty1, ty2 with
99+
| Unit, Unit -> Eq
100+
| Bool, Bool -> Eq
101+
| Int, Int -> Eq
102+
| String, String -> Eq
103+
| Unit, _ -> raise Not_equal
104+
| Bool, _ -> raise Not_equal
105+
| Int, _ -> raise Not_equal
106+
| String, _ -> raise Not_equal
107+
108+
let onmessage worker (ev : _ Worker.messageEvent Js.t) =
109+
match Json.unsafe_input ev##.data with
110+
| Write (fd, s) -> (
111+
try
112+
IntMap.find fd worker.fds s;
113+
Js._false
114+
with Not_found ->
115+
Firebug.console##warn (Js.string (Printf.sprintf "Missing channels (%d)" fd));
116+
Js._false)
117+
| ReturnSuccess (id, ty_v, v, w) -> (
118+
try
119+
let (U (ty_u, u, _)) = IntMap.find id worker.wakeners in
120+
let Eq = check_equal ty_u ty_v in
121+
worker.wakeners <- IntMap.remove id worker.wakeners;
122+
Lwt.wakeup u (JsooTopWrapped.Success (v, w));
123+
Js._false
124+
with
125+
| Not_found ->
126+
Firebug.console##warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id));
127+
Js._false
128+
| Not_equal ->
129+
Firebug.console##warn (Js.string (Printf.sprintf "Unexpected wakeners (%d)" id));
130+
Js._false)
131+
| ReturnError (id, e, w) -> (
132+
try
133+
let (U (_, u, _)) = IntMap.find id worker.wakeners in
134+
worker.wakeners <- IntMap.remove id worker.wakeners;
135+
Lwt.wakeup u (JsooTopWrapped.Error (e, w));
136+
Js._false
137+
with Not_found ->
138+
Firebug.console##warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id));
139+
Js._false)
140+
141+
let terminate worker =
142+
(worker.worker)##terminate;
143+
IntMap.iter
144+
(fun id (U (_, _, t)) ->
145+
worker.wakeners <- IntMap.remove id worker.wakeners;
146+
Lwt.cancel t)
147+
worker.wakeners
148+
149+
let never_ending =
150+
(* and not cancellable. *)
151+
fst (Lwt.wait ())
152+
153+
let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
154+
| Init _ -> Unit
155+
| Reset -> Unit
156+
| Check _ -> Unit
157+
| Execute _ -> Bool
158+
| Use_string _ -> Bool
159+
| Use_mod_string _ -> Bool
160+
| Import_scripts _ -> Unit
161+
162+
(** Threads created with [post] will always be wake-uped by
163+
[onmessage] by calling [Lwt.wakeup]. They should never end with
164+
an exception, unless canceled. When canceled, the worker is
165+
killed and a new one is spawned. *)
166+
let rec post : type a. toplevel -> a host_msg -> a JsooTopWrapped.result Lwt.t =
167+
fun worker msg ->
168+
let msg_id = worker.counter in
169+
let msg_ty = ty_of_host_msg msg in
170+
let t, u = Lwt.task () in
171+
Lwt.on_cancel t (fun () -> Lwt.async (fun () -> worker.reset_worker worker));
172+
worker.wakeners <- IntMap.add msg_id (U (msg_ty, u, t)) worker.wakeners;
173+
worker.counter <- msg_id + 1;
174+
(worker.worker)##postMessage (Json.output (msg_id, msg));
175+
t
176+
177+
and do_reset_worker () =
178+
let running = ref true in
179+
fun worker ->
180+
if !running
181+
then (
182+
running := false;
183+
terminate worker;
184+
IntMap.iter
185+
(* GRGR: Peut-on 'cancel' directement le Lwt.u ? *)
186+
(fun _ (U (_, _, t)) -> Lwt.cancel t)
187+
worker.wakeners;
188+
worker.worker <- Worker.create worker.js_file;
189+
worker.fds <-
190+
IntMap.empty
191+
|> IntMap.add 0 (IntMap.find 0 worker.fds)
192+
|> IntMap.add 1 (IntMap.find 1 worker.fds);
193+
worker.fd_counter <- 2;
194+
let imported = worker.imported in
195+
worker.imported <- [];
196+
worker.wakeners <- IntMap.empty;
197+
worker.counter <- 0;
198+
worker.reset_worker <- do_reset_worker ();
199+
(Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker);
200+
Lwt_list.iter_p
201+
(fun name -> import_cmis_js worker name >>= fun _ -> Lwt.return_unit)
202+
imported
203+
>>= fun () ->
204+
post worker @@ Init worker.cmis_prefix
205+
>>= fun _ -> worker.after_init worker >>= fun _ -> Lwt.return_unit)
206+
else Lwt.return_unit
207+
208+
and import_cmis_js worker name =
209+
if List.mem name worker.imported
210+
then return_unit_success
211+
else
212+
let url = worker.cmis_prefix ^ name ^ ".cmis.js" in
213+
post worker @@ Import_scripts [url]
214+
>>? fun () ->
215+
worker.imported <- name :: worker.imported;
216+
return_unit_success
217+
218+
let create
219+
?(cmis_prefix = "")
220+
?(after_init = fun _ -> Lwt.return_unit)
221+
~pp_stdout
222+
~pp_stderr
223+
~js_file
224+
() =
225+
let worker = Worker.create js_file in
226+
let fds = IntMap.empty |> IntMap.add 0 pp_stdout |> IntMap.add 1 pp_stderr in
227+
let worker =
228+
{ cmis_prefix
229+
; imported = []
230+
; worker
231+
; js_file
232+
; wakeners = IntMap.empty
233+
; counter = 0
234+
; fds
235+
; fd_counter = 2
236+
; reset_worker = do_reset_worker ()
237+
; after_init
238+
; pp_stdout
239+
; pp_stderr }
240+
in
241+
(Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker);
242+
post worker @@ Init cmis_prefix
243+
>>= fun _ -> worker.after_init worker >>= fun () -> Lwt.return worker
244+
245+
let create_fd worker pp =
246+
worker.fds <- IntMap.add worker.fd_counter pp worker.fds;
247+
let fd = worker.fd_counter in
248+
worker.fd_counter <- fd + 1;
249+
fd
250+
251+
let close_fd worker fd = worker.fds <- IntMap.remove fd worker.fds
252+
253+
let reset worker ?(timeout = fun () -> never_ending) () =
254+
let timeout = timeout () in
255+
Lwt.choose
256+
[ (post worker Reset >>= fun res -> Lwt.return (`Reset res))
257+
; (timeout >>= fun () -> Lwt.return `Timeout) ]
258+
>>= function
259+
| `Reset (JsooTopWrapped.Success ((), _)) ->
260+
Lwt.cancel timeout;
261+
worker.after_init worker
262+
| `Reset (JsooTopWrapped.Error (err, _)) ->
263+
Lwt.cancel timeout;
264+
worker.pp_stderr err.JsooTopWrapped.msg;
265+
worker.reset_worker worker
266+
| `Timeout ->
267+
(* Not canceling the Reset thread, but manually resetting. *)
268+
worker.reset_worker worker
269+
270+
let check worker ?(setenv = false) code = post worker @@ Check (setenv, code)
271+
272+
let execute worker ?ppf_code ?(print_outcome = false) ~ppf_answer code =
273+
let ppf_code = map_option (create_fd worker) ppf_code in
274+
let ppf_answer = create_fd worker ppf_answer in
275+
post worker @@ Execute (ppf_code, print_outcome, ppf_answer, code)
276+
>>= fun result ->
277+
iter_option (close_fd worker) ppf_code;
278+
close_fd worker ppf_answer;
279+
Lwt.return result
280+
281+
let use_string worker ?filename ?(print_outcome = false) ~ppf_answer code =
282+
let ppf_answer = create_fd worker ppf_answer in
283+
post worker @@ Use_string (filename, print_outcome, ppf_answer, code)
284+
>>= fun result ->
285+
close_fd worker ppf_answer;
286+
Lwt.return result
287+
288+
let use_mod_string
289+
worker
290+
?(print_outcome = false)
291+
~ppf_answer
292+
~modname
293+
?sig_code
294+
impl_code =
295+
let ppf_answer = create_fd worker ppf_answer in
296+
post worker @@ Use_mod_string (ppf_answer, print_outcome, modname, sig_code, impl_code)
297+
>>= fun result ->
298+
close_fd worker ppf_answer;
299+
Lwt.return result
300+
301+
let set_after_init w after_init = w.after_init <- after_init

‎toplevel/lib/jsooTopAsynchronous.mli‎

Lines changed: 45 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,45 @@
1+
(* Js_of_ocaml library
2+
* http://www.ocsigen.org/js_of_ocaml/
3+
* Copyright (C) 2016 OCamlPro
4+
*
5+
* This program is free software; you can redistribute it and/or modify
6+
* it under the terms of the GNU Library General Public License as published by
7+
* the Free Software Foundation, with linking exception;
8+
* either version 2.1 of the License, or (at your option) any later version.
9+
*
10+
* This program is distributed in the hope that it will be useful,
11+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
12+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+
* GNU Library General Public License for more details.
14+
*
15+
* You should have received a copy of the GNU Library General Public License
16+
* along with this program; if not, write to the Free Software
17+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
18+
*)
19+
20+
type toplevel
21+
22+
type 'a result = 'a JsooTopWrapped.result Lwt.t
23+
24+
type output = string -> unit
25+
26+
val create :
27+
?cmis_prefix:string
28+
-> ?after_init:(toplevel -> unit Lwt.t)
29+
-> pp_stdout:output
30+
-> pp_stderr:output
31+
-> js_file:string
32+
-> unit
33+
-> toplevel Lwt.t
34+
35+
val set_after_init : toplevel -> (toplevel -> unit Lwt.t) -> unit
36+
37+
val import_cmis_js : toplevel -> string -> unit JsooTopWrapped.result Lwt.t
38+
39+
val reset : toplevel -> ?timeout:(unit -> unit Lwt.t) -> unit -> unit Lwt.t
40+
41+
include
42+
JsooTopIntf.Wrapped
43+
with type toplevel := toplevel
44+
and type 'a result := 'a result
45+
and type output := output

0 commit comments

Comments
 (0)