From 6887d13646d3b8e894d9f262b777f12bda2994a0 Mon Sep 17 00:00:00 2001
From: Jon Ludlam <jon@recoil.org>
Date: Tue, 17 Dec 2024 11:43:55 +0000
Subject: [PATCH] Custom landing pages part 1

---
 src/driver/bin/odoc_driver.ml          |  4 +-
 src/driver/bin/odoc_driver_monorepo.ml |  7 +-
 src/driver/bin/odoc_driver_voodoo.ml   |  8 +--
 src/driver/compile.ml                  |  6 +-
 src/driver/compile.mli                 |  2 +-
 src/driver/landing_pages.ml            | 99 ++++++++++++++++++++++++++
 src/driver/landing_pages.mli           |  2 +
 src/driver/monorepo_style.ml           | 62 ++++++++++------
 src/driver/odoc.ml                     |  7 +-
 src/driver/odoc.mli                    |  1 +
 src/driver/odoc_units_of.ml            | 31 ++++++--
 src/driver/odoc_units_of.mli           |  7 +-
 12 files changed, 190 insertions(+), 46 deletions(-)

diff --git a/src/driver/bin/odoc_driver.ml b/src/driver/bin/odoc_driver.ml
index edd5a8e3c1..d4555f93cd 100644
--- a/src/driver/bin/odoc_driver.ml
+++ b/src/driver/bin/odoc_driver.ml
@@ -45,11 +45,11 @@ 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 ~gen_indices:true ~extra_paths ~remap all
+          Odoc_units_of.packages ~dirs ~indices_style:Odoc_units_of.Normal ~extra_paths ~remap all
         in
         Compile.init_stats units;
         let compiled = Compile.compile ~partial_dir:odoc_dir units in
-        let linked = Compile.link compiled in
+        let linked = Compile.link ~custom_layout:false compiled in
         let occurrence_file =
           let output =
             Fpath.( / ) odoc_dir "occurrences-all.odoc-occurrences"
diff --git a/src/driver/bin/odoc_driver_monorepo.ml b/src/driver/bin/odoc_driver_monorepo.ml
index 88d8e7a770..d853759392 100644
--- a/src/driver/bin/odoc_driver_monorepo.ml
+++ b/src/driver/bin/odoc_driver_monorepo.ml
@@ -34,10 +34,9 @@ let run path
   Stats.init_nprocs nb_workers;
   let () = Worker_pool.start_workers env sw nb_workers in
 
-  let all, extra_paths, gen_indices, generate_json =
+  let all, extra_paths, generate_json =
     ( Monorepo_style.of_dune_build path,
       Voodoo.empty_extra_paths,
-      true,
       generate_json )
   in
 
@@ -49,12 +48,12 @@ let run path
       (fun () ->
         let units =
           let dirs = { Odoc_unit.odoc_dir; odocl_dir; index_dir; mld_dir } in
-          Odoc_units_of.packages ~dirs ~gen_indices ~extra_paths ~remap:false
+          Odoc_units_of.packages ~dirs ~indices_style:Odoc_units_of.Custom ~extra_paths ~remap:false
             all
         in
         Compile.init_stats units;
         let compiled = Compile.compile ~partial_dir:odoc_dir units in
-        let linked = Compile.link compiled in
+        let linked = Compile.link ~custom_layout:true compiled in
         let occurrence_file =
           let output =
             Fpath.( / ) odoc_dir "occurrences-all.odoc-occurrences"
diff --git a/src/driver/bin/odoc_driver_voodoo.ml b/src/driver/bin/odoc_driver_voodoo.ml
index db39d0d651..7ad15b9373 100644
--- a/src/driver/bin/odoc_driver_voodoo.ml
+++ b/src/driver/bin/odoc_driver_voodoo.ml
@@ -22,10 +22,10 @@ let run package_name blessed actions odoc_dir odocl_dir
   Stats.init_nprocs nb_workers;
   let () = Worker_pool.start_workers env sw nb_workers in
 
-  let all, extra_paths, actions, gen_indices, generate_json =
+  let all, extra_paths, actions, generate_json =
     let all = Voodoo.of_voodoo package_name ~blessed in
     let extra_paths = Voodoo.extra_paths odoc_dir in
-    (all, extra_paths, actions, false, true)
+    (all, extra_paths, actions, true)
   in
 
   let all = Packages.remap_virtual all in
@@ -43,7 +43,7 @@ let run package_name blessed actions odoc_dir odocl_dir
       let odocl_dir = Option.value odocl_dir ~default:odoc_dir in
       { Odoc_unit.odoc_dir; odocl_dir; index_dir; mld_dir }
     in
-    Odoc_units_of.packages ~dirs ~gen_indices ~extra_paths ~remap:false all
+    Odoc_units_of.packages ~dirs ~indices_style:Odoc_units_of.Voodoo ~extra_paths ~remap:false all
   in
   Compile.init_stats units;
   let compiled =
@@ -56,7 +56,7 @@ let run package_name blessed actions odoc_dir odocl_dir
     match actions with
     | CompileOnly -> ()
     | LinkAndGen | All ->
-        let linked = Compile.link compiled in
+        let linked = Compile.link ~custom_layout:false compiled in
         let occurrence_file =
           let output =
             Fpath.( / ) odoc_dir "occurrences-all.odoc-occurrences"
diff --git a/src/driver/compile.ml b/src/driver/compile.ml
index 12883a1a30..6188c9278c 100644
--- a/src/driver/compile.ml
+++ b/src/driver/compile.ml
@@ -244,15 +244,15 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) =
 
 type linked = Odoc_unit.t
 
-let link : compiled list -> _ =
- fun compiled ->
+let link : custom_layout:bool -> compiled list -> _ =
+ fun ~custom_layout compiled ->
   let link : compiled -> linked =
    fun c ->
     let link input_file output_file enable_warnings =
       let libs = Odoc_unit.Pkg_args.compiled_libs c.pkg_args in
       let pages = Odoc_unit.Pkg_args.compiled_pages c.pkg_args in
       let includes = Odoc_unit.Pkg_args.includes c.pkg_args in
-      Odoc.link ~input_file ~output_file ~libs ~docs:pages ~includes
+      Odoc.link ~custom_layout ~input_file ~output_file ~libs ~docs:pages ~includes
         ~ignore_output:(not enable_warnings) ?current_package:c.pkgname ()
     in
     match c.kind with
diff --git a/src/driver/compile.mli b/src/driver/compile.mli
index 88cbe0ddb2..5626b202ef 100644
--- a/src/driver/compile.mli
+++ b/src/driver/compile.mli
@@ -12,7 +12,7 @@ val compile :
 
 type linked
 
-val link : compiled list -> linked list
+val link : custom_layout:bool -> compiled list -> linked list
 
 val html_generate :
   occurrence_file:Fpath.t ->
diff --git a/src/driver/landing_pages.ml b/src/driver/landing_pages.ml
index 1974974d92..7902a0f82a 100644
--- a/src/driver/landing_pages.ml
+++ b/src/driver/landing_pages.ml
@@ -112,3 +112,102 @@ let package_list ~dirs ~remap all =
   let content = content all in
   let rel_dir = Fpath.v "./" in
   make_index ~dirs ~rel_dir ~pkgs:all ~content ()
+
+let content dir _pkg libs _src subdirs all_libs =
+  fun pfp ->
+    let is_root = Fpath.to_string dir = "./" in
+    fpf pfp "{0 Directory: %a}\n\n" Fpath.pp dir;
+
+    if is_root then begin
+      fpf pfp "@short_title /\n";
+      fpf pfp "@children_order ";
+      Fpath.Set.iter (fun x -> if Fpath.basename x <> "opam_switch" then fpf pfp "%s/ " (Fpath.basename x)) subdirs;
+      fpf pfp "opam_switch\n%!";
+    end else
+      fpf pfp "@short_title %s\n" (Fpath.basename dir);
+
+    if Fpath.Set.cardinal subdirs > 0 then begin
+      fpf pfp "{1 Subdirectories}\n";
+      Fpath.Set.iter (fun subdir ->
+        fpf pfp "- {{!/pkg/%apage-index}%s}\n%!" Fpath.pp subdir (Fpath.basename subdir)) subdirs
+    end;
+    
+    if List.length libs > 0 then begin
+      List.iter (fun (_, lib) -> 
+      fpf pfp "{1 Library %s}" lib.Packages.lib_name;
+      fpf pfp "%a@\n" module_list lib) libs
+    end;
+
+    if is_root then begin
+      fpf pfp "{1 Libraries index}\n";
+      List.iter (fun lib ->
+        fpf pfp "- Library [%s]\n" lib.Packages.lib_name;
+        fpf pfp "  %a@\n" module_list lib
+      ) all_libs
+    end
+
+
+let make_custom dirs index_of (pkg : Packages.t) : Odoc_unit.mld Odoc_unit.unit list =
+  let pkgs = [pkg] in
+  let pkg_dirs =
+    List.fold_right (fun pkg dirs ->
+      Fpath.Map.add (Fpath.to_dir_path pkg.Packages.pkg_dir) pkg dirs) pkgs Fpath.Map.empty
+  in
+  let lib_dirs =
+    List.fold_right (fun pkg dirs ->
+      let libs = pkg.libraries in
+      List.fold_left (fun dirs lib ->
+        Fpath.Map.add (Fpath.to_dir_path (Odoc_unit.lib_dir pkg lib)) (pkg, lib) dirs) dirs libs) pkgs Fpath.Map.empty
+  in
+  let src_dirs =
+    List.fold_right (fun pkg dirs ->
+      let libs = pkg.libraries in
+      let x = List.fold_right (fun lib dirs ->
+      if List.exists (fun m ->
+          match m.Packages.m_impl with
+          | Some { mip_src_info = Some _; _ } -> true
+          | _ -> false) lib.modules
+        then Fpath.Map.add (Fpath.to_dir_path (Odoc_unit.src_lib_dir pkg lib)) (pkg, lib) dirs
+        else dirs
+      ) libs dirs in x) pkgs Fpath.Map.empty in
+  let pkg_src_dirs =
+    List.fold_left (fun acc pkg -> Fpath.Map.add (Odoc_unit.src_dir pkg |> Fpath.to_dir_path) pkg acc) Fpath.Map.empty pkgs in
+  let all_dirs = Fpath.Set.union (Fpath.Map.dom pkg_dirs) (Fpath.Set.union (Fpath.Map.dom lib_dirs) (Fpath.Map.dom src_dirs)) in
+  let rec all_parents path =
+    let parent, _ = Fpath.split_base path in
+    if Fpath.compare parent (Fpath.v "./") = 0 || Fpath.compare parent (Fpath.v "/") = 0 then [path] else path :: all_parents parent
+  in
+  let all_dirs = Fpath.Set.fold (fun p acc ->
+    let parents = all_parents p in
+    List.fold_right Fpath.Set.add parents acc) all_dirs all_dirs
+  in
+
+  let all_indexes = List.fold_right (fun pkg acc ->
+    let mlds = pkg.Packages.mlds in
+    let indexes = List.filter (fun mld -> Fpath.basename mld.mld_rel_path = "index.mld") mlds in
+    let index_paths = List.map (fun mld -> Fpath.(pkg.pkg_dir // mld.mld_rel_path |> parent)) indexes |> Fpath.Set.of_list in
+    Fpath.Set.union acc index_paths) pkgs Fpath.Set.empty in
+
+  Fpath.Set.fold (fun p acc ->
+    if Fpath.Set.mem p all_indexes
+    then (Logs.debug (fun m -> m "Skipping predefined index.mld: %a" Fpath.pp p); acc)
+    else begin
+      let libs = Fpath.Map.fold (fun p' lib libs -> if p=p' then lib::libs else libs) lib_dirs [] in
+      let src = Fpath.Map.find_opt p src_dirs in
+      let pkg_src = Fpath.Map.find_opt p pkg_src_dirs in
+      let subdirs = Fpath.Set.filter (fun p' -> Fpath.parent p' = p) all_dirs in
+      Logs.debug (fun x -> x "dir: %a pkg: %a lib: %a src: %a pkg_src: %a subdirs: %a" Fpath.pp p
+        (Fmt.string) pkg.Packages.name
+        (Fmt.Dump.list Fmt.string) (List.map (fun (_, p) -> p.Packages.lib_name) libs)
+        (Fmt.Dump.option Fmt.string) (Option.map (fun (_, p) -> p.Packages.lib_name) src)
+        (Fmt.Dump.option Fmt.string) (Option.map (fun p -> p.Packages.name) pkg_src)
+        (Fmt.Dump.list Fpath.pp) (Fpath.Set.elements subdirs)
+        );
+      let index = Some (index_of pkg) in
+      let pkgs = pkgs in
+      let all_libs = pkg.libraries in
+      Logs.debug (fun m -> m "pkgs: %a" Fmt.Dump.(list string) (List.map (fun p -> p.Packages.name) pkgs));
+      let idx = make_index ~dirs ~rel_dir:p ~libs ~pkgs ~content:(content p pkg libs src subdirs all_libs) ?index () in 
+      idx :: acc
+    end
+    ) all_dirs []
diff --git a/src/driver/landing_pages.mli b/src/driver/landing_pages.mli
index cf4ae96a2f..2c1b64ae05 100644
--- a/src/driver/landing_pages.mli
+++ b/src/driver/landing_pages.mli
@@ -8,3 +8,5 @@ val package : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit
 val src : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit
 
 val package_list : dirs:dirs -> remap:bool -> Packages.t list -> mld unit
+
+val make_custom : dirs -> (Packages.t -> Odoc_unit.index) -> Packages.t ->  mld unit list
diff --git a/src/driver/monorepo_style.ml b/src/driver/monorepo_style.ml
index 3dfe138df1..824e9307c6 100644
--- a/src/driver/monorepo_style.ml
+++ b/src/driver/monorepo_style.ml
@@ -64,11 +64,12 @@ let dune_describe dir =
   match out with Error _ -> [] | Ok out -> of_dune_describe out.Run.output
 
 let of_dune_build dir =
+  let root = Fpath.(dir / "_build" / "default") in
   let contents =
     Bos.OS.Dir.fold_contents ~dotfiles:true
       (fun p acc -> p :: acc)
       []
-      Fpath.(dir / "_build" / "default")
+      root
   in
   match contents with
   | Error _ -> []
@@ -79,6 +80,13 @@ let of_dune_build dir =
           (function Library l -> if l.local then Some l else None)
           libs
       in
+
+      let global_libs =
+        List.filter_map
+          (function Library l -> if l.local then None else Some l)
+          libs
+      in
+
       List.iter
         (fun (lib : library) ->
           Logs.debug (fun m ->
@@ -142,10 +150,11 @@ let of_dune_build dir =
                 in
                 let id_override =
                   Fpath.relativize
-                    ~root:Fpath.(v "_build" / "default")
+                    ~root:Fpath.(v "_build/default")
                     Fpath.(v lib.source_dir)
                   |> Option.map Fpath.to_string
                 in
+                Logs.debug (fun m -> m "this should never be 'None': %a" Fmt.Dump.(option string) id_override);
                 if List.mem cmtidir c then
                   Some
                     (Packages.Lib.v ~libname_of_archive ~pkg_name:lib.name
@@ -155,32 +164,39 @@ let of_dune_build dir =
                 else None)
           libs
       in
-      let other_docs =
+      let find_docs ext =
         List.filter_map
           (fun f ->
-            if Fpath.has_ext "md" f then
-              let md_rel_path =
-                Fpath.relativize ~root:Fpath.(v "_build" / "default") f
+            if Fpath.has_ext ext f then
+              let rel_path =
+                Fpath.relativize ~root f
                 |> Option.get
               in
-              Some { Packages.md_path = f; md_rel_path }
+              Some ( f, rel_path )
             else None)
           c
       in
+      let other_docs = find_docs ".md" |> List.map (fun (p,r) -> { Packages.md_path = p; md_rel_path = r}) in
+      let mlds = find_docs ".mld" |> List.map (fun (p,r) -> { Packages.mld_path = p; mld_rel_path = r}) in
+
       let libs = List.flatten libs in
-      [
-          {
-            Packages.name = "root";
-            version = "1.0";
-            libraries = libs;
-            mlds = [];
-            assets = [];
-            selected = true;
-            remaps = [];
-            pkg_dir = Fpath.v ".";
-            doc_dir = Fpath.v ".";
-            other_docs;
-            config = Global_config.empty;
-          };
-      ]
-   
+      let local =
+        [
+            {
+              Packages.name = "pkg";
+              version = "1.0";
+              libraries = libs;
+              mlds;
+              assets = [];
+              selected = true;
+              remaps = [];
+              pkg_dir = Fpath.v ".";
+              doc_dir = Fpath.v ".";
+              other_docs;
+              config = Global_config.empty;
+            };
+        ]
+      in
+      let global = Packages.of_libs ~packages_dir:(Some (Fpath.v "opam_switch")) (List.map (fun (l : library) -> l.name) global_libs |> Util.StringSet.of_list) in
+      local @ global
+
diff --git a/src/driver/odoc.ml b/src/driver/odoc.ml
index 8d7496332e..391fab2be6 100644
--- a/src/driver/odoc.ml
+++ b/src/driver/odoc.ml
@@ -136,7 +136,7 @@ let lib_args libs =
       v "-L" % s %% acc)
     Cmd.empty libs
 
-let link ?(ignore_output = false) ~input_file:file ?output_file ~docs ~libs
+let link ?(ignore_output = false) ~custom_layout ~input_file:file ?output_file ~docs ~libs
     ~includes ?current_package () =
   let open Cmd in
   let output_file =
@@ -160,6 +160,11 @@ let link ?(ignore_output = false) ~input_file:file ?output_file ~docs ~libs
     if Fpath.to_string file = "stdlib.odoc" then cmd % "--open=\"\"" else cmd
   in
   let desc = Printf.sprintf "Linking %s" (Fpath.to_string file) in
+  let cmd =
+    if custom_layout then
+      cmd % "--custom-layout"
+    else cmd
+  in
   let log =
     if ignore_output then None else Some (`Link, Fpath.to_string file)
   in
diff --git a/src/driver/odoc.mli b/src/driver/odoc.mli
index 537fe3f1cd..1f7f6cc1a4 100644
--- a/src/driver/odoc.mli
+++ b/src/driver/odoc.mli
@@ -35,6 +35,7 @@ val compile_asset : output_dir:Fpath.t -> name:string -> parent_id:Id.t -> unit
 
 val link :
   ?ignore_output:bool ->
+  custom_layout:bool ->
   input_file:Fpath.t ->
   ?output_file:Fpath.t ->
   docs:(string * Fpath.t) list ->
diff --git a/src/driver/odoc_units_of.ml b/src/driver/odoc_units_of.ml
index ed57301c91..3b0fa80dd4 100644
--- a/src/driver/odoc_units_of.ml
+++ b/src/driver/odoc_units_of.ml
@@ -1,6 +1,11 @@
 open Odoc_unit
 
-let packages ~dirs ~extra_paths ~remap ~gen_indices (pkgs : Packages.t list) :
+type indices_style =
+  | Voodoo
+  | Normal
+  | Custom
+
+let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
     t list =
   let { odoc_dir; odocl_dir; index_dir; mld_dir = _ } = dirs in
   (* [module_of_hash] Maps a hash to the corresponding [Package.t], library name and
@@ -239,7 +244,7 @@ let packages ~dirs ~extra_paths ~remap ~gen_indices (pkgs : Packages.t list) :
     let mld_units :> t list list = List.map (of_mld pkg) pkg.mlds in
     let asset_units :> t list list = List.map (of_asset pkg) pkg.assets in
     let md_units :> t list list = List.map (of_md pkg) pkg.other_docs in
-    let pkg_index :> t list =
+    let pkg_index () :> t list =
       let has_index_page =
         List.exists
           (fun mld ->
@@ -253,7 +258,7 @@ let packages ~dirs ~extra_paths ~remap ~gen_indices (pkgs : Packages.t list) :
         let index = index_of pkg in
         [ Landing_pages.package ~dirs ~pkg ~index ]
     in
-    let src_index :> t list =
+    let src_index () :> t list =
       if remap && not pkg.selected then []
       else if
         (* Some library has a module which has an implementation which has a source *)
@@ -271,11 +276,23 @@ let packages ~dirs ~extra_paths ~remap ~gen_indices (pkgs : Packages.t list) :
         [ Landing_pages.src ~dirs ~pkg ~index ]
       else []
     in
-    List.concat
-      ((pkg_index :: src_index :: lib_units)
-      @ mld_units @ asset_units @ md_units)
+    match indices_style with
+    | Normal | Voodoo ->
+      List.concat
+        ((pkg_index () :: src_index () :: lib_units)
+        @ mld_units @ asset_units @ md_units)
+    | Custom ->
+      if pkg.name = "pkg" then
+        let others :> t list = Landing_pages.make_custom dirs index_of (List.find (fun p -> p.Packages.name = "pkg") pkgs) in
+        others @ List.concat
+          (mld_units @ asset_units @ md_units @ lib_units)
+      else
+        List.concat
+          ((pkg_index () :: src_index () :: lib_units)
+          @ mld_units @ asset_units @ md_units)
   in
-  if gen_indices then
+  if indices_style = Normal then
     let gen_indices :> t = Landing_pages.package_list ~dirs ~remap pkgs in
     gen_indices :: List.concat_map of_package pkgs
   else List.concat_map of_package pkgs
+  
\ No newline at end of file
diff --git a/src/driver/odoc_units_of.mli b/src/driver/odoc_units_of.mli
index cc862c3ac8..1fd9c70549 100644
--- a/src/driver/odoc_units_of.mli
+++ b/src/driver/odoc_units_of.mli
@@ -1,9 +1,14 @@
 open Odoc_unit
 
+type indices_style =
+| Voodoo
+| Normal
+| Custom
+
 val packages :
   dirs:dirs ->
   extra_paths:Voodoo.extra_paths ->
   remap:bool ->
-  gen_indices:bool ->
+  indices_style:indices_style ->
   Packages.t list ->
   t list