Add a marshalled output for index generation

CHANGES.md

@@ -16,6 +16,7 @@
 - Path-references to hierarchical pages and modules (@Julow, #1151)
   Absolute (`{!/foo}`), relative (`{!./foo}`) and package-local (`{!//foo}`)
   are added.
+- Add a marshalled search index consumable by sherlodoc (@EmileTrotignon, @panglesd, #1084)
 
 ### Changed
 

odoc-driver.opam

@@ -34,7 +34,7 @@ documentation for installed packages.
 
 depends: [
   "odoc" {= version}
-  "bos" 
+  "bos"
   "fpath"
   "yojson"
   "ocamlfind"

src/driver/cmd_outputs.ml

@@ -0,0 +1,20 @@
+let submit desc cmd output_file =
+  match Worker_pool.submit desc cmd output_file with
+  | Ok x -> x
+  | Error exn -> raise exn
+
+let compile_output = ref [ "" ]
+
+let compile_src_output = ref [ "" ]
+
+let link_output = ref [ "" ]
+
+let generate_output = ref [ "" ]
+
+let source_tree_output = ref [ "" ]
+
+let add_prefixed_output cmd list prefix lines =
+  if List.length lines > 0 then
+    list :=
+      !list
+      @ (Bos.Cmd.to_string cmd :: List.map (fun l -> prefix ^ ": " ^ l) lines)

src/driver/compile.ml

@@ -16,17 +16,17 @@ type compiled = {
   include_dirs : Fpath.Set.t;
   impl : impl option;
   pkg_args : pkg_args;
-  current_package : string;
+  pkgname : string;
 }
 
 let mk_byhash (pkgs : Packages.t Util.StringMap.t) =
   Util.StringMap.fold
-    (fun _pkg_name pkg acc ->
+    (fun pkg_name pkg acc ->
       List.fold_left
         (fun acc (lib : Packages.libty) ->
           List.fold_left
             (fun acc (m : Packages.modulety) ->
-              Util.StringMap.add m.m_intf.mif_hash m acc)
+              Util.StringMap.add m.m_intf.mif_hash (pkg_name, m) acc)
             acc lib.modules)
         acc pkg.Packages.libraries)
     pkgs Util.StringMap.empty
@@ -95,7 +95,7 @@ let compile output_dir all =
     | None ->
         Logs.debug (fun m -> m "Error locating hash: %s" hash);
         Error Not_found
-    | Some modty ->
+    | Some (pkgname, modty) ->
         let deps = modty.m_intf.mif_deps in
         let output_file = Fpath.(output_dir // modty.m_intf.mif_odoc_file) in
         let fibers =
@@ -146,7 +146,7 @@ let compile output_dir all =
             include_dirs = includes;
             impl;
             pkg_args;
-            current_package = modty.m_package;
+            pkgname;
           }
   in
 
@@ -167,7 +167,7 @@ let compile output_dir all =
     List.filter_map (function Ok x -> Some x | Error _ -> None) mod_results
   in
   Util.StringMap.fold
-    (fun _ (pkg : Packages.t) acc ->
+    (fun pkgname (pkg : Packages.t) acc ->
       Logs.debug (fun m ->
           m "Package %s mlds: [%a]" pkg.name
             Fmt.(list ~sep:sp Packages.pp_mld)
@@ -191,21 +191,21 @@ let compile output_dir all =
             include_dirs;
             impl = None;
             pkg_args;
-            current_package = pkg.name;
+            pkgname : string;
           }
           :: acc)
         acc pkg.mlds)
     all mods
 
-type linked = { output_file : Fpath.t; src : Fpath.t option }
+type linked = { output_file : Fpath.t; src : Fpath.t option; pkgname : string }
 
 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 }; current_package; _ } = c in
+      let { pkg_args = { libs; docs }; pkgname = current_package; _ } = c in
       Odoc.link ~input_file ~includes ~libs ~docs ~current_package ()
     in
     let impl =
@@ -214,7 +214,13 @@ let link : compiled list -> _ =
           Logs.debug (fun m -> m "Linking impl: %a" Fpath.pp impl);
           link impl;
           Atomic.incr Stats.stats.linked_impls;
-          [ { output_file = Fpath.(set_ext "odocl" impl); src = Some src } ]
+          [
+            {
+              output_file = Fpath.(set_ext "odocl" impl);
+              src = Some src;
+              pkgname = c.pkgname;
+            };
+          ]
       | None -> []
     in
     match c.m with
@@ -227,16 +233,66 @@ let link : compiled list -> _ =
         (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); src = None }
+        {
+          output_file = Fpath.(set_ext "odocl" c.output_file);
+          src = None;
+          pkgname = c.pkgname;
+        }
         :: 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 dst = odoc_index_path ~odoc_dir:output_dir pkgname in
+  let include_rec = Fpath.Set.singleton dir in
+  Odoc.compile_index ~json:false ~dst ~include_rec ()
+let index odoc_dir pkgs = Util.StringMap.iter (index_one odoc_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 ~html_dir ~odoc_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;
+  let format = `marshal in
+  let dst = sherlodoc_marshall_path ~html_dir in
+  let inputs =
+    pkgs |> Util.StringMap.bindings
+    |> List.map (fun (pkgname, _pkg) -> odoc_index_path ~odoc_dir pkgname)
+  in
+  Sherlodoc.index ~format ~inputs ~dst ()
+
 let html_generate : Fpath.t -> linked list -> _ =
  fun output_dir linked ->
   let html_generate : linked -> unit =
    fun l ->
-    Odoc.html_generate
+    let search_uris =
+      [
+        sherlodoc_js_index_path_relative_to_html l.pkgname;
+        sherlodoc_js_path_relative_to_html;
+      ]
+    in
+    Odoc.html_generate ~search_uris
       ~output_dir:(Fpath.to_string output_dir)
       ~input_file:l.output_file ?source:l.src ();
     Atomic.incr Stats.stats.generated_units

src/driver/compile.mli

@@ -8,4 +8,8 @@ type linked
 
 val link : compiled list -> linked list
 
+val index : Fpath.t -> Packages.set -> unit
+
+val sherlodoc : html_dir:Fpath.t -> odoc_dir:Fpath.t -> Packages.set -> unit
+
 val html_generate : Fpath.t -> linked list -> unit

src/driver/odoc.ml

@@ -5,31 +5,10 @@ type compile_deps = { digest : Digest.t; deps : (string * Digest.t) list }
 let odoc = Cmd.v "./_build/default/src/odoc/bin/main.exe"
 (* This is the just-built odoc binary *)
 
-let submit desc cmd output_file =
-  match Worker_pool.submit desc cmd output_file with
-  | Ok x -> x
-  | Error exn -> raise exn
-
-let compile_output = ref [ "" ]
-
-let compile_src_output = ref [ "" ]
-
-let link_output = ref [ "" ]
-
-let generate_output = ref [ "" ]
-
-let source_tree_output = ref [ "" ]
-
-let add_prefixed_output cmd list prefix lines =
-  if List.length lines > 0 then
-    list :=
-      !list
-      @ (Bos.Cmd.to_string cmd :: List.map (fun l -> prefix ^ ": " ^ l) lines)
-
 let compile_deps f =
   let cmd = Cmd.(odoc % "compile-deps" % Fpath.to_string f) in
   let desc = Printf.sprintf "Compile deps for %s" (Fpath.to_string f) in
-  let deps = submit desc cmd None in
+  let deps = Cmd_outputs.submit desc cmd None in
   let l = List.filter_map (Astring.String.cut ~sep:" ") deps in
   let basename = Fpath.(basename (f |> rem_ext)) |> String.capitalize_ascii in
   match List.partition (fun (n, _) -> basename = n) l with
@@ -53,8 +32,9 @@ let compile ~output_dir ~input_file:file ~includes ~parent_id =
   in
   let cmd = cmd % "--parent-id" % parent_id in
   let desc = Printf.sprintf "Compiling %s" (Fpath.to_string file) in
-  let lines = submit desc cmd output_file in
-  add_prefixed_output cmd compile_output (Fpath.to_string file) lines
+  let lines = Cmd_outputs.submit desc cmd output_file in
+  Cmd_outputs.(
+    add_prefixed_output cmd compile_output (Fpath.to_string file) lines)
 
 let compile_impl ~output_dir ~input_file:file ~includes ~parent_id ~source_id =
   let open Cmd in
@@ -78,8 +58,9 @@ let compile_impl ~output_dir ~input_file:file ~includes ~parent_id ~source_id =
   let desc =
     Printf.sprintf "Compiling implementation %s" (Fpath.to_string file)
   in
-  let lines = submit desc cmd output_file in
-  add_prefixed_output cmd compile_output (Fpath.to_string file) lines
+  let lines = Cmd_outputs.submit desc cmd output_file in
+  Cmd_outputs.(
+    add_prefixed_output cmd compile_output (Fpath.to_string file) lines)
 
 let link ?(ignore_output = false) ~input_file:file ~includes ~docs ~libs
     ~current_package () =
@@ -113,9 +94,26 @@ let link ?(ignore_output = false) ~input_file:file ~includes ~docs ~libs
   in
   let desc = Printf.sprintf "Linking %s" (Fpath.to_string file) in
 
-  let lines = submit desc cmd (Some output_file) in
+  let lines = Cmd_outputs.submit desc cmd (Some output_file) in
   if not ignore_output then
-    add_prefixed_output cmd link_output (Fpath.to_string file) lines
+    Cmd_outputs.(
+      add_prefixed_output cmd link_output (Fpath.to_string file) lines)
+
+let compile_index ?(ignore_output = false) ~dst ~json ~include_rec () =
+  let include_rec =
+    Fpath.Set.fold
+      (fun path acc -> Cmd.(acc % "--include-rec" % p path))
+      include_rec Cmd.empty
+  in
+  let json = if json then Cmd.v "--json" else Cmd.empty in
+  let cmd =
+    Cmd.(odoc % "compile-index" %% json %% v "-o" % p dst %% include_rec)
+  in
+  let desc = "Generating search index" in
+  let lines = Cmd_outputs.submit desc cmd (Some dst) in
+  if not ignore_output then
+    Cmd_outputs.(
+      add_prefixed_output cmd link_output (Fpath.to_string dst) lines)
 
 let html_generate ~output_dir ?(ignore_output = false) ?(assets = []) ?source
     ?(search_uris = []) ~input_file:file () =
@@ -136,21 +134,22 @@ let html_generate ~output_dir ?(ignore_output = false) ?(assets = []) ?source
     % output_dir
   in
   let desc = Printf.sprintf "Generating HTML for %s" (Fpath.to_string file) in
-  let lines = submit desc cmd None in
+  let lines = Cmd_outputs.submit desc cmd None in
   if not ignore_output then
-    add_prefixed_output cmd generate_output (Fpath.to_string file) lines
+    Cmd_outputs.(
+      add_prefixed_output cmd generate_output (Fpath.to_string file) lines)
 
 let support_files path =
   let open Cmd in
   let cmd = odoc % "support-files" % "-o" % Fpath.to_string path in
   let desc = "Generating support files" in
-  submit desc cmd None
+  Cmd_outputs.submit desc cmd None
 
 let count_occurrences output =
   let open Cmd in
   let cmd = odoc % "count-occurrences" % "-I" % "." % "-o" % p output in
   let desc = "Counting occurrences" in
-  submit desc cmd None
+  Cmd_outputs.submit desc cmd None
 
 let source_tree ?(ignore_output = false) ~parent ~output file =
   let open Cmd in
@@ -159,15 +158,18 @@ let source_tree ?(ignore_output = false) ~parent ~output file =
     odoc % "source-tree" % "-I" % "." %% parent % "-o" % p output % p file
   in
   let desc = Printf.sprintf "Source tree for %s" (Fpath.to_string file) in
-  let lines = submit desc cmd None in
+  let lines = Cmd_outputs.submit desc cmd None in
   if not ignore_output then
-    add_prefixed_output cmd source_tree_output (Fpath.to_string file) lines
+    Cmd_outputs.(
+      add_prefixed_output cmd source_tree_output (Fpath.to_string file) lines)
 
 let classify dir =
   let open Cmd in
   let cmd = odoc % "classify" % p dir in
   let desc = Printf.sprintf "Classifying %s" (Fpath.to_string dir) in
-  let lines = submit desc cmd None |> List.filter (fun l -> l <> "") in
+  let lines =
+    Cmd_outputs.submit desc cmd None |> List.filter (fun l -> l <> "")
+  in
   List.map
     (fun line ->
       match String.split_on_char ' ' line with

src/driver/odoc.mli

@@ -25,6 +25,14 @@ val link :
   unit ->
   unit
 
+val compile_index :
+  ?ignore_output:bool ->
+  dst:Fpath.t ->
+  json:bool ->
+  include_rec:Fpath.set ->
+  unit ->
+  unit
+
 val html_generate :
   output_dir:string ->
   ?ignore_output:bool ->
@@ -36,11 +44,6 @@ val html_generate :
   unit
 val support_files : Fpath.t -> string list
 
-val compile_output : string list ref
-val compile_src_output : string list ref
-val link_output : string list ref
-val generate_output : string list ref
-val source_tree_output : string list ref
 val count_occurrences : Fpath.t -> string list
 val source_tree :
   ?ignore_output:bool -> parent:string -> output:Fpath.t -> Fpath.t -> unit

src/driver/odoc_driver.ml

@@ -514,6 +514,8 @@ let run libs verbose odoc_dir html_dir stats nb_workers =
       (fun () ->
         let compiled = Compile.compile odoc_dir all in
         let linked = Compile.link compiled in
+        let () = Compile.index odoc_dir all in
+        let () = Compile.sherlodoc ~html_dir ~odoc_dir all in
         let () = Compile.html_generate html_dir linked in
         let _ = Odoc.support_files html_dir in
         ())