From bcd6802290d9f2248a309aa33a960ee8017d823c Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sun, 7 Jul 2019 23:50:11 +0800 Subject: [PATCH] jsoo-top-wrapped --- toplevel/lib/js_of_ocaml_toplevel.ml | 2 + toplevel/lib/jsooTopIntf.ml | 107 ++++++++ toplevel/lib/jsooTopIntf.mli | 107 ++++++++ toplevel/lib/jsooTopWrapped.ml | 255 +++++++++++++++++++ toplevel/lib/jsooTopWrapped.mli | 24 ++ toplevel/lib/lwt/dune | 14 ++ toplevel/lib/lwt/jsooTopAsynchronous.ml | 305 +++++++++++++++++++++++ toplevel/lib/lwt/jsooTopAsynchronous.mli | 46 ++++ toplevel/lib/lwt/jsooTopWorker.ml | 203 +++++++++++++++ toplevel/lib/lwt/jsooTopWorker.mli | 20 ++ toplevel/lib/lwt/jsooTopWorkerIntf.ml | 44 ++++ toplevel/lib/lwt/jsooTopWorkerIntf.mli | 44 ++++ 12 files changed, 1171 insertions(+) create mode 100644 toplevel/lib/jsooTopIntf.ml create mode 100644 toplevel/lib/jsooTopIntf.mli create mode 100644 toplevel/lib/jsooTopWrapped.ml create mode 100644 toplevel/lib/jsooTopWrapped.mli create mode 100644 toplevel/lib/lwt/dune create mode 100644 toplevel/lib/lwt/jsooTopAsynchronous.ml create mode 100644 toplevel/lib/lwt/jsooTopAsynchronous.mli create mode 100644 toplevel/lib/lwt/jsooTopWorker.ml create mode 100644 toplevel/lib/lwt/jsooTopWorker.mli create mode 100644 toplevel/lib/lwt/jsooTopWorkerIntf.ml create mode 100644 toplevel/lib/lwt/jsooTopWorkerIntf.mli diff --git a/toplevel/lib/js_of_ocaml_toplevel.ml b/toplevel/lib/js_of_ocaml_toplevel.ml index 476e5cb3dc..4653b7c825 100644 --- a/toplevel/lib/js_of_ocaml_toplevel.ml +++ b/toplevel/lib/js_of_ocaml_toplevel.ml @@ -18,3 +18,5 @@ *) module JsooTop = JsooTop +module JsooTopWrapped = JsooTopWrapped +module JsooTopIntf = JsooTopIntf diff --git a/toplevel/lib/jsooTopIntf.ml b/toplevel/lib/jsooTopIntf.ml new file mode 100644 index 0000000000..3f738f65a2 --- /dev/null +++ b/toplevel/lib/jsooTopIntf.ml @@ -0,0 +1,107 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +module type Wrapped = sig + type toplevel + + type 'a result + + type output + + val check : toplevel -> ?setenv:bool -> string -> unit result + (** Parse and typecheck a given source code + + @param setenv should the resulting environment replace the current + environment ? + + @return [Success ()] in case of success and [Error err] + where [err] contains the error message otherwise. + + *) + + val execute : + toplevel + -> ?ppf_code:output + -> ?print_outcome:bool + -> ppf_answer:output + -> string + -> bool result + (** Execute a given source code. The evaluation stops after the first + toplevel phrase (as terminated by ";;") that fails to compile or + for which the evaluation raises an uncaught exception. + + @param ppf_code a formatter were the source code will be printed + before its execution. The printing might be interleaved + with call to "pp_answer" when a line finishes by ";;". + + @param ppf_answer a formatter were the compiler outputs will be + printed. + + @param print_outcome should the toplevel print the computed + values and their types ? + + @return [Error err] when parsing or typechecking failed, where + [err] contains the error message. It returns [Success true] + when the code evaluation finished without uncaught + exception, and [Success false] otherwise. + *) + + val use_string : + toplevel + -> ?filename:string + -> ?print_outcome:bool + -> ppf_answer:output + -> string + -> bool result + (** Execute a given source code. The code is parsed and + typechecked all at once before to start the evalution. + + @param filename a faked filename which will be used in error messages + + @param ppf_answer see {!val:execute}. + + @param print_outcome see {!val:execute}. + + @return as {!val:execute}. + + *) + + val use_mod_string : + toplevel + -> ?print_outcome:bool + -> ppf_answer:output + -> modname:string + -> ?sig_code:string + -> string + -> bool result + (** Wrap a given source code into a module and bind it with a given name. + + @param print_outcome see {!val:execute}. + + @param ppf_answer see {!val:execute}. + + @param modname the module name, it must start with a capital + character. + + @param sig_code source code for the module signature. + + @return as {!val:execute}. + + *) +end diff --git a/toplevel/lib/jsooTopIntf.mli b/toplevel/lib/jsooTopIntf.mli new file mode 100644 index 0000000000..3f738f65a2 --- /dev/null +++ b/toplevel/lib/jsooTopIntf.mli @@ -0,0 +1,107 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +module type Wrapped = sig + type toplevel + + type 'a result + + type output + + val check : toplevel -> ?setenv:bool -> string -> unit result + (** Parse and typecheck a given source code + + @param setenv should the resulting environment replace the current + environment ? + + @return [Success ()] in case of success and [Error err] + where [err] contains the error message otherwise. + + *) + + val execute : + toplevel + -> ?ppf_code:output + -> ?print_outcome:bool + -> ppf_answer:output + -> string + -> bool result + (** Execute a given source code. The evaluation stops after the first + toplevel phrase (as terminated by ";;") that fails to compile or + for which the evaluation raises an uncaught exception. + + @param ppf_code a formatter were the source code will be printed + before its execution. The printing might be interleaved + with call to "pp_answer" when a line finishes by ";;". + + @param ppf_answer a formatter were the compiler outputs will be + printed. + + @param print_outcome should the toplevel print the computed + values and their types ? + + @return [Error err] when parsing or typechecking failed, where + [err] contains the error message. It returns [Success true] + when the code evaluation finished without uncaught + exception, and [Success false] otherwise. + *) + + val use_string : + toplevel + -> ?filename:string + -> ?print_outcome:bool + -> ppf_answer:output + -> string + -> bool result + (** Execute a given source code. The code is parsed and + typechecked all at once before to start the evalution. + + @param filename a faked filename which will be used in error messages + + @param ppf_answer see {!val:execute}. + + @param print_outcome see {!val:execute}. + + @return as {!val:execute}. + + *) + + val use_mod_string : + toplevel + -> ?print_outcome:bool + -> ppf_answer:output + -> modname:string + -> ?sig_code:string + -> string + -> bool result + (** Wrap a given source code into a module and bind it with a given name. + + @param print_outcome see {!val:execute}. + + @param ppf_answer see {!val:execute}. + + @param modname the module name, it must start with a capital + character. + + @param sig_code source code for the module signature. + + @return as {!val:execute}. + + *) +end diff --git a/toplevel/lib/jsooTopWrapped.ml b/toplevel/lib/jsooTopWrapped.ml new file mode 100644 index 0000000000..9df2f1d7cb --- /dev/null +++ b/toplevel/lib/jsooTopWrapped.ml @@ -0,0 +1,255 @@ +open! Js_of_ocaml +open! Js_of_ocaml_compiler +open! Js_of_ocaml_compiler.Stdlib + +type loc = + { loc_start : int * int + ; loc_end : int * int + } + +type error = + { msg : string + ; locs : loc list + } + +type warning = error + +type 'a result = + | Success of 'a * warning list + | Error of error * warning list + +let warnings = ref [] + +let convert_loc loc = + let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in + let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in + { loc_start = line1, col1; loc_end = line2, col2 } + +let () = + let warning_reporter = !Location.warning_reporter in + Location.warning_reporter := + fun loc w -> + match warning_reporter loc w with + | Some report -> + let buf = Buffer.create 503 in + let ppf = Format.formatter_of_buffer buf in + let printer = !Location.report_printer () in + printer.pp printer ppf report; + let msg = Buffer.contents buf in + let loc = convert_loc loc in + warnings := { msg; locs = [ loc ] } :: !warnings; + Some report + | None -> None + +(* Workaround Marshal bug triggered by includemod.ml:607 *) +let () = Clflags.error_size := 0 + +(* Disable inlining of JSOO which may blow the JS stack *) +let () = Js_of_ocaml_compiler.Config.Flag.disable "inline" + +let return_success e = Success (e, !warnings) + +let return_error e = Error (e, !warnings) + +(* let return_unit_success = return_success () *) + +(** Error handling *) + +let report_error_rec ppf (report : Location.report) = + let locs = ref [] in + let printer = !Location.report_printer () in + let printer = + { printer with + pp_main_loc = + (fun pr report fmt loc -> + locs := loc :: !locs; + printer.pp_main_loc pr report fmt loc) + ; pp_submsg_loc = + (fun pr report fmt loc -> + locs := loc :: !locs; + printer.pp_submsg_loc pr report fmt loc) + } + in + printer.pp printer ppf report; + List.map ~f:convert_loc !locs + +let report_error err = + let buf = Buffer.create 503 in + let ppf = Format.formatter_of_buffer buf in + let locs = report_error_rec ppf err in + Format.pp_print_flush ppf (); + let msg = Buffer.contents buf in + { msg; locs } + +let error_of_exn exn = + match Location.error_of_exn exn with + | Some (`Ok error) -> report_error error + | Some `Already_displayed | None -> + let msg = Printexc.to_string exn in + { msg; locs = [] } + +let return_exn exn = return_error (error_of_exn exn) + +(** Execution helpers *) + +let trim_end s = + let ws = function + | ' ' | '\t' | '\n' -> true + | _ -> false + in + let len = String.length s in + let stop = ref (len - 1) in + while !stop > 0 && ws s.[!stop] do + decr stop + done; + String.sub s ~pos:0 ~len:(!stop + 1) + +let normalize code = + let content = trim_end code in + let len = String.length content in + if String.is_empty content + then content + else if len > 2 && Char.equal content.[len - 2] ';' && Char.equal content.[len - 1] ';' + then content ^ "\n" + else content ^ " ;;\n" + +let init_loc lb filename = + Location.input_name := filename; + Location.input_lexbuf := Some lb; + Location.init lb filename + +let refill_lexbuf s p ppf buffer len = + if !p = String.length s + then 0 + else + let len', nl = + try String.index_from s !p '\n' - !p + 1, false + with _ -> String.length s - !p, true + in + let len'' = min len len' in + String.blit ~src:s ~src_pos:!p ~dst:buffer ~dst_pos:0 ~len:len''; + (match ppf with + | Some ppf -> + Format.fprintf ppf "%s" (Bytes.sub_string buffer ~pos:0 ~len:len''); + if nl then Format.pp_print_newline ppf (); + Format.pp_print_flush ppf () + | None -> ()); + p := !p + len''; + len'' + +let execute () ?ppf_code ?(print_outcome = true) ~ppf_answer code = + let code = normalize code in + let lb = + match ppf_code with + | Some ppf_code -> Lexing.from_function (refill_lexbuf code (ref 0) (Some ppf_code)) + | None -> Lexing.from_string code + in + init_loc lb "//toplevel//"; + warnings := []; + let rec loop () = + let phr = !Toploop.parse_toplevel_phrase lb in + let phr = JsooTopPpx.preprocess_phrase phr in + let success = Toploop.execute_phrase print_outcome ppf_answer phr in + Format.pp_print_flush ppf_answer (); + if success then loop () else return_success false + in + try + let res = loop () in + flush_all (); + res + with + | End_of_file -> + flush_all (); + return_success true + | exn -> + flush_all (); + return_error (error_of_exn exn) + +let use_string () ?(filename = "//toplevel//") ?(print_outcome = true) ~ppf_answer code = + let lb = Lexing.from_string code in + init_loc lb filename; + warnings := []; + try + List.iter + ~f:(fun phr -> + if not (Toploop.execute_phrase print_outcome ppf_answer phr) + then raise Exit + else Format.pp_print_flush ppf_answer ()) + (List.map ~f:JsooTopPpx.preprocess_phrase (!Toploop.parse_use_file lb)); + flush_all (); + return_success true + with + | Exit -> + flush_all (); + Format.pp_print_flush ppf_answer (); + return_success false + | exn -> + flush_all (); + return_error (error_of_exn exn) + +let parse_mod_string modname sig_code impl_code = + let open Parsetree in + let open Ast_helper in + let str = + let impl_lb = Lexing.from_string impl_code in + init_loc impl_lb (String.uncapitalize_ascii modname ^ ".ml"); + Parse.implementation impl_lb + in + let m = + match sig_code with + | None -> Mod.structure str + | Some sig_code -> + let sig_lb = Lexing.from_string sig_code in + init_loc sig_lb (String.uncapitalize_ascii modname ^ ".mli"); + let s = Parse.interface sig_lb in + Mod.constraint_ (Mod.structure str) (Mty.signature s) + in + Ptop_def [ Str.module_ (Mb.mk (Location.mknoloc (Some modname)) m) ] + +let use_mod_string () ?(print_outcome = true) ~ppf_answer ~modname ?sig_code impl_code = + if not (String.equal (String.capitalize_ascii modname) modname) + then + invalid_arg + "Tryocaml_toploop.use_mod_string: the module name must start with a capital letter."; + warnings := []; + try + let phr = + JsooTopPpx.preprocess_phrase @@ parse_mod_string modname sig_code impl_code + in + let res = Toploop.execute_phrase print_outcome ppf_answer phr in + Format.pp_print_flush ppf_answer (); + flush_all (); + return_success res + with exn -> + flush_all (); + return_error (error_of_exn exn) + +(* Extracted from the "execute" function in "ocaml/toplevel/toploop.ml" *) +let check_phrase env = function + | Parsetree.Ptop_def sstr -> + Typecore.reset_delayed_checks (); + let str, sg, sg_names, _, newenv = Typemod.type_toplevel_phrase env sstr in + let sg' = Typemod.Signature_names.simplify newenv sg_names sg in + ignore (Includemod.signatures ~mark:Mark_positive env sg sg'); + Typecore.force_delayed_checks (); + let _lam = Translmod.transl_toplevel_definition str in + Warnings.check_fatal (); + newenv + | Parsetree.Ptop_dir _ -> env + +let check () ?(setenv = false) code = + let lb = Lexing.from_string code in + init_loc lb "//toplevel//"; + warnings := []; + try + let env = + List.fold_left + ~f:check_phrase + ~init:!Toploop.toplevel_env + (List.map ~f:JsooTopPpx.preprocess_phrase (!Toploop.parse_use_file lb)) + in + if setenv then Toploop.toplevel_env := env; + return_success () + with + | End_of_file -> return_success () + | exn -> return_exn exn diff --git a/toplevel/lib/jsooTopWrapped.mli b/toplevel/lib/jsooTopWrapped.mli new file mode 100644 index 0000000000..ccdb101fdb --- /dev/null +++ b/toplevel/lib/jsooTopWrapped.mli @@ -0,0 +1,24 @@ +(** A [result] type for all the toplevel functions. *) +type 'a result = + | Success of 'a * warning list + | Error of error * warning list + +and error = + { msg : string + ; locs : loc list + } + +and warning = error + +and loc = + { loc_start : int * int + ; loc_end : int * int + } + +include + JsooTopIntf.Wrapped + with type toplevel := unit + and type 'a result := 'a result + and type output := Format.formatter + +val error_of_exn : exn -> error diff --git a/toplevel/lib/lwt/dune b/toplevel/lib/lwt/dune new file mode 100644 index 0000000000..5abbafbc73 --- /dev/null +++ b/toplevel/lib/lwt/dune @@ -0,0 +1,14 @@ +(library + (name js_of_ocaml_toplevel_lwt) + (public_name js_of_ocaml-toplevel.lwt) + (synopsis "Js_of_ocaml toplevel library") + (libraries + lwt + js_of_ocaml-compiler + js_of_ocaml + bytes + js_of_ocaml-toplevel + compiler-libs.bytecomp + compiler-libs.toplevel) + (preprocess + (pps js_of_ocaml-ppx))) diff --git a/toplevel/lib/lwt/jsooTopAsynchronous.ml b/toplevel/lib/lwt/jsooTopAsynchronous.ml new file mode 100644 index 0000000000..f3f6390908 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopAsynchronous.ml @@ -0,0 +1,305 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) +open Js_of_ocaml +open! Js_of_ocaml_toplevel +open JsooTopWorkerIntf + +type 'a result = 'a JsooTopWrapped.result Lwt.t + +let ( >>= ) = Lwt.bind + +let ( >>? ) o f = + let open! JsooTopWrapped in + o + >>= function + | Error (err, w) -> Lwt.return (Error (err, w)) + | Success (x, w) -> ( + f x + >>= function + | Error (err, w') -> Lwt.return (Error (err, w @ w')) + | Success (x, w') -> Lwt.return (Success (x, w @ w'))) + +let return_success e = Lwt.return (JsooTopWrapped.Success (e, [])) + +let return_unit_success = return_success () + +(* let return_error e = Lwt.return (JsooTopWrapped.Error (e, [])) *) +(* let return_exn exn = return_error (JsooTopWrapped.error_of_exn exn) *) + +(* let wrap pp = *) +(* let buf = Buffer.create 503 in *) +(* let flush () = *) +(* let s = Buffer.contents buf in *) +(* if s <> "" then begin *) +(* Buffer.reset buf; *) +(* pp s *) +(* end in *) +(* Format.make_formatter (Buffer.add_substring buf) flush *) + +(* let () = *) +(* Location.register_error_of_exn *) +(* (function *) +(* | Js.Error e -> *) +(* Firebug.console##log(e##stack); *) +(* let msg = Js.to_string e##message in *) +(* Some { Location.msg; if_highlight = msg; sub = []; loc = Location.none } *) +(* | _ -> None) *) + +module IntMap = Map.Make (Int) + +let map_option f o = + match o with + | None -> None + | Some o -> Some (f o) + +let iter_option f o = + match o with + | None -> () + | Some o -> f o + +type u = + | U : 'a msg_ty * 'a JsooTopWrapped.result Lwt.u * 'a JsooTopWrapped.result Lwt.t -> u + +type output = string -> unit + +type toplevel = + { cmis_prefix : string + ; js_file : string + ; mutable imported : string list + ; mutable worker : (Js.js_string Js.t, Js.js_string Js.t) Worker.worker Js.t + ; mutable wakeners : u IntMap.t + ; mutable counter : int + ; mutable fds : output IntMap.t + ; mutable fd_counter : int + ; mutable reset_worker : toplevel -> unit Lwt.t + ; mutable after_init : toplevel -> unit Lwt.t + ; pp_stdout : output + ; pp_stderr : output + } + +exception Not_equal + +let check_equal : type t1 t2. t1 msg_ty -> t2 msg_ty -> (t1, t2) eq = + fun ty1 ty2 -> + match ty1, ty2 with + | Unit, Unit -> Eq + | Bool, Bool -> Eq + | Int, Int -> Eq + | String, String -> Eq + | Unit, _ -> raise Not_equal + | Bool, _ -> raise Not_equal + | Int, _ -> raise Not_equal + | String, _ -> raise Not_equal + +let onmessage worker (ev : _ Worker.messageEvent Js.t) = + match Json.unsafe_input ev##.data with + | Write (fd, s) -> ( + try + IntMap.find fd worker.fds s; + Js._false + with Not_found -> + Firebug.console##warn (Js.string (Printf.sprintf "Missing channels (%d)" fd)); + Js._false) + | ReturnSuccess (id, ty_v, v, w) -> ( + try + let (U (ty_u, u, _)) = IntMap.find id worker.wakeners in + let Eq = check_equal ty_u ty_v in + worker.wakeners <- IntMap.remove id worker.wakeners; + Lwt.wakeup u (JsooTopWrapped.Success (v, w)); + Js._false + with + | Not_found -> + Firebug.console##warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id)); + Js._false + | Not_equal -> + Firebug.console##warn (Js.string (Printf.sprintf "Unexpected wakeners (%d)" id)); + Js._false) + | ReturnError (id, e, w) -> ( + try + let (U (_, u, _)) = IntMap.find id worker.wakeners in + worker.wakeners <- IntMap.remove id worker.wakeners; + Lwt.wakeup u (JsooTopWrapped.Error (e, w)); + Js._false + with Not_found -> + Firebug.console##warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id)); + Js._false) + +let terminate worker = + worker.worker##terminate; + IntMap.iter + (fun id (U (_, _, t)) -> + worker.wakeners <- IntMap.remove id worker.wakeners; + Lwt.cancel t) + worker.wakeners + +let never_ending = + (* and not cancellable. *) + fst (Lwt.wait ()) + +let ty_of_host_msg : type t. t host_msg -> t msg_ty = function + | Init _ -> Unit + | Reset -> Unit + | Check _ -> Unit + | Execute _ -> Bool + | Use_string _ -> Bool + | Use_mod_string _ -> Bool + | Import_scripts _ -> Unit + +(** Threads created with [post] will always be wake-uped by + [onmessage] by calling [Lwt.wakeup]. They should never end with + an exception, unless canceled. When canceled, the worker is + killed and a new one is spawned. *) +let rec post : type a. toplevel -> a host_msg -> a JsooTopWrapped.result Lwt.t = + fun worker msg -> + let msg_id = worker.counter in + let msg_ty = ty_of_host_msg msg in + let t, u = Lwt.task () in + Lwt.on_cancel t (fun () -> Lwt.async (fun () -> worker.reset_worker worker)); + worker.wakeners <- IntMap.add msg_id (U (msg_ty, u, t)) worker.wakeners; + worker.counter <- msg_id + 1; + worker.worker##postMessage (Json.output (msg_id, msg)); + t + +and do_reset_worker () = + let running = ref true in + fun worker -> + if !running + then ( + running := false; + terminate worker; + IntMap.iter + (* GRGR: Peut-on 'cancel' directement le Lwt.u ? *) + (fun _ (U (_, _, t)) -> Lwt.cancel t) + worker.wakeners; + worker.worker <- Worker.create worker.js_file; + worker.fds <- + IntMap.empty + |> IntMap.add 0 (IntMap.find 0 worker.fds) + |> IntMap.add 1 (IntMap.find 1 worker.fds); + worker.fd_counter <- 2; + let imported = worker.imported in + worker.imported <- []; + worker.wakeners <- IntMap.empty; + worker.counter <- 0; + worker.reset_worker <- do_reset_worker (); + (Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker); + Lwt_list.iter_p + (fun name -> import_cmis_js worker name >>= fun _ -> Lwt.return_unit) + imported + >>= fun () -> + post worker @@ Init worker.cmis_prefix + >>= fun _ -> worker.after_init worker >>= fun _ -> Lwt.return_unit) + else Lwt.return_unit + +and import_cmis_js worker name = + if List.mem name worker.imported + then return_unit_success + else + let url = worker.cmis_prefix ^ name ^ ".cmis.js" in + post worker @@ Import_scripts [ url ] + >>? fun () -> + worker.imported <- name :: worker.imported; + return_unit_success + +let create + ?(cmis_prefix = "") + ?(after_init = fun _ -> Lwt.return_unit) + ~pp_stdout + ~pp_stderr + ~js_file + () = + let worker = Worker.create js_file in + let fds = IntMap.empty |> IntMap.add 0 pp_stdout |> IntMap.add 1 pp_stderr in + let worker = + { cmis_prefix + ; imported = [] + ; worker + ; js_file + ; wakeners = IntMap.empty + ; counter = 0 + ; fds + ; fd_counter = 2 + ; reset_worker = do_reset_worker () + ; after_init + ; pp_stdout + ; pp_stderr + } + in + (Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker); + post worker @@ Init cmis_prefix + >>= fun _ -> worker.after_init worker >>= fun () -> Lwt.return worker + +let create_fd worker pp = + worker.fds <- IntMap.add worker.fd_counter pp worker.fds; + let fd = worker.fd_counter in + worker.fd_counter <- fd + 1; + fd + +let close_fd worker fd = worker.fds <- IntMap.remove fd worker.fds + +let reset worker ?(timeout = fun () -> never_ending) () = + let timeout = timeout () in + Lwt.choose + [ (post worker Reset >>= fun res -> Lwt.return (`Reset res)) + ; (timeout >>= fun () -> Lwt.return `Timeout) + ] + >>= function + | `Reset (JsooTopWrapped.Success ((), _)) -> + Lwt.cancel timeout; + worker.after_init worker + | `Reset (JsooTopWrapped.Error (err, _)) -> + Lwt.cancel timeout; + worker.pp_stderr err.JsooTopWrapped.msg; + worker.reset_worker worker + | `Timeout -> + (* Not canceling the Reset thread, but manually resetting. *) + worker.reset_worker worker + +let check worker ?(setenv = false) code = post worker @@ Check (setenv, code) + +let execute worker ?ppf_code ?(print_outcome = false) ~ppf_answer code = + let ppf_code = map_option (create_fd worker) ppf_code in + let ppf_answer = create_fd worker ppf_answer in + post worker @@ Execute (ppf_code, print_outcome, ppf_answer, code) + >>= fun result -> + iter_option (close_fd worker) ppf_code; + close_fd worker ppf_answer; + Lwt.return result + +let use_string worker ?filename ?(print_outcome = false) ~ppf_answer code = + let ppf_answer = create_fd worker ppf_answer in + post worker @@ Use_string (filename, print_outcome, ppf_answer, code) + >>= fun result -> + close_fd worker ppf_answer; + Lwt.return result + +let use_mod_string + worker + ?(print_outcome = false) + ~ppf_answer + ~modname + ?sig_code + impl_code = + let ppf_answer = create_fd worker ppf_answer in + post worker @@ Use_mod_string (ppf_answer, print_outcome, modname, sig_code, impl_code) + >>= fun result -> + close_fd worker ppf_answer; + Lwt.return result + +let set_after_init w after_init = w.after_init <- after_init diff --git a/toplevel/lib/lwt/jsooTopAsynchronous.mli b/toplevel/lib/lwt/jsooTopAsynchronous.mli new file mode 100644 index 0000000000..444b282578 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopAsynchronous.mli @@ -0,0 +1,46 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) +open! Js_of_ocaml_toplevel + +type toplevel + +type 'a result = 'a JsooTopWrapped.result Lwt.t + +type output = string -> unit + +val create : + ?cmis_prefix:string + -> ?after_init:(toplevel -> unit Lwt.t) + -> pp_stdout:output + -> pp_stderr:output + -> js_file:string + -> unit + -> toplevel Lwt.t + +val set_after_init : toplevel -> (toplevel -> unit Lwt.t) -> unit + +val import_cmis_js : toplevel -> string -> unit JsooTopWrapped.result Lwt.t + +val reset : toplevel -> ?timeout:(unit -> unit Lwt.t) -> unit -> unit Lwt.t + +include + JsooTopIntf.Wrapped + with type toplevel := toplevel + and type 'a result := 'a result + and type output := output diff --git a/toplevel/lib/lwt/jsooTopWorker.ml b/toplevel/lib/lwt/jsooTopWorker.ml new file mode 100644 index 0000000000..fa396c4165 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopWorker.ml @@ -0,0 +1,203 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml +open! Js_of_ocaml_toplevel +open JsooTopWorkerIntf + +type 'a return = + | ReturnSuccess of 'a * JsooTopWrapped.warning list + | ReturnError of JsooTopWrapped.error * JsooTopWrapped.warning list + +let return_success v w = ReturnSuccess (v, w) + +let return_unit_success = return_success () [] + +let return_error e w = ReturnError (e, w) + +let return_exn exn = return_error (JsooTopWrapped.error_of_exn exn) [] + +let unwrap_result : _ JsooTopWrapped.result -> _ = function + | Success (b, w) -> return_success b w + | Error (err, w) -> return_error err w + +(** File descriptors *) + +module IntMap = Map.Make (struct + type t = int + + let compare (x : int) (y : int) = compare x y +end) + +(* Limit the frequency of sent messages to one per ms, using an active + loop (yuck) because, well, there is no other concurrency primitive + and we do not want to fill a memory buffer but really "pause" the + program. + + The problem arises with debug off and developper tools off only. + In this case, with a program that does a lot of writes (print or + callbacks), the messages queue fills up super quickly and kills the + browser / tab. + + A possible improvement would be to bufferize the messages channel + per channel, and emit the buffer of each channel every ms if it has + changed. But it could cause bad asynchronicity in case the worker + does a big computation just after a bufferized write. And it would + still need some kind of active waiting to limit throughput. All in + all this spinwait is not that ugly. *) +let last = ref 0. + +let rec wait () = + let now = Sys.time () (* let's hope this yields a bit *) in + if now -. !last > 0.001 then last := now else wait () + +let post_message (m : toploop_msg) = + wait (); + Worker.post_message (Json.output m) + +let wrap_fd, close_fd, clear_fds = + let fds = ref IntMap.empty in + let wrap_fd fd = + try IntMap.find fd !fds + with Not_found -> + let buf = Buffer.create 503 in + let flush () = + let s = Buffer.contents buf in + if s <> "" + then ( + Buffer.reset buf; + post_message (Write (fd, s))) + in + let ppf = Format.make_formatter (Buffer.add_substring buf) flush in + fds := IntMap.add fd ppf !fds; + ppf + in + let close_fd fd = + if IntMap.mem fd !fds then Format.pp_print_flush (IntMap.find fd !fds) (); + fds := IntMap.remove fd !fds + in + let clear_fds () = + fds := + IntMap.fold + (fun id ppf fds -> + Format.pp_print_flush ppf (); + if id = 0 || id = 1 then IntMap.add id ppf fds else fds) + !fds + IntMap.empty + in + wrap_fd, close_fd, clear_fds + +let stdout_ppf = wrap_fd 0 + +let stderr_ppf = wrap_fd 1 + +let () = + Sys_js.set_channel_flusher stdout (fun s -> + Format.pp_print_string stdout_ppf s; + Format.pp_print_flush stdout_ppf ()); + Sys_js.set_channel_flusher stderr (fun s -> + Format.pp_print_string stderr_ppf s; + Format.pp_print_flush stderr_ppf ()) + +(** Code compilation and execution *) + +(* TODO protect execution with a mutex! *) + +(** Message dispatcher *) + +let map_option f o = + match o with + | None -> None + | Some o -> Some (f o) + +let iter_option f o = + match o with + | None -> () + | Some o -> f o + +let handler : type a. a host_msg -> a return = function + | Init prefix -> + Worker.import_scripts [ prefix ^ "stdlib.cmis.js" ]; + JsooTop.initialize (); + return_unit_success + | Reset -> + clear_fds (); + Toploop.initialize_toplevel_env (); + return_unit_success + | Check (setenv, code) -> + let result = JsooTopWrapped.check () ~setenv code in + unwrap_result result + | Execute (fd_code, print_outcome, fd_answer, code) -> + let ppf_code = map_option wrap_fd fd_code in + let ppf_answer = wrap_fd fd_answer in + let result = JsooTopWrapped.execute () ?ppf_code ~print_outcome ~ppf_answer code in + iter_option close_fd fd_code; + close_fd fd_answer; + unwrap_result result + | Use_string (filename, print_outcome, fd_answer, code) -> + let ppf_answer = wrap_fd fd_answer in + let result = + JsooTopWrapped.use_string () ?filename ~print_outcome ~ppf_answer code + in + close_fd fd_answer; + unwrap_result result + | Use_mod_string (fd_answer, print_outcome, modname, sig_code, impl_code) -> + let ppf_answer = wrap_fd fd_answer in + let result = + JsooTopWrapped.use_mod_string + () + ~ppf_answer + ~print_outcome + ~modname + ?sig_code + impl_code + in + close_fd fd_answer; + unwrap_result result + | Import_scripts urls -> ( + try + Worker.import_scripts urls; + return_unit_success + with exn -> return_exn exn) + +let ty_of_host_msg : type t. t host_msg -> t msg_ty = function + | Init _ -> Unit + | Reset -> Unit + | Check _ -> Unit + | Execute _ -> Bool + | Use_string _ -> Bool + | Use_mod_string _ -> Bool + | Import_scripts _ -> Unit + +let new_directive name k = Hashtbl.add Toploop.directive_table name k + [@@alert "-deprecated"] + +let () = + let handler (type t) data = + let (id, data) : int * t host_msg = Json.unsafe_input data in + let ty = ty_of_host_msg data in + match handler data with + | ReturnSuccess (v, w) -> + post_message (JsooTopWorkerIntf.ReturnSuccess (id, ty, v, w)) + | ReturnError (res, w) -> post_message (JsooTopWorkerIntf.ReturnError (id, res, w)) + in + new_directive + "cmis" + (Toploop.Directive_string (fun name -> Worker.import_scripts [ name ])); + Worker.set_onmessage (fun s -> handler s) diff --git a/toplevel/lib/lwt/jsooTopWorker.mli b/toplevel/lib/lwt/jsooTopWorker.mli new file mode 100644 index 0000000000..8767edb2f5 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopWorker.mli @@ -0,0 +1,20 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(* empty file *) diff --git a/toplevel/lib/lwt/jsooTopWorkerIntf.ml b/toplevel/lib/lwt/jsooTopWorkerIntf.ml new file mode 100644 index 0000000000..244d88dac0 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopWorkerIntf.ml @@ -0,0 +1,44 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) +open! Js_of_ocaml_toplevel +open Js_of_ocaml + +(** Types of the messages exchanged with a toplevel in a Web Worker. *) + +type _ host_msg = + | Init : string -> unit host_msg + | Reset : unit host_msg + | Check : bool * string -> unit host_msg + | Execute : int option * bool * int * string -> bool host_msg + | Use_string : string option * bool * int * string -> bool host_msg + | Use_mod_string : int * bool * string * string option * string -> bool host_msg + | Import_scripts : string list -> unit host_msg + +type _ msg_ty = + | Unit : unit msg_ty + | Bool : bool msg_ty + | Int : int msg_ty + | String : Js.js_string Js.t msg_ty + +type (_, _) eq = Eq : ('a, 'a) eq + +type toploop_msg = + | Write : int * string -> toploop_msg (* pseudo file descriptor * content *) + | ReturnSuccess : int * 'a msg_ty * 'a * JsooTopWrapped.warning list -> toploop_msg + | ReturnError : int * JsooTopWrapped.error * JsooTopWrapped.warning list -> toploop_msg diff --git a/toplevel/lib/lwt/jsooTopWorkerIntf.mli b/toplevel/lib/lwt/jsooTopWorkerIntf.mli new file mode 100644 index 0000000000..244d88dac0 --- /dev/null +++ b/toplevel/lib/lwt/jsooTopWorkerIntf.mli @@ -0,0 +1,44 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2016 OCamlPro + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Library General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) +open! Js_of_ocaml_toplevel +open Js_of_ocaml + +(** Types of the messages exchanged with a toplevel in a Web Worker. *) + +type _ host_msg = + | Init : string -> unit host_msg + | Reset : unit host_msg + | Check : bool * string -> unit host_msg + | Execute : int option * bool * int * string -> bool host_msg + | Use_string : string option * bool * int * string -> bool host_msg + | Use_mod_string : int * bool * string * string option * string -> bool host_msg + | Import_scripts : string list -> unit host_msg + +type _ msg_ty = + | Unit : unit msg_ty + | Bool : bool msg_ty + | Int : int msg_ty + | String : Js.js_string Js.t msg_ty + +type (_, _) eq = Eq : ('a, 'a) eq + +type toploop_msg = + | Write : int * string -> toploop_msg (* pseudo file descriptor * content *) + | ReturnSuccess : int * 'a msg_ty * 'a * JsooTopWrapped.warning list -> toploop_msg + | ReturnError : int * JsooTopWrapped.error * JsooTopWrapped.warning list -> toploop_msg