Driver: generate "external" pages

src/driver/compile.ml

@@ -1,5 +1,7 @@
 (* compile *)
 
+open Bos
+
 type compiled = Odoc_unit.t
 
 let mk_byhash (pkgs : Odoc_unit.t list) =
@@ -22,7 +24,11 @@ let init_stats (units : Odoc_unit.t list) =
         let assets =
           match unit.kind with `Asset -> assets + 1 | _ -> assets
         in
-        let indexes = Fpath.Set.add unit.index.output_file indexes in
+        let indexes =
+          match unit.index with
+          | None -> indexes
+          | Some index -> Fpath.Set.add index.output_file indexes
+        in
         let non_hidden =
           match unit.kind with
           | `Intf { hidden = false; _ } -> non_hidden + 1
@@ -54,8 +60,7 @@ let unmarshal filename : partial =
     (fun () -> Marshal.from_channel ic)
 
 let marshal (v : partial) filename =
-  let p = Fpath.parent filename in
-  Util.mkdir_p p;
+  let _ = OS.Dir.create (Fpath.parent filename) |> Result.get_ok in
   let oc = open_out_bin (Fpath.to_string filename) in
   Fun.protect
     ~finally:(fun () -> close_out oc)
@@ -65,10 +70,10 @@ let find_partials odoc_dir : Odoc_unit.intf Odoc_unit.unit Util.StringMap.t * _
     =
   let tbl = Hashtbl.create 1000 in
   let hashes_result =
-    Bos.OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
+    OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
       (fun p hashes ->
         let index_m = Fpath.( / ) p "index.m" in
-        match Bos.OS.File.exists index_m with
+        match OS.File.exists index_m with
         | Ok true ->
             let tbl', hashes' = unmarshal index_m in
             List.iter
@@ -216,12 +221,13 @@ let sherlodoc_index_one ~output_dir (index : Odoc_unit.index) =
   let rel_path = Fpath.(index.search_dir / "sherlodoc_db.js") in
   let dst = Fpath.(output_dir // rel_path) in
   let dst_dir, _ = Fpath.split_base dst in
-  Util.mkdir_p dst_dir;
+  let _ = OS.Dir.create dst_dir |> Result.get_ok in
   Sherlodoc.index ~format:`js ~inputs ~dst ();
   rel_path
 
 let html_generate output_dir linked =
   let tbl = Hashtbl.create 10 in
+  let _ = OS.Dir.create output_dir |> Result.get_ok in
   Sherlodoc.js Fpath.(output_dir // Sherlodoc.js_file);
   let compile_index : Odoc_unit.index -> _ =
    fun index ->
@@ -256,10 +262,16 @@ let html_generate output_dir linked =
         Odoc.html_generate_asset ~output_dir ~input_file:l.odoc_file
           ~asset_path:l.input_file ()
     | _ ->
-        let db_path = compile_index l.index in
-        let search_uris = [ db_path; Sherlodoc.js_file ] in
-        let index = l.index.output_file in
-        Odoc.html_generate ~search_uris ~index ~output_dir ~input_file ();
+        let search_uris, index =
+          match l.index with
+          | None -> (None, None)
+          | Some index ->
+              let db_path = compile_index index in
+              let search_uris = [ db_path; Sherlodoc.js_file ] in
+              let index = index.output_file in
+              (Some search_uris, Some index)
+        in
+        Odoc.html_generate ?search_uris ?index ~output_dir ~input_file ();
         Atomic.incr Stats.stats.generated_units
   in
   Fiber.List.iter html_generate linked

src/driver/dune

@@ -13,4 +13,5 @@
   opam-format
   logs
   logs.fmt
-  eio_main))
+  eio_main
+  odoc_utils))

src/driver/landing_pages.ml

@@ -0,0 +1,125 @@
+open Packages
+open Odoc_unit
+
+let fpf = Format.fprintf
+
+let make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
+    ?(include_dirs = []) ~pkgname ~pkg_args () =
+  let input_file = Fpath.(mld_dir // rel_path / "index.mld") in
+  let odoc_file = Fpath.(odoc_dir // rel_path / "page-index.odoc") in
+  let odocl_file = Fpath.(odocl_dir // rel_path / "page-index.odocl") in
+  Util.with_out_to input_file (fun oc ->
+      fpf (Format.formatter_of_out_channel oc) "%t@?" content)
+  |> Result.get_ok;
+  let parent_id = rel_path |> Odoc.Id.of_fpath in
+  {
+    parent_id;
+    odoc_dir;
+    input_file;
+    output_dir;
+    odoc_file;
+    odocl_file;
+    pkg_args;
+    pkgname;
+    include_dirs;
+    index = None;
+    kind = `Mld;
+  }
+
+module PackageLanding = struct
+  let content pkg ppf =
+    fpf ppf "{0 %s}\n" pkg.name;
+    if not (List.is_empty pkg.mlds) then
+      fpf ppf
+        "{1 Documentation pages}@\n@\n{{!/%s/doc/index}Documentation for %s}@\n"
+        pkg.name pkg.name;
+    if not (List.is_empty pkg.libraries) then
+      fpf ppf "{1 Libraries}@\n@\n{{!/%s/lib/index}Libraries for %s}@\n"
+        pkg.name pkg.name
+
+  let page ~odoc_dir ~odocl_dir ~mld_dir ~output_dir ~pkg =
+    let content = content pkg in
+    let rel_path = Fpath.v pkg.name in
+    let pkg_args =
+      { pages = [ (pkg.name, Fpath.( // ) odoc_dir rel_path) ]; libs = [] }
+    in
+    make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
+      ~pkgname:pkg.name ~pkg_args ()
+end
+
+module PackageList = struct
+  let content all ppf =
+    let sorted_packages =
+      all |> List.sort (fun n1 n2 -> String.compare n1.name n2.name)
+    in
+    fpf ppf "{0 List of all packages}@\n";
+    let print_pkg pkg =
+      fpf ppf "- {{!/__driver/%s/index}%s}@\n" pkg.name pkg.name
+    in
+    List.iter print_pkg sorted_packages
+
+  let page ~mld_dir ~odoc_dir ~odocl_dir ~output_dir all =
+    let content = content all in
+    let rel_path = Fpath.v "./" in
+    let pkgname = "__driver" in
+    let pkg_args =
+      { pages = [ (pkgname, Fpath.(odoc_dir // rel_path)) ]; libs = [] }
+    in
+    make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir ~content ~pkgname
+      ~pkg_args rel_path ()
+end
+
+module LibraryLanding = struct
+  let content lib ppf =
+    fpf ppf "{0 %s}@\n" lib.lib_name;
+    let print_module m =
+      if not m.m_hidden then fpf ppf "- {!%s}@\n" m.Packages.m_name
+    in
+    List.iter print_module lib.modules
+
+  let page ~pkg ~odoc_dir ~odocl_dir ~mld_dir ~output_dir lib =
+    let content = content lib in
+    let rel_path = Fpath.(v pkg.name / "lib" / lib.lib_name) in
+    let pkg_args =
+      { pages = [ (pkg.name, Fpath.( // ) odoc_dir rel_path) ]; libs = [] }
+    in
+    let include_dirs = [ Fpath.(odoc_dir // rel_path) ] in
+    make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
+      ~pkgname:pkg.name ~include_dirs ~pkg_args ()
+end
+
+module PackageLibLanding = struct
+  let content pkg ppf =
+    fpf ppf "{0 %s}@\n" pkg.name;
+    let print_lib (lib : Packages.libty) =
+      fpf ppf "- {{!/%s/%s/index}%s}@\n" pkg.name lib.lib_name lib.lib_name
+    in
+    List.iter print_lib pkg.libraries
+
+  let page ~pkg ~odoc_dir ~odocl_dir ~mld_dir ~output_dir =
+    let content = content pkg in
+    let rel_path = Fpath.(v pkg.name / "lib") in
+    let pkg_args =
+      { pages = [ (pkg.name, Fpath.( // ) odoc_dir rel_path) ]; libs = [] }
+    in
+    make_unit ~odoc_dir ~odocl_dir ~mld_dir ~output_dir rel_path ~content
+      ~pkgname:pkg.name ~pkg_args ()
+end
+
+let of_package ~mld_dir ~odoc_dir ~odocl_dir ~output_dir pkg =
+  let library_pages =
+    List.map
+      (LibraryLanding.page ~pkg ~odoc_dir ~odocl_dir ~mld_dir ~output_dir)
+      pkg.libraries
+  in
+  let package_landing_page =
+    PackageLanding.page ~odoc_dir ~odocl_dir ~mld_dir ~output_dir ~pkg
+  in
+  let library_list_page =
+    PackageLibLanding.page ~odoc_dir ~odocl_dir ~mld_dir ~output_dir ~pkg
+  in
+  package_landing_page :: library_list_page :: library_pages
+
+let of_packages ~mld_dir ~odoc_dir ~odocl_dir ~output_dir all =
+  PackageList.page ~mld_dir ~odoc_dir ~odocl_dir ~output_dir all
+  :: List.concat_map (of_package ~mld_dir ~odoc_dir ~odocl_dir ~output_dir) all

src/driver/landing_pages.mli

@@ -0,0 +1,7 @@
+val of_packages :
+  mld_dir:Fpath.t ->
+  odoc_dir:Fpath.t ->
+  odocl_dir:Fpath.t ->
+  output_dir:Fpath.t ->
+  Packages.t list ->
+  [> `Mld ] Odoc_unit.unit list

src/driver/odoc.ml

@@ -1,12 +1,20 @@
 open Bos
 
-type id = Fpath.t
+module Id : sig
+  type t
+  val to_fpath : t -> Fpath.t
+  val of_fpath : Fpath.t -> t
+  val to_string : t -> string
+end = struct
+  type t = Fpath.t
 
-let fpath_of_id id = id
+  let to_fpath id = id
 
-let id_of_fpath id =
-  id |> Fpath.normalize
-  |> Fpath.rem_empty_seg (* If an odoc path ends with a [/] everything breaks *)
+  let of_fpath id = id |> Fpath.normalize |> Fpath.rem_empty_seg
+  (* If an odoc path ends with a [/] everything breaks *)
+
+  let to_string id = match Fpath.to_string id with "." -> "" | v -> v
+end
 
 let index_filename = "index.odoc-index"
 
@@ -33,13 +41,13 @@ let compile ~output_dir ~input_file:file ~includes ~parent_id =
   in
   let output_file =
     let _, f = Fpath.split_base file in
-    Some Fpath.(output_dir // parent_id // set_ext "odoc" f)
+    Some Fpath.(output_dir // Id.to_fpath parent_id // set_ext "odoc" f)
   in
   let cmd =
     !odoc % "compile" % Fpath.to_string file % "--output-dir" % p output_dir
     %% includes % "--enable-missing-root-warning"
   in
-  let cmd = cmd % "--parent-id" % Fpath.to_string parent_id in
+  let cmd = cmd % "--parent-id" % Id.to_string parent_id in
   let desc = Printf.sprintf "Compiling %s" (Fpath.to_string file) in
   let lines = Cmd_outputs.submit desc cmd output_file in
   Cmd_outputs.(
@@ -48,13 +56,14 @@ let compile ~output_dir ~input_file:file ~includes ~parent_id =
 let compile_asset ~output_dir ~name ~parent_id =
   let open Cmd in
   let output_file =
-    Some Fpath.(output_dir // parent_id / ("asset-" ^ name ^ ".odoc"))
+    Some
+      Fpath.(output_dir // Id.to_fpath parent_id / ("asset-" ^ name ^ ".odoc"))
   in
   let cmd =
     !odoc % "compile-asset" % "--name" % name % "--output-dir" % p output_dir
   in
 
-  let cmd = cmd % "--parent-id" % Fpath.to_string parent_id in
+  let cmd = cmd % "--parent-id" % Id.to_string parent_id in
   let desc = Printf.sprintf "Compiling %s" name in
   let lines = Cmd_outputs.submit desc cmd output_file in
   Cmd_outputs.(add_prefixed_output cmd compile_output name lines)
@@ -73,10 +82,12 @@ let compile_impl ~output_dir ~input_file:file ~includes ~parent_id ~source_id =
   let output_file =
     let _, f = Fpath.split_base file in
     Some
-      Fpath.(output_dir // parent_id / ("impl-" ^ to_string (set_ext "odoc" f)))
+      Fpath.(
+        output_dir // Id.to_fpath parent_id
+        / ("impl-" ^ to_string (set_ext "odoc" f)))
   in
-  let cmd = cmd % "--parent-id" % Fpath.to_string parent_id in
-  let cmd = cmd % "--source-id" % Fpath.to_string source_id in
+  let cmd = cmd % "--parent-id" % Id.to_string parent_id in
+  let cmd = cmd % "--source-id" % Id.to_string source_id in
   let desc =
     Printf.sprintf "Compiling implementation %s" (Fpath.to_string file)
   in

src/driver/odoc.mli

@@ -1,7 +1,9 @@
-type id
-
-val fpath_of_id : id -> Fpath.t
-val id_of_fpath : Fpath.t -> id
+module Id : sig
+  type t
+  val to_fpath : t -> Fpath.t
+  val of_fpath : Fpath.t -> t
+  val to_string : t -> string
+end
 
 val index_filename : string
 
@@ -14,17 +16,17 @@ val compile_impl :
   output_dir:Fpath.t ->
   input_file:Fpath.t ->
   includes:Fpath.set ->
-  parent_id:id ->
-  source_id:id ->
+  parent_id:Id.t ->
+  source_id:Id.t ->
   unit
 val compile :
   output_dir:Fpath.t ->
   input_file:Fpath.t ->
   includes:Fpath.set ->
-  parent_id:id ->
+  parent_id:Id.t ->
   unit
 
-val compile_asset : output_dir:Fpath.t -> name:string -> parent_id:id -> unit
+val compile_asset : output_dir:Fpath.t -> name:string -> parent_id:Id.t -> unit
 
 val link :
   ?ignore_output:bool ->

src/driver/odoc_driver.ml

@@ -558,8 +558,17 @@ let run libs verbose packages_dir odoc_dir odocl_dir html_dir stats nb_workers
       (fun () ->
         let all =
           let all = Util.StringMap.bindings all |> List.map snd in
-          Odoc_unit.of_packages ~output_dir:odoc_dir ~linked_dir:odocl_dir
-            ~index_dir:None all
+          let internal =
+            Odoc_unit.of_packages ~output_dir:odoc_dir ~linked_dir:odocl_dir
+              ~index_dir:None all
+          in
+          let external_ =
+            let mld_dir = odoc_dir in
+            let odocl_dir = Option.value odocl_dir ~default:odoc_dir in
+            Landing_pages.of_packages ~mld_dir ~odoc_dir ~odocl_dir
+              ~output_dir:odoc_dir all
+          in
+          internal @ external_
         in
         Compile.init_stats all;
         let compiled =