Voodoo mode!

In this mode we can process the results of 'voodoo prep' and produce output
that will be compatible with what ocaml.org expects.

Author: jonludlam

src/driver/compile.ml

@@ -2,7 +2,7 @@
 
 type ty = Module of Packages.modulety | Mld of Packages.mld
 
-type impl = { impl : Fpath.t; src : Fpath.t }
+type impl = { impl_odoc : Fpath.t; impl_odocl: Fpath.t; src : Fpath.t }
 
 type pkg_args = {
   docs : (string * Fpath.t) list;
@@ -11,12 +11,14 @@ type pkg_args = {
 
 type compiled = {
   m : ty;
-  output_dir : Fpath.t;
-  output_file : Fpath.t;
+  odoc_output_dir : Fpath.t; (* e.g. "_odoc/base/lib/base/" *)
+  odoc_file : Fpath.t; (* Full path to odoc file *)
+  odocl_file : Fpath.t;
   include_dirs : Fpath.Set.t;
   impl : impl option;
   pkg_args : pkg_args;
-  package_name : string;
+  pkg_name : string;
+  pkg_dir : Fpath.t;
 }
 
 let mk_byhash (pkgs : Packages.t Util.StringMap.t) =
@@ -67,20 +69,53 @@ let init_stats (pkgs : Packages.t Util.StringMap.t) =
 
 open Eio.Std
 
-let compile output_dir all =
+type partial = 
+  (string * compiled) list * (string * Packages.modulety) Util.StringMap.t
+
+let unmarshal filename =
+  let ic = open_in_bin (Fpath.to_string filename) in
+  let (v : partial) = Marshal.from_channel ic in
+  close_in ic;
+  v
+
+let marshal (v : partial) filename =
+  let p = Fpath.parent filename in
+  Util.mkdir_p p;
+  let oc = open_out_bin (Fpath.to_string filename) in
+  Marshal.to_channel oc v [];
+  close_out oc
+
+let find_partials odoc_dir =
+  let tbl = Hashtbl.create 1000 in
+  let hashes_result = Bos.OS.Dir.fold_contents ~dotfiles:false
+  (fun p hashes ->
+    if Fpath.filename p = "index.m"
+    then
+      let (tbl', hashes') = unmarshal p in
+      List.iter (fun (k,v) -> Hashtbl.replace tbl k (Promise.create_resolved (Ok v))) tbl';
+      Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes hashes'
+    else hashes) Util.StringMap.empty odoc_dir in
+  match hashes_result with
+  | Ok h -> h, tbl
+  | Error _ -> (* odoc_dir doesn't exist...? *) Util.StringMap.empty, tbl
+
+let compile partial ~output_dir ?linked_dir all =
+  let linked_dir = Option.value linked_dir ~default:output_dir in
   let hashes = mk_byhash all in
-  let tbl = Hashtbl.create 10 in
+  let other_hashes, tbl =
+    match partial with
+    | Some _ -> find_partials output_dir
+    | None -> Util.StringMap.empty, Hashtbl.create 10 in
+  let all_hashes = Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes other_hashes in
   let pkg_args =
     let docs, libs =
       Util.StringMap.fold
-        (fun pkgname pkg (docs, libs) ->
-          let ( / ) = Fpath.( / ) in
-          let doc = (pkgname, output_dir / pkgname / "doc") in
+        (fun pkgname (pkg : Packages.t) (docs, libs) ->
+          let doc = (pkgname, Fpath.(output_dir // pkg.mld_odoc_dir)) in
           let lib =
             List.map
               (fun lib ->
-                ( lib.Packages.lib_name,
-                  output_dir / pkgname / "lib" / lib.lib_name ))
+                ( lib.Packages.lib_name, Fpath.(output_dir // lib.Packages.odoc_dir )))
               pkg.Packages.libraries
           in
           let docs = doc :: docs and libs = List.rev_append lib libs in
@@ -91,15 +126,16 @@ let compile output_dir all =
   in
 
   let compile_one compile_other hash =
-    match Util.StringMap.find_opt hash hashes with
+    match Util.StringMap.find_opt hash all_hashes with
     | None ->
         Logs.debug (fun m -> m "Error locating hash: %s" hash);
         Error Not_found
     | Some (package_name, modty) ->
         let deps = modty.m_intf.mif_deps in
-        let output_file = Fpath.(output_dir // modty.m_intf.mif_odoc_file) in
+        let odoc_file = Fpath.(output_dir // modty.m_intf.mif_odoc_file) in
+        let odocl_file = Fpath.(linked_dir // modty.m_intf.mif_odocl_file) in
         let fibers =
-          Fiber.List.map
+          List.map
             (fun (n, h) ->
               match compile_other h with
               | Ok r -> Some r
@@ -114,7 +150,7 @@ let compile output_dir all =
           List.fold_left
             (fun acc opt ->
               match opt with
-              | Some s -> Fpath.(Set.add s.output_dir acc)
+              | Some s -> Fpath.(Set.add s.odoc_output_dir acc)
               | _ -> acc)
             Fpath.Set.empty fibers
         in
@@ -124,11 +160,12 @@ let compile output_dir all =
           | Some impl -> (
               match impl.mip_src_info with
               | Some si ->
-                  let output_file = Fpath.(output_dir // impl.mip_odoc_file) in
+                  let odoc_file = Fpath.(output_dir // impl.mip_odoc_file) in
+                  let odocl_file = Fpath.(linked_dir // impl.mip_odocl_file) in
                   Odoc.compile_impl ~output_dir ~input_file:impl.mip_path
                     ~includes ~parent_id:impl.mip_parent_id ~source_id:si.src_id;
                   Atomic.incr Stats.stats.compiled_impls;
-                  Some { impl = output_file; src = si.src_path }
+                  Some { impl_odoc = odoc_file; impl_odocl=odocl_file; src = si.src_path }
               | None -> None)
           | None -> None
         in
@@ -137,45 +174,51 @@ let compile output_dir all =
           ~parent_id:modty.m_intf.mif_parent_id;
         Atomic.incr Stats.stats.compiled_units;
 
-        let output_dir = Fpath.split_base output_file |> fst in
+        let odoc_output_dir = Fpath.split_base odoc_file |> fst in
+
         Ok
           {
             m = Module modty;
-            output_dir;
-            output_file;
+            odoc_output_dir;
+            odoc_file;
+            odocl_file;
             include_dirs = includes;
             impl;
             pkg_args;
-            package_name;
+            pkg_dir = modty.m_pkg_dir;
+            pkg_name = package_name;
           }
   in
 
   let rec compile : string -> (compiled, exn) Result.t =
    fun hash ->
     match Hashtbl.find_opt tbl hash with
-    | Some p -> Promise.await_exn p
+    | Some p -> Promise.await p
     | None ->
         let p, r = Promise.create () in
         Hashtbl.add tbl hash p;
         let result = compile_one compile hash in
-        Promise.resolve_ok r result;
+        Promise.resolve r result;
         result
   in
-  let all_hashes = Util.StringMap.bindings hashes |> List.map fst in
-  let mod_results = Fiber.List.map compile all_hashes in
+  let to_build = Util.StringMap.bindings hashes |> List.map fst in
+  let mod_results = List.map compile to_build in
+  let zipped_res = List.map2 (fun a b -> (a,b)) to_build mod_results in
+  let zipped = List.filter_map (function (a, Ok b) -> Some (a,b) | _ -> None) zipped_res in
   let mods =
     List.filter_map (function Ok x -> Some x | Error _ -> None) mod_results
   in
-  Util.StringMap.fold
+  let result = Util.StringMap.fold
     (fun package_name (pkg : Packages.t) acc ->
       Logs.debug (fun m ->
           m "Package %s mlds: [%a]" pkg.name
             Fmt.(list ~sep:sp Packages.pp_mld)
             pkg.mlds);
       List.fold_left
         (fun acc (mld : Packages.mld) ->
-          let output_file = Fpath.(output_dir // mld.Packages.mld_odoc_file) in
-          let odoc_output_dir = Fpath.split_base output_file |> fst in
+          let odoc_file = Fpath.(output_dir // mld.Packages.mld_odoc_file) in
+          let odocl_file = Fpath.(linked_dir // mld.Packages.mld_odocl_file) in
+          let odoc_output_dir = Fpath.split_base odoc_file |> fst in
           Odoc.compile ~output_dir ~input_file:mld.mld_path
             ~includes:Fpath.Set.empty ~parent_id:mld.mld_parent_id;
           Atomic.incr Stats.stats.compiled_mlds;
@@ -184,128 +227,124 @@ let compile output_dir all =
             |> Fpath.Set.of_list
           in
           let include_dirs = Fpath.Set.add odoc_output_dir include_dirs in
+          let odoc_output_dir = Fpath.split_base odoc_file |> fst in
           {
             m = Mld mld;
-            output_dir;
-            output_file;
+            odoc_output_dir;
+            odoc_file;
+            odocl_file;
             include_dirs;
             impl = None;
             pkg_args;
-            package_name;
+            pkg_dir = mld.mld_pkg_dir;
+            pkg_name = package_name;
           }
           :: acc)
         acc pkg.mlds)
-    all mods
+    all mods in
+
+  (match partial with
+  | Some l -> marshal (zipped, hashes) Fpath.(l / "index.m")
+  | None -> ());
+  result
 
 type linked = {
   output_file : Fpath.t;
   src : Fpath.t option;
-  package_name : string;
+  pkg_dir : Fpath.t;
 }
 
 let link : compiled list -> _ =
  fun compiled ->
   let link : compiled -> linked list =
    fun c ->
-    let includes = Fpath.Set.add c.output_dir c.include_dirs in
-    let link input_file =
-      let { pkg_args = { libs; docs }; package_name = current_package; _ } =
+    let includes = Fpath.Set.add c.odoc_output_dir c.include_dirs in
+    let link input_file output_file =
+      let { pkg_args = { libs; docs }; pkg_name; _ } =
         c
       in
-      Odoc.link ~input_file ~includes ~libs ~docs ~current_package ()
+      Odoc.link ~input_file ~output_file ~includes ~libs ~docs ~current_package:pkg_name ()
     in
     let impl =
       match c.impl with
-      | Some { impl; src } ->
-          Logs.debug (fun m -> m "Linking impl: %a" Fpath.pp impl);
-          link impl;
+      | Some { impl_odoc; impl_odocl; src } ->
+          Logs.debug (fun m -> m "Linking impl: %a -> %a" Fpath.pp impl_odoc Fpath.pp impl_odocl);
+          link impl_odoc impl_odocl;
           Atomic.incr Stats.stats.linked_impls;
           [
             {
-              package_name = c.package_name;
-              output_file = Fpath.(set_ext "odocl" impl);
+              pkg_dir = c.pkg_dir;
+              output_file = impl_odocl;
               src = Some src;
             };
           ]
       | None -> []
     in
     match c.m with
     | Module m when m.m_hidden ->
-        Logs.debug (fun m -> m "not linking %a" Fpath.pp c.output_file);
+        Logs.debug (fun m -> m "not linking %a" Fpath.pp c.odoc_file);
         impl
     | _ ->
-        Logs.debug (fun m -> m "linking %a" Fpath.pp c.output_file);
-        link c.output_file;
+        Logs.debug (fun m -> m "linking %a" Fpath.pp c.odoc_file);
+        link c.odoc_file c.odocl_file;
         (match c.m with
         | Module _ -> Atomic.incr Stats.stats.linked_units
         | Mld _ -> Atomic.incr Stats.stats.linked_mlds);
         {
-          output_file = Fpath.(set_ext "odocl" c.output_file);
+          output_file = c.odocl_file;
           src = None;
-          package_name = c.package_name;
+          pkg_dir = c.pkg_dir;
         }
         :: impl
   in
   Fiber.List.map link compiled |> List.concat
 
-let odoc_index_path ~odoc_dir pkgname =
-  Fpath.(odoc_dir / pkgname / "index.odoc-index")
-let sherlodoc_js_index_path_relative_to_html pkgname =
-  Fpath.(v pkgname / "sherlodoc_db.js")
-
-let sherlodoc_js_path_relative_to_html = Fpath.v "sherlodoc.js"
-let sherlodoc_js_index_path ~html_dir pkgname =
-  Fpath.(html_dir // sherlodoc_js_index_path_relative_to_html pkgname)
-
-let sherlodoc_js_path ~html_dir =
-  Fpath.(html_dir // sherlodoc_js_path_relative_to_html)
-
-let sherlodoc_marshall_path ~html_dir =
-  Fpath.(html_dir / "sherlodoc_db.marshal")
-let index_one output_dir pkgname pkg =
-  let dir = Fpath.(output_dir / pkgname) in
-  let output_file = odoc_index_path ~odoc_dir:output_dir pkgname in
-  let ( / ) = Fpath.( / ) in
+let index_one ~odocl_dir pkgname pkg =
+  let dir = pkg.Packages.pkg_dir in
+  let output_file = Fpath.(odocl_dir // dir / Odoc.index_filename) in
   let libs =
     List.map
-      (fun lib -> (lib.Packages.lib_name, dir / "lib" / lib.lib_name))
+      (fun lib ->
+        (lib.Packages.lib_name, Fpath.(odocl_dir // lib.odoc_dir)))
       pkg.Packages.libraries
   in
   Odoc.compile_index ~json:false ~output_file ~libs
-    ~docs:[ (pkgname, dir / "doc") ]
+    ~docs:[ (pkgname, Fpath.(odocl_dir // pkg.mld_odoc_dir)) ]
     ()
 
-let index odoc_dir pkgs = Util.StringMap.iter (index_one odoc_dir) pkgs
+let index ~odocl_dir pkgs = Util.StringMap.iter (index_one ~odocl_dir) pkgs
 
-let sherlodoc_index_one ~html_dir ~odoc_dir pkgname _pkg_content =
-  ignore @@ Bos.OS.Dir.create Fpath.(html_dir / pkgname);
-  let format = `js in
-  let inputs = [ odoc_index_path ~odoc_dir pkgname ] in
-  let dst = sherlodoc_js_index_path ~html_dir pkgname in
-  Sherlodoc.index ~format ~inputs ~dst ()
+let sherlodoc_index_one ~html_dir ~odocl_dir _ pkg_content =
+  let inputs = [ Fpath.(odocl_dir // pkg_content.Packages.pkg_dir / Odoc.index_filename) ] in
+  let dst = Fpath.(html_dir // Sherlodoc.db_js_file pkg_content.pkg_dir) in
+  let dst_dir, _ = Fpath.split_base dst in
+  Util.mkdir_p dst_dir;
+  Sherlodoc.index ~format:`js ~inputs ~dst ()
 
-let sherlodoc ~html_dir ~odoc_dir pkgs =
+let sherlodoc ~html_dir ~odocl_dir pkgs =
   ignore @@ Bos.OS.Dir.create html_dir;
-  Sherlodoc.js (sherlodoc_js_path ~html_dir);
-  Util.StringMap.iter (sherlodoc_index_one ~html_dir ~odoc_dir) pkgs;
+  Sherlodoc.js Fpath.(html_dir // Sherlodoc.js_file);
+  Util.StringMap.iter (sherlodoc_index_one ~html_dir ~odocl_dir) pkgs;
   let format = `marshal in
-  let dst = sherlodoc_marshall_path ~html_dir in
+  let dst = Fpath.(html_dir // Sherlodoc.db_marshal_file) in
+  let dst_dir, _ = Fpath.split_base dst in
+  Util.mkdir_p dst_dir;
   let inputs =
     pkgs |> Util.StringMap.bindings
-    |> List.map (fun (pkgname, _pkg) -> odoc_index_path ~odoc_dir pkgname)
+    |> List.map (fun (_pkgname, pkg) -> Fpath.(odocl_dir // pkg.Packages.pkg_dir / Odoc.index_filename))
   in
   Sherlodoc.index ~format ~inputs ~dst ()
 
-let html_generate output_dir ~odoc_dir linked =
+let html_generate output_dir ~odocl_dir linked =
   let html_generate : linked -> unit =
    fun l ->
     let search_uris =
       [
-        sherlodoc_js_index_path_relative_to_html l.package_name;
-        sherlodoc_js_path_relative_to_html;
+        Sherlodoc.db_js_file l.pkg_dir;
+        Sherlodoc.js_file;
       ]
     in
-    let index = Some (odoc_index_path ~odoc_dir l.package_name) in
+    let index = Some (Fpath.(odocl_dir // l.pkg_dir / Odoc.index_filename)) in
     Odoc.html_generate ~search_uris ?index
       ~output_dir:(Fpath.to_string output_dir)
       ~input_file:l.output_file ?source:l.src ();

src/driver/compile.mli

@@ -2,20 +2,20 @@ type compiled
 
 val init_stats : Packages.set -> unit
 
-val compile : Fpath.t -> Packages.set -> compiled list
+val compile : Fpath.t option -> output_dir:Fpath.t -> ?linked_dir:Fpath.t -> Packages.set -> compiled list
 
 type linked
 
 val link : compiled list -> linked list
 
-val index : Fpath.t -> Packages.set -> unit
+val index : odocl_dir:Fpath.t -> Packages.set -> unit
 
-val sherlodoc : html_dir:Fpath.t -> odoc_dir:Fpath.t -> Packages.set -> unit
+val sherlodoc : html_dir:Fpath.t -> odocl_dir:Fpath.t -> Packages.set -> unit
 
 (* val compile_sidebars : *)
 (*   odoc_dir:Fpath.t -> *)
 (*   output_dir:Fpath.t -> *)
 (*   Packages.set -> *)
 (*   Fpath.t Util.StringMap.t *)
 
-val html_generate : Fpath.t -> odoc_dir:Fpath.t -> linked list -> unit
+val html_generate : Fpath.t -> odocl_dir:Fpath.t -> linked list -> unit