tmp

dune-project

@@ -41,8 +41,12 @@
   cmdliner
   fpath
   bos
+  js_of_ocaml-compiler
+  js_of_ocaml-toplevel
   (opam-format
-   (>= 2.0.0))))
+   (>= 2.0.0))
+  (yojson
+   (>= 1.6.0))))
 
 (package
  (name voodoo-do)

src/voodoo-do/do.ml

@@ -188,6 +188,10 @@ let run pkg_name is_blessed failed =
 
   let package_mlds, otherdocs = Package_mlds.find package in
 
+  let toplevel_files = Js_toplevel.find package in
+  Format.eprintf "Found %d toplevel files\n%!" (List.length toplevel_files);
+  Js_toplevel.copy toplevel_files output_path;
+
   let error_log = Error_log.find package in
 
   let parent =
@@ -267,4 +271,6 @@ let run pkg_name is_blessed failed =
   in
   if failed then
     Bos.OS.File.write Fpath.(output_path / "failed") "failed" |> Result.get_ok;
+  Bos.OS.File.write Fpath.(output_path / "universe.txt") universe
+  |> Result.get_ok;
   ()

src/voodoo-gen/main.ml

@@ -133,11 +133,18 @@ let generate_pkgver output_dir name_filter version_filter =
                   | _ -> { acc with others = path :: acc.others })
                 init otherdocs
             in
-            let status = { Voodoo_serialize.Status.failed; otherdocs } in
-            if Option.is_none universe then
-              Yojson.Safe.to_file
-                Fpath.(output_prefix / "status.json" |> to_string)
-                (Voodoo_serialize.Status.to_yojson status);
+
+            (if Option.is_none universe then
+               let universe =
+                 Bos.OS.File.read Fpath.(pkg_path / "universe.txt")
+                 |> Result.get_ok
+               in
+               let status =
+                 { Voodoo_serialize.Status.failed; universe; otherdocs }
+               in
+               Yojson.Safe.to_file
+                 Fpath.(output_prefix / "status.json" |> to_string)
+                 (Voodoo_serialize.Status.to_yojson status));
 
             match
               Search_index.generate_index

src/voodoo-prep/dune

@@ -2,4 +2,4 @@
  (name main)
  (public_name voodoo-prep)
  (package voodoo-prep)
- (libraries cmdliner fpath bos opam-format))
+ (libraries cmdliner fpath bos.setup opam-format yojson))

src/voodoo-prep/jsoo.ml

@@ -0,0 +1,127 @@
+module Result = Bos_setup.R
+open Result.Infix
+module StringSet = Jsoo_cmi.StringSet
+
+let run path package =
+  Bos.OS.Dir.fold_contents
+    (fun fpath (acc, universes) ->
+      let rel_fpath =
+        match Fpath.relativize ~root:path fpath with
+        | Some x -> x
+        | None -> failwith "Bos error"
+      in
+      let segs = Fpath.segs rel_fpath in
+      let universes =
+        match segs with
+        | "universes" :: universe_id :: _ -> StringSet.add universe_id universes
+        | _ -> universes
+      in
+      let path_relevant =
+        match (package, segs) with
+        | Some s, "universes" :: _universe_id :: package' :: _ -> package' = s
+        | Some _, _ -> false
+        | None, _ -> true
+      in
+      if
+        path_relevant
+        && List.mem (Fpath.get_ext fpath)
+             [ Jsoo_cma.ext; Jsoo_toplevel.meta_ext ]
+      then (fpath :: acc, universes)
+      else (acc, universes))
+    ([], StringSet.empty) path
+  >>= fun (files, universes) ->
+  let toplevels =
+    List.fold_left
+      (fun acc x ->
+        acc >>= fun acc ->
+        if Fpath.has_ext Jsoo_cma.ext x then
+          Jsoo_cma.process x >>| fun () -> acc
+        else Jsoo_toplevel.process x >>| fun t -> t :: acc)
+      (Ok []) files
+  in
+  toplevels >>= fun toplevels ->
+  let cmis =
+    List.concat
+      (List.map (fun toplevel -> toplevel.Jsoo_toplevel.cmis) toplevels)
+    |> List.sort_uniq Jsoo_cmi.compare
+  in
+  Jsoo_cmi.copy universes cmis;
+  toplevels
+  |> List.map (fun t -> t.Jsoo_toplevel.package)
+  |> List.sort_uniq Package.compare
+  |> Util.R.iter_list ~f:(fun package ->
+         toplevels
+         |> List.filter (fun t -> t.Jsoo_toplevel.package = package)
+         |> List.map Jsoo_toplevel.to_yojson
+         |> Util.R.combine_list
+         >>| fun toplevels ->
+         Yojson.Safe.to_file
+           Fpath.(Package.jsoo_path package / "toplevels.json" |> to_string)
+           (`List toplevels))
+
+let copy_files root pkg_contents =
+  let findlib_cmas = Jsoo_cma.findlib () in
+  let pkgs = List.map (fun (x, _, _) -> x) pkg_contents in
+  Jsoo_cmi.stdlib pkgs >>= fun stdlib_cmis ->
+  Util.R.iter_list pkg_contents ~f:(fun (package, cmas, _) ->
+      let findlib_pkgs =
+        List.filter_map
+          (fun p ->
+            match List.assoc_opt Fpath.(root // p) findlib_cmas with
+            | Some pkg -> Some (p, pkg)
+            | None ->
+                Logs.info (fun m ->
+                    m "No findlib pkg for archive %a%!" Fpath.pp p);
+                None)
+          cmas
+      in
+      Util.R.iter_list findlib_pkgs ~f:(fun (cma_fpath, findlib_pkg) ->
+          let cma = Jsoo_cma.{ package; path = cma_fpath } in
+          Jsoo_cma.marshal cma;
+          let include_paths = Ocamlfind.include_paths findlib_pkg in
+          let cmis =
+            List.concat
+              (List.map
+                 (fun (package, _, contents) ->
+                   List.filter_map
+                     (fun path ->
+                       let dir, file = Fpath.split_base path in
+                       if
+                         Fpath.has_ext ".cmi" file
+                         && List.mem
+                              Fpath.(to_string (root // dir))
+                              include_paths
+                       then Some Jsoo_cmi.{ package; path }
+                       else None)
+                     contents)
+                 pkg_contents)
+          in
+          let cmis = cmis @ stdlib_cmis in
+          Ocamlfind.js_files findlib_pkg
+          |> Bos_setup.R.reword_error_msg (fun s ->
+                 Bos_setup.R.msgf "Bad js file for: %a (%s)\n%!" Package.pp
+                   package s)
+          >>| fun js_files ->
+          let dep_cmas =
+            List.filter_map
+              (fun path ->
+                match
+                  List.find_opt
+                    (fun (_, _, contents) ->
+                      List.exists (fun p -> Fpath.(root // p) = path) contents)
+                    pkg_contents
+                with
+                | Some (package, _, _) -> Some { Jsoo_cma.package; path }
+                | None ->
+                    Logs.info (fun m ->
+                        m "Failed to find package containing %a\n%!" Fpath.pp
+                          path);
+                    None)
+              (Ocamlfind.dep_cmas findlib_pkg)
+          in
+          let toplevel : Jsoo_toplevel.t =
+            { package; cma_fpath; js_files; dep_cmas; cmis; digest = None }
+          in
+          Jsoo_toplevel.build_toplevel toplevel;
+          Jsoo_toplevel.copy_js_files root toplevel;
+          Jsoo_toplevel.marshal toplevel))

src/voodoo-prep/jsoo.mli

@@ -0,0 +1,8 @@
+val run : Fpath.t -> string option -> (unit, Bos_setup.R.msg) Bos_setup.result
+(** [run path file] copies [*.js] toplevel files, [*.cmi] and [*.cma] files.
+    Write the configurations in [toplevels.json]. *)
+
+val copy_files :
+  Fpath.t ->
+  (Package.t * Fpath.t list * Fpath.t list) list ->
+  (unit, Bos_setup.R.msg) Bos_setup.result

src/voodoo-prep/jsoo_cma.ml

@@ -0,0 +1,63 @@
+type t = { package : Package.t; path : Fpath.t }
+
+let name v = Fpath.basename v.path
+
+let func_name vv =
+  let n = name vv in
+  Astring.String.cuts ~sep:"." n
+  |> String.concat "_dot_"
+  |> Astring.String.cuts ~sep:"-"
+  |> String.concat "_dash_"
+
+let pp fmt v =
+  Format.fprintf fmt "{ path: %a; package: %a }" Fpath.pp v.path Package.pp
+    v.package
+
+let ext = ".jscma"
+let cma_path vv = Fpath.(Package.prep_path vv.package // vv.path)
+
+let meta_path vv =
+  Fpath.(Package.prep_path vv.package // add_ext ext (v (name vv)))
+
+let output_path vv =
+  Fpath.(Package.jsoo_path vv.package // add_ext ".js" (v (name vv)))
+
+let server_path vv = Fpath.(v "/toplevels" // output_path vv)
+
+let marshal v =
+  let path = meta_path v in
+  let oc = open_out_bin (Fpath.to_string path) in
+  Marshal.to_channel oc v [];
+  close_out oc
+
+let unmarshal path =
+  let ic = open_in_bin path in
+  let result = Marshal.from_channel ic in
+  close_in ic;
+  result
+
+let cmd vv =
+  Bos.Cmd.(
+    v "js_of_ocaml"
+    % p (cma_path vv)
+    % "--pretty" % "--wrap-with-fun" % func_name vv % "-o"
+    % p (output_path vv))
+
+let findlib () =
+  let findlib_pkgs = Ocamlfind.list () in
+  List.filter_map
+    (fun pkg ->
+      match Ocamlfind.cma_of_package pkg with
+      | Some cma -> Some (cma, pkg)
+      | None -> None)
+    findlib_pkgs
+
+let process cma_fpath =
+  Logs.info (fun m -> m "Processing %a%!" Fpath.pp cma_fpath);
+  let cma = unmarshal (Fpath.to_string cma_fpath) in
+  let cmd = cmd cma in
+  let dir = fst (Fpath.split_base (output_path cma)) in
+  Util.mkdir_p dir;
+  Logs.debug (fun m -> m "Cma: %a\n%!" Bos.Cmd.pp cmd);
+  Util.run_silent cmd;
+  Ok ()

src/voodoo-prep/jsoo_cma.mli

@@ -0,0 +1,22 @@
+type t = { package : Package.t; path : Fpath.t }
+
+val marshal : t -> unit
+(** Serialize. *)
+
+val pp : t Fmt.t
+val findlib : unit -> (Fpath.t * string) list
+
+val ext : string
+(** [.jscma] file extension. *)
+
+val server_path : t -> Fpath.t
+
+val func_name : t -> string
+(** [func_name t] changes the name of the name of the cma filename to a valid
+    function name.
+    - [.] are replaced with [_dot_]
+    - [-] are replaced with [_dash_]. *)
+
+val process : Fpath.t -> (unit, Bos_setup.R.msg) Bos_setup.result
+(** [process path] deserializes the cma file located at [path], then runs
+    [js_of_ocaml] on it. *)

src/voodoo-prep/jsoo_cmi.ml

@@ -0,0 +1,62 @@
+module StringSet = Set.Make (String)
+
+type t = { package : Package.t; path : Fpath.t }
+
+let prep_path vv = Fpath.(Package.prep_path vv.package // vv.path)
+let output_path vv = Fpath.(Package.jsoo_path vv.package // vv.path)
+let server_path vv = Fpath.(v "/toplevels" // output_path vv)
+
+let pp fmt v =
+  Format.fprintf fmt "{ package: %a; path: %a }" Package.pp v.package Fpath.pp
+    v.path
+
+let compare v1 v2 =
+  let s1 = Format.asprintf "%a" pp v1 in
+  let s2 = Format.asprintf "%a" pp v2 in
+  String.compare s1 s2
+
+let copy universes cmis =
+  let cmis =
+    List.filter
+      (fun cmi -> StringSet.mem cmi.package.universe_id universes)
+      cmis
+  in
+  let l = List.map (fun cmi -> (prep_path cmi, output_path cmi)) cmis in
+  let dst_dirs =
+    List.map
+      (fun (_, f) ->
+        let dir, _ = Fpath.split_base f in
+        dir)
+      l
+    |> List.sort_uniq Fpath.compare
+  in
+  List.iter Util.mkdir_p dst_dirs;
+  List.iter
+    (fun (src, dst) -> if Fpath.has_ext ".cmi" src then Util.cp src dst)
+    l
+
+let stdlib pkgs =
+  let root = Fpath.v @@ Opam.prefix () in
+  let find_pkg s = List.find (fun { Package.name; _ } -> name = s) pkgs in
+  let stdlib_pkg = find_pkg "ocaml-base-compiler" in
+  let num_pkg = find_pkg "num" in
+  let num_cmis =
+    [ "arith_status.cmi"; "big_int.cmi"; "nat.cmi"; "num.cmi"; "ratio.cmi" ]
+  in
+  let num_path = Ocamlfind.num_path () in
+  Ocamlfind.stdlib_path ()
+  |> Bos.OS.Dir.fold_contents
+       (fun path acc ->
+         if Fpath.has_ext "cmi" path then
+           match Fpath.relativize ~root path with
+           | Some path ->
+               let package, path =
+                 let file = Fpath.filename path in
+                 if List.mem file num_cmis then
+                   (num_pkg, Fpath.(num_path / file))
+                 else (stdlib_pkg, path)
+               in
+               { package; path } :: acc
+           | None -> acc
+         else acc)
+       []

src/voodoo-prep/jsoo_cmi.mli

@@ -0,0 +1,17 @@
+module StringSet : Set.S with type elt = string
+
+type t = { package : Package.t; path : Fpath.t }
+
+val pp : t Fmt.t
+val compare : t -> t -> int
+
+val stdlib : Package.t list -> (t list, Bos_setup.R.msg) Bos_setup.result
+(** [stdlib pkgs] returns the [*.cmi] files from the stdlib. The
+    cmi files are linked to the [ocaml-base-compiler] package
+    found among [pkgs]. *)
+
+val server_path : t -> Fpath.t
+
+val copy : StringSet.t -> t list -> unit
+(** [copy universes cmis] copies [cmis] files whose [universe_id]
+    is included in [universes] from [prep/] to [jsoo/]. *)