Driver: allow overriding main package index

src/driver/bin/odoc_driver.ml

@@ -7,7 +7,7 @@ let with_dir dir pat f =
   | Some dir -> f dir ()
 
 let run_inner ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ~compile_grep ~link_grep
-    ~generate_grep ~index_grep ~remap packages
+    ~generate_grep ~index_grep ~remap ~index_mld packages
     {
       Common_args.verbose;
       html_dir;
@@ -27,6 +27,16 @@ let run_inner ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ~compile_grep ~link_grep
   Logs.set_reporter (Logs_fmt.reporter ());
   Stats.init_nprocs nb_workers;
 
+  let index_mld_content =
+    Option.bind index_mld (fun fpath ->
+        match Bos.OS.File.read fpath with
+        | Ok content -> Some content
+        | Error (`Msg msg) ->
+            Logs.err (fun m ->
+                m "Failed to read index_mld file '%a': %s" Fpath.pp fpath msg);
+            exit 1)
+  in
+
   Eio_main.run @@ fun env ->
   Eio.Switch.run @@ fun sw ->
   let () = Worker_pool.start_workers env sw nb_workers in
@@ -45,7 +55,9 @@ let run_inner ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ~compile_grep ~link_grep
       (fun () ->
         let units =
           let dirs = { Odoc_unit.odoc_dir; odocl_dir; index_dir; mld_dir } in
-          Odoc_units_of.packages ~dirs ~indices_style:Odoc_units_of.Normal
+          Odoc_units_of.packages ~dirs
+            ~indices_style:
+              (Odoc_units_of.Normal { toplevel_content = index_mld_content })
             ~extra_paths ~remap all
         in
         Compile.init_stats units;
@@ -124,14 +136,14 @@ let run_inner ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ~compile_grep ~link_grep
   if stats then Stats.bench_results html_dir
 
 let run odoc_dir odocl_dir index_dir mld_dir compile_grep link_grep
-    generate_grep index_grep remap packages common () =
+    generate_grep index_grep remap packages index_mld common () =
   with_dir odoc_dir "odoc-%s" @@ fun odoc_dir () ->
   with_dir odocl_dir "odocl-%s" @@ fun odocl_dir () ->
   with_dir index_dir "index-%s" @@ fun index_dir () ->
   with_dir mld_dir "mld-%s" @@ fun mld_dir () ->
   let () =
     run_inner ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ~compile_grep ~link_grep
-      ~generate_grep ~index_grep ~remap packages common
+      ~generate_grep ~index_grep ~remap ~index_mld packages common
   in
   ()
 
@@ -189,10 +201,20 @@ let remap =
 
 let packages = Arg.(value & pos_all string [] & info [] ~docv:"PACKAGES")
 
+let index_mld =
+  let doc =
+    "Provide an index.mld file to serve as the top-level index of the \
+     documentation"
+  in
+  Arg.(
+    value
+    & opt (some Common_args.fpath_arg) None
+    & info [ "index-mld" ] ~docv:"INDEX" ~doc)
+
 let cmd_term =
   Term.(
     const run $ odoc_dir $ odocl_dir $ index_dir $ mld_dir $ compile_grep
-    $ link_grep $ generate_grep $ index_grep $ remap $ packages
+    $ link_grep $ generate_grep $ index_grep $ remap $ packages $ index_mld
     $ Common_args.term $ const ())
 
 let cmd =

src/driver/compile.ml

@@ -2,13 +2,13 @@
 
 open Bos
 
-type compiled = Odoc_unit.t
+type compiled = Odoc_unit.any
 
 let odoc_partial_filename = "__odoc_partial.m"
 
-let mk_byhash (pkgs : Odoc_unit.t list) =
+let mk_byhash (pkgs : Odoc_unit.any list) =
   List.fold_left
-    (fun acc (u : Odoc_unit.t) ->
+    (fun acc (u : Odoc_unit.any) ->
       match u.Odoc_unit.kind with
       | `Intf { hash; _ } as kind ->
           let elt = { u with kind } in
@@ -18,11 +18,11 @@ let mk_byhash (pkgs : Odoc_unit.t list) =
       | _ -> acc)
     Util.StringMap.empty pkgs
 
-let init_stats (units : Odoc_unit.t list) =
+let init_stats (units : Odoc_unit.any list) =
   let total, total_impl, non_hidden, mlds, assets, indexes =
     List.fold_left
       (fun (total, total_impl, non_hidden, mlds, assets, indexes)
-           (unit : Odoc_unit.t) ->
+           (unit : Odoc_unit.any) ->
         let total = match unit.kind with `Intf _ -> total + 1 | _ -> total in
         let total_impl =
           match unit.kind with `Impl _ -> total_impl + 1 | _ -> total_impl
@@ -56,8 +56,8 @@ let init_stats (units : Odoc_unit.t list) =
 open Eio.Std
 
 type partial =
-  ((string * string) * Odoc_unit.intf Odoc_unit.unit list) list
-  * Odoc_unit.intf Odoc_unit.unit list Util.StringMap.t
+  ((string * string) * Odoc_unit.intf Odoc_unit.t list) list
+  * Odoc_unit.intf Odoc_unit.t list Util.StringMap.t
 
 let unmarshal filename : partial =
   let ic = open_in_bin (Fpath.to_string filename) in
@@ -73,7 +73,7 @@ let marshal (v : partial) filename =
     (fun () -> Marshal.to_channel oc v [])
 
 let find_partials odoc_dir :
-    Odoc_unit.intf Odoc_unit.unit list Util.StringMap.t * _ =
+    Odoc_unit.intf Odoc_unit.t list Util.StringMap.t * _ =
   let tbl = Hashtbl.create 1000 in
   let hashes_result =
     OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
@@ -94,7 +94,7 @@ let find_partials odoc_dir :
   | Ok h -> (h, tbl)
   | Error _ -> (* odoc_dir doesn't exist...? *) (Util.StringMap.empty, tbl)
 
-let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
+let compile ?partial ~partial_dir (all : Odoc_unit.any list) =
   let hashes = mk_byhash all in
   let compile_mod =
     (* Modules have a more complicated compilation because:
@@ -119,7 +119,7 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
       | Some units ->
           Ok
             (List.map
-               (fun (unit : Odoc_unit.intf Odoc_unit.unit) ->
+               (fun (unit : Odoc_unit.intf Odoc_unit.t) ->
                  let deps = match unit.kind with `Intf { deps; _ } -> deps in
                  let _fibers =
                    Fiber.List.map
@@ -152,7 +152,7 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
                units)
     in
     let rec compile_mod :
-        string -> (Odoc_unit.intf Odoc_unit.unit list, exn) Result.t =
+        string -> (Odoc_unit.intf Odoc_unit.t list, exn) Result.t =
      fun hash ->
       let units = try Util.StringMap.find hash hashes with _ -> [] in
       let r =
@@ -185,9 +185,9 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
     compile_mod
   in
 
-  let compile (unit : Odoc_unit.t) =
+  let compile (unit : Odoc_unit.any) =
     match unit.kind with
-    | `Intf intf -> (compile_mod intf.hash :> (Odoc_unit.t list, _) Result.t)
+    | `Intf intf -> (compile_mod intf.hash :> (Odoc_unit.any list, _) Result.t)
     | `Impl src ->
         let includes =
           List.fold_left
@@ -242,7 +242,7 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
   | None -> ());
   all
 
-type linked = Odoc_unit.t
+type linked = Odoc_unit.any
 
 let link : custom_layout:bool -> compiled list -> _ =
  fun ~custom_layout compiled ->

src/driver/compile.mli

@@ -1,9 +1,9 @@
-type compiled = Odoc_unit.t
+type compiled = Odoc_unit.any
 
-val init_stats : Odoc_unit.t list -> unit
+val init_stats : Odoc_unit.any list -> unit
 
 val compile :
-  ?partial:Fpath.t -> partial_dir:Fpath.t -> Odoc_unit.t list -> compiled list
+  ?partial:Fpath.t -> partial_dir:Fpath.t -> Odoc_unit.any list -> compiled list
 (** Use [partial] to reuse the output of a previous call to [compile]. Useful in
     the voodoo context.
 

src/driver/landing_pages.ml

@@ -3,7 +3,8 @@ open Packages
 
 let fpf = Format.fprintf
 
-let make_index ~dirs ~rel_dir ?(libs = []) ?(pkgs = []) ?index ~content () =
+let make_index ~dirs ~rel_dir ~libs ~pkgs ~index ~enable_warnings ~content :
+    Odoc_unit.mld Odoc_unit.t =
   let { odoc_dir; odocl_dir; mld_dir; _ } = dirs in
   let input_file = Fpath.(mld_dir // rel_dir / "index.mld") in
   let odoc_file = Fpath.(odoc_dir // rel_dir / "page-index.odoc") in
@@ -29,7 +30,7 @@ let make_index ~dirs ~rel_dir ?(libs = []) ?(pkgs = []) ?index ~content () =
     input_file;
     odoc_file;
     odocl_file;
-    enable_warnings = false;
+    enable_warnings;
     to_output = true;
     kind = `Mld;
     index;
@@ -56,7 +57,8 @@ let library ~dirs ~pkg ~index lib =
   in
   let rel_dir = lib_dir pkg lib in
   let libs = [ (pkg, lib) ] in
-  make_index ~dirs ~rel_dir ~libs ~index ~content ()
+  make_index ~dirs ~rel_dir ~libs ~pkgs:[] ~index:(Some index) ~content
+    ~enable_warnings:false
 
 let package ~dirs ~pkg ~index =
   let library_list ppf pkg =
@@ -83,7 +85,8 @@ let package ~dirs ~pkg ~index =
   let content = content pkg in
   let rel_dir = doc_dir pkg in
   let libs = List.map (fun lib -> (pkg, lib)) pkg.libraries in
-  make_index ~dirs ~rel_dir ~index ~content ~pkgs:[ pkg ] ~libs ()
+  make_index ~dirs ~rel_dir ~index:(Some index) ~content ~pkgs:[ pkg ] ~libs
+    ~enable_warnings:false
 
 let src ~dirs ~pkg ~index =
   let content ppf =
@@ -95,7 +98,8 @@ let src ~dirs ~pkg ~index =
       pkg.name
   in
   let rel_dir = src_dir pkg in
-  make_index ~dirs ~rel_dir ~index ~content ()
+  make_index ~dirs ~pkgs:[] ~libs:[] ~rel_dir ~index:(Some index) ~content
+    ~enable_warnings:true
 
 let package_list ~dirs ~remap all =
   let content all ppf =
@@ -111,7 +115,8 @@ let package_list ~dirs ~remap all =
   in
   let content = content all in
   let rel_dir = Fpath.v "./" in
-  make_index ~dirs ~rel_dir ~pkgs:all ~content ()
+  make_index ~dirs ~rel_dir ~pkgs:all ~libs:[] ~index:None ~content
+    ~enable_warnings:true
 
 let content dir _pkg libs _src subdirs all_libs pfp =
   let is_root = Fpath.to_string dir = "./" in
@@ -152,7 +157,7 @@ let content dir _pkg libs _src subdirs all_libs pfp =
       all_libs)
 
 let make_custom dirs index_of (pkg : Packages.t) :
-    Odoc_unit.mld Odoc_unit.unit list =
+    Odoc_unit.mld Odoc_unit.t list =
   let pkgs = [ pkg ] in
   let pkg_dirs =
     List.fold_right
@@ -278,7 +283,7 @@ let make_custom dirs index_of (pkg : Packages.t) :
         let idx =
           make_index ~dirs ~rel_dir:p ~libs ~pkgs
             ~content:(content p pkg libs src subdirs all_libs)
-            ?index ()
+            ~index ~enable_warnings:false
         in
         idx :: acc)
     all_dirs []

src/driver/landing_pages.mli

@@ -1,13 +1,23 @@
 open Odoc_unit
 
+val make_index :
+  dirs:dirs ->
+  rel_dir:Fpath.t ->
+  libs:(Packages.t * Packages.libty) list ->
+  pkgs:Packages.t list ->
+  index:index option ->
+  enable_warnings:bool ->
+  content:(Format.formatter -> unit) ->
+  mld Odoc_unit.t
+
 val library :
-  dirs:dirs -> pkg:Packages.t -> index:index -> Packages.libty -> mld unit
+  dirs:dirs -> pkg:Packages.t -> index:index -> Packages.libty -> mld t
 
-val package : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit
+val package : dirs:dirs -> pkg:Packages.t -> index:index -> mld t
 
-val src : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit
+val src : dirs:dirs -> pkg:Packages.t -> index:index -> mld t
 
-val package_list : dirs:dirs -> remap:bool -> Packages.t list -> mld unit
+val package_list : dirs:dirs -> remap:bool -> Packages.t list -> mld t
 
 val make_custom :
-  dirs -> (Packages.t -> Odoc_unit.index) -> Packages.t -> mld unit list
+  dirs -> (Packages.t -> Odoc_unit.index) -> Packages.t -> mld t list

src/driver/odoc_unit.ml

@@ -71,7 +71,7 @@ let pp_index fmt x =
     (Fmt.list Fpath.pp) x.roots Fpath.pp x.output_file x.json Fpath.pp
     x.search_dir
 
-type 'a unit = {
+type 'a t = {
   parent_id : Odoc.Id.t;
   input_file : Fpath.t;
   output_dir : Fpath.t;
@@ -101,7 +101,7 @@ type md = [ `Md ]
 type asset = [ `Asset ]
 
 type all_kinds = [ impl | intf | mld | asset | md ]
-type t = all_kinds unit
+type any = all_kinds t
 
 let rec pp_kind : all_kinds Fmt.t =
  fun fmt x ->
@@ -122,7 +122,7 @@ and pp_impl_extra fmt x =
     (Odoc.Id.to_string x.src_id)
     Fpath.pp x.src_path
 
-and pp : all_kinds unit Fmt.t =
+and pp : all_kinds t Fmt.t =
  fun fmt x ->
   Format.fprintf fmt
     "@[<hov>parent_id: %s@;\
@@ -160,8 +160,8 @@ type dirs = {
   mld_dir : Fpath.t;
 }
 
-let fix_virtual ~(precompiled_units : intf unit list Util.StringMap.t)
-    ~(units : intf unit list Util.StringMap.t) =
+let fix_virtual ~(precompiled_units : intf t list Util.StringMap.t)
+    ~(units : intf t list Util.StringMap.t) =
   Logs.debug (fun m ->
       m "Fixing virtual libraries: %d precompiled units, %d other units"
         (Util.StringMap.cardinal precompiled_units)
@@ -189,13 +189,13 @@ let fix_virtual ~(precompiled_units : intf unit list Util.StringMap.t)
                       "Virtual library check: Selecting cmti for hash %s from \
                        %d possibilities: %a"
                       uhash (List.length xs) (Fmt.Dump.list pp)
-                      (xs :> t list));
+                      (xs :> any list));
                 let unit_name =
                   Fpath.rem_ext unit.input_file |> Fpath.basename
                 in
                 match
                   List.filter
-                    (fun (x : intf unit) ->
+                    (fun (x : intf t) ->
                       (match x.kind with `Intf { hash; _ } -> uhash = hash)
                       && Fpath.has_ext "cmti" x.input_file
                       && Fpath.rem_ext x.input_file |> Fpath.basename

src/driver/odoc_unit.mli

@@ -29,7 +29,7 @@ type index = {
   sidebar : sidebar option;
 }
 
-type 'a unit = {
+type 'a t = {
   parent_id : Odoc.Id.t;
   input_file : Fpath.t;
   output_dir : Fpath.t;
@@ -57,9 +57,9 @@ type mld = [ `Mld ]
 type md = [ `Md ]
 type asset = [ `Asset ]
 
-type t = [ impl | intf | mld | asset | md ] unit
+type any = [ impl | intf | mld | asset | md ] t
 
-val pp : t Fmt.t
+val pp : any Fmt.t
 
 val pkg_dir : Packages.t -> Fpath.t
 val lib_dir : Packages.t -> Packages.libty -> Fpath.t
@@ -75,9 +75,9 @@ type dirs = {
 }
 
 val fix_virtual :
-  precompiled_units:intf unit list Util.StringMap.t ->
-  units:intf unit list Util.StringMap.t ->
-  intf unit list Util.StringMap.t
+  precompiled_units:intf t list Util.StringMap.t ->
+  units:intf t list Util.StringMap.t ->
+  intf t list Util.StringMap.t
 (** [fix_virtual ~precompiled_units ~units] replaces the input file
     in units representing implementations of virtual libraries.
     Implementation units have a [cmt] but no [cmti], even though