share and improve the code for spawming webworkers

dict-gen/browser/dict_gen.ml

@@ -66,66 +66,34 @@ let html_fragment () =
     ~url_prefix:"/" ~id_prefix:"checkbox-" ~name_prefix:"load-" ()
   |> Jv.of_string
 
-let on_message ?progress ~k (lexique_url, dict1990_url, rules, profile) =
-  let open Fut.Result_syntax in
-  let* embedded =
-    time_fut ~profile "fetch" (fun () ->
-        let* data_lexique_Lexique383_gen_tsv = Brrex.fetch lexique_url in
-        Option.iter progress ~f:(fun f -> f 5);
-        let* extension_dict1990_gen_csv = Brrex.fetch dict1990_url in
-        Option.iter progress ~f:(fun f -> f 10);
-        Fut.ok { Dict_gen_common.Dict_gen.data_lexique_Lexique383_gen_tsv
-               ; extension_dict1990_gen_csv
+let on_message_rpc, on_message =
+  Brrex.rpc_with_progress (fun ?progress (lexique_url, dict1990_url, rules, profile) ->
+      let open Fut.Result_syntax in
+      let* embedded =
+        time_fut ~profile "fetch" (fun () ->
+            let* data_lexique_Lexique383_gen_tsv = Brrex.fetch lexique_url in
+            Option.iter progress ~f:(fun f -> f 5);
+            let* extension_dict1990_gen_csv = Brrex.fetch dict1990_url in
+            Option.iter progress ~f:(fun f -> f 10);
+            Fut.ok { Dict_gen_common.Dict_gen.data_lexique_Lexique383_gen_tsv
+                   ; extension_dict1990_gen_csv
           })
-  in
-  match
-    generate
-      ?progress:(Option.map progress ~f:(fun f x -> f (10 + x * 9 / 10)))
-      ~profile
-      embedded
-      rules
-  with
-  | exception e -> Fut.error (Jv.Error.v (Jstr.of_string (Exn.to_string e)))
-  | v -> Fut.ok (k v)
-
-let rpc : type q r.
-          ?progress:_
-          -> local:bool
-          -> path:string
-          -> (q -> (r, 'b) Result.t Fut.t)
-          -> q
-          -> (q -> _)
-          -> (r, 'b) Result.t Fut.t
-  = fun ?progress ~local ~path impl arg constr ->
-  (* This function ensures well typedness, by tying the result in the worker
-     case and in the non-worker case. *)
-  let open Fut.Syntax in
-  if local
-  then impl arg
-  else (
-    let worker = Brr_webworkers.Worker.create (Jstr.of_string (path ^ "/dict_gen.bc.js")) in
-    Brr_webworkers.Worker.post worker (constr arg);
-    let rec loop () =
-      let* event = Brr.Ev.next Brr_io.Message.Ev.message
-                     (Brr_webworkers.Worker.as_target worker) in
-      match Brr_io.Message.Ev.data (Brr.Ev.as_type event) with
-      | ("magic-string", i) -> Option.iter progress ~f:(fun f -> f i); loop ()
-      | _ -> Fut.return event
-    in
-    let* event = loop () in
-    Brr_webworkers.Worker.terminate worker;
-    Fut.return
-      (Brrex.or_throw
-         (Brr_io.Message.Ev.data
-            (Brr.Ev.as_type event)
-          : ((r, Jv.Error.t) Result.t, Jv.Error.t) Result.t))
-  )
+      in
+      match
+        generate
+          ?progress:(Option.map progress ~f:(fun f x -> f (10 + x * 9 / 10)))
+          ~profile
+          embedded
+          rules
+      with
+      | exception e -> Fut.error (Jv.Error.v (Jstr.of_string (Exn.to_string e)))
+      | v -> Fut.ok v
+    )
 
-let generate_in_worker path (lexique_url : Jstr.t) (dict1990_url : Jstr.t) rules (n : Jv.t) profile progress =
+let generate_in_worker (lexique_url : Jstr.t) (dict1990_url : Jstr.t) rules (n : Jv.t) profile progress =
   (* We need to run this in a worker, otherwise the loading animation doesn't actually
    * animate, which we kind of want it to, since the a 2s of waiting is on the longer
    * side. *)
-  let path = Jv.to_string path in
   let rules = (Stdlib.Obj.magic : Jv.t -> selected_rules) rules in
   let progress =
     Jv.to_option
@@ -136,13 +104,10 @@ let generate_in_worker path (lexique_url : Jstr.t) (dict1990_url : Jstr.t) rules
   let profile = Jv.to_bool profile in
   Brrex.fut_to_promise
     ~ok:(fun (dict, duration) -> Jv.of_jv_list [ Jv.of_string dict ; Jv.of_string duration ])
-    (rpc
-       ?progress
+    (on_message
        ~local:(n = 0)
-       ~path
-       (on_message ?progress ~k:Fn.id)
-       (lexique_url, dict1990_url, rules, profile)
-       (fun arg -> `On_message arg))
+       ?progress
+       (lexique_url, dict1990_url, rules, profile))
 
 let staged_generate =
   Jv.callback ~arity:2
@@ -168,24 +133,13 @@ let staged_generate =
                        (f (Jv.to_string jstr)))))))
 
 let () =
-  if Brr_webworkers.Worker.ami ()
-  then
-    let open Fut.Syntax in
-    Brrex.fut_await
-      (let* event = Brr.Ev.next Brr_io.Message.Ev.message Brr.G.target in
-       let data = Brr_io.Message.Ev.data (Brr.Ev.as_type event) in
-       match data with
-       | `On_message data ->
-          on_message data ~k:Jv.repr
-            ~progress:(fun i -> Brr_webworkers.Worker.G.post ("magic-string", i)))
-      (fun res ->
-        Brr_webworkers.Worker.G.post
-          (res : ((Jv.t, Jv.Error.t) Result.t, Jv.Error.t) Result.t))
-  else
-    Js_of_ocaml.Js.export "dict_gen"
-      (Js_of_ocaml.Js.Unsafe.inject
-         (Jv.obj [| "generate", Jv.callback ~arity:7 generate_in_worker
-                  ; "staged_generate", staged_generate
-                  ; "html_fragment", Jv.callback ~arity:1 html_fragment
-                  ; "currently_selected_rules", Jv.callback ~arity:1 currently_selected_rules
-            |]))
+  Brrex.main
+    [ on_message_rpc ]
+    (fun () ->
+      Js_of_ocaml.Js.export "dict_gen"
+        (Js_of_ocaml.Js.Unsafe.inject
+           (Jv.obj [| "generate", Jv.callback ~arity:6 generate_in_worker
+                    ; "staged_generate", staged_generate
+                    ; "html_fragment", Jv.callback ~arity:1 html_fragment
+                    ; "currently_selected_rules", Jv.callback ~arity:1 currently_selected_rules
+              |])))

extension/src/options.js

@@ -117,7 +117,7 @@ function add_rule_selection_ui() {
 }
 
 async function compute_dict(rules, set_progress) {
-    const [dict, stats] = await dict_gen.generate(".", "./Lexique383.gen.tsv", "./dict1990.gen.csv", rules, 1, false, set_progress);
+    const [dict, stats] = await dict_gen.generate("./Lexique383.gen.tsv", "./dict1990.gen.csv", rules, 1, false, set_progress);
     console.log(stats);
     return dict;
 }

libs/brrex/brrex.ml

@@ -121,5 +121,81 @@ let fetch url =
   let* buf = Brr_io.Fetch.Body.array_buffer (Brr_io.Fetch.Response.as_body response) in
   Fut.ok (string_of_array_buffer buf)
 
+let document = Jv.get Jv.global "document"
 let get_element_by_id id =
-  Jv.call (Jv.get Jv.global "document") "getElementById" [| Jv.of_jstr id |]
+  Jv.call document "getElementById" [| Jv.of_jstr id |]
+
+type rpc = string * ((bool * Jv.t) -> Jv.t Fut.or_error)
+let current_script =
+  if Jv.is_undefined document
+  then lazy (failwith "no currentScript, because no document")
+  else
+    (* We need to run this at toplevel, because currentScript is only defined when
+       executing the toplevel of a script. *)
+    let src = Jv.get (Jv.get document "currentScript") "src" in
+    lazy (Jv.to_jstr (Jv.get (Jv.new' (Jv.get Jv.global "URL") [|src|]) "pathname"))
+
+let rpc_name =
+  let r = ref (-1) in
+  fun () ->
+  r := !r + 1;
+  "rpc" ^ Int.to_string !r
+
+let rpc_with_progress : type q r.
+               (?progress:(int -> unit) -> q -> r Fut.or_error)
+               -> rpc * (?local:bool -> ?progress:(int -> unit) -> q -> r Fut.or_error)
+  = fun impl ->
+  let rpc_name = rpc_name () in
+  (rpc_name, (fun (has_progress, q) ->
+                  let progress =
+                    if has_progress
+                    then Some (fun i -> Brr_webworkers.Worker.G.post ("magic-string", i))
+                    else None
+                  in
+                  (Obj.magic
+                     (impl ?progress (Obj.magic (q : Jv.t) : q) : r Fut.or_error)
+                   : Jv.t Fut.or_error))),
+  (fun ?(local = false) ?progress arg ->
+    let open Fut.Syntax in
+    if local
+    then impl ?progress arg
+    else (
+      let worker = Brr_webworkers.Worker.create (Lazy.force current_script) in
+      Brr_webworkers.Worker.post worker (rpc_name, (Option.is_some progress, arg));
+      let* event =
+        let rec loop () =
+          let* event = Brr.Ev.next Brr_io.Message.Ev.message
+                         (Brr_webworkers.Worker.as_target worker) in
+          match Brr_io.Message.Ev.data (Brr.Ev.as_type event) with
+          | ("magic-string", i) -> Option.iter (fun f -> f i) progress; loop ()
+          | _ -> Fut.return event
+        in loop ()
+      in
+      Brr_webworkers.Worker.terminate worker;
+      Fut.return
+        (or_throw
+           (Brr_io.Message.Ev.data
+              (Brr.Ev.as_type event)
+            : ((r, Jv.Error.t) Result.t, Jv.Error.t) Result.t))))
+
+let rpc impl =
+  let rpc, f = rpc_with_progress (fun ?progress:_ q -> impl q) in
+  rpc, (fun ?local q -> f ?progress:None ?local q)
+
+let main (rpcs : rpc list) f =
+  let rpcs = Hashtbl.of_seq (List.to_seq rpcs) in
+  if Brr_webworkers.Worker.ami ()
+  then
+    let open Fut.Syntax in
+    fut_await
+      (let* event = Brr.Ev.next Brr_io.Message.Ev.message Brr.G.target in
+       let data = Brr_io.Message.Ev.data (Brr.Ev.as_type event) in
+       let (rpc_name, rpc_arg) = data in
+       let impl =
+         Hashtbl.find_opt rpcs rpc_name ||? failwith ("unknown rpc " ^ rpc_name)
+       in
+       impl rpc_arg)
+      (fun res ->
+        Brr_webworkers.Worker.G.post
+          (res : ((Jv.t, Jv.Error.t) Result.t, Jv.Error.t) Result.t))
+  else f ()

libs/brrex/brrex.mli

@@ -39,3 +39,12 @@ val download_from_memory :
 val fetch : Jstr.t -> string Fut.or_error
 
 val get_element_by_id : Jstr.t -> Jv.t
+
+type rpc
+val rpc : ('q -> 'r Fut.or_error)
+          -> rpc * (?local:bool -> 'q -> 'r Fut.or_error)
+val rpc_with_progress
+    : (?progress:(int -> unit) -> 'q -> 'r Fut.or_error)
+  -> rpc
+     * (?local:bool -> ?progress:(int -> unit) -> 'q -> 'r Fut.or_error)
+val main : rpc list -> (unit -> unit) -> unit

libs/brrex/dune

@@ -1,4 +1,4 @@
 (library
  (name brrex)
  (libraries brr)
- (preprocess (pps ppx_partial ppx_string)))
+ (preprocess (pps ppx_partial ppx_string ppx_lazy_option_op)))

site/client/page.js

@@ -161,7 +161,7 @@ document.getElementById("download-dict")?.addEventListener("click", async (e) =>
         set_progress(10);
         const [ rules, selection_text ] = dict_gen.currently_selected_rules("conv-");
         const [ dict, _stats ] =
-              await dict_gen.generate("/static", "/static/Lexique383.gen.tsv",
+              await dict_gen.generate("/static/Lexique383.gen.tsv",
                                       "/static/rect1990.csv", rules, 1, false,
                                       (i) => set_progress(10 + i * 8 / 10));
         set_progress(90);