Driver: Compile assets, following convention

Author: panglesd

src/driver/compile.ml

@@ -2,11 +2,12 @@
 
 type compiled = Odoc_unit.t
 
-let mk_byhash (pkgs : Odoc_unit.intf Odoc_unit.unit list) =
+let mk_byhash (pkgs : Odoc_unit.t list) =
   List.fold_left
-    (fun acc (u : Odoc_unit.intf Odoc_unit.unit) ->
+    (fun acc (u : Odoc_unit.t) ->
       match u.Odoc_unit.kind with
-      | `Intf { hash; _ } -> Util.StringMap.add hash u acc)
+      | `Intf { hash; _ } as kind -> Util.StringMap.add hash { u with kind } acc
+      | _ -> acc)
     Util.StringMap.empty pkgs
 
 let init_stats (units : Odoc_unit.t list) =
@@ -78,93 +79,98 @@ let find_partials odoc_dir : Odoc_unit.intf Odoc_unit.unit Util.StringMap.t * _
   | Error _ -> (* odoc_dir doesn't exist...? *) (Util.StringMap.empty, tbl)
 
 let compile ?partial ~partial_dir ?linked_dir:_ (all : Odoc_unit.t list) =
-  (* let linked_dir = Option.value linked_dir ~default:output_dir in *)
-  let intf_units, impl_units, mld_units =
-    List.fold_left
-      (fun (intf_units, impl_units, page_units) (unit : Odoc_unit.t) ->
-        match unit with
-        | { kind = `Intf _; _ } as intf ->
-            (intf :: intf_units, impl_units, page_units)
-        | { kind = `Impl _; _ } as impl ->
-            (intf_units, impl :: impl_units, page_units)
-        | { kind = `Mld; _ } as mld ->
-            (intf_units, impl_units, mld :: page_units))
-      ([], [], []) all
-  in
-  let hashes = mk_byhash intf_units in
-  let other_hashes, tbl =
-    match partial with
-    | Some _ -> find_partials partial_dir
-    | None -> (Util.StringMap.empty, Hashtbl.create 10)
-  in
-  let all_hashes =
-    Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes other_hashes
+  let hashes = mk_byhash all in
+  let compile_mod =
+    (* Modules have a more complicated compilation because:
+       - They have dependencies and must be compiled in the right order
+       - In Voodoo mode, there might exists already compiled parts *)
+    let other_hashes, tbl =
+      match partial with
+      | Some _ -> find_partials partial_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 compile_one compile_other hash =
+      match Util.StringMap.find_opt hash all_hashes with
+      | None ->
+          Logs.debug (fun m -> m "Error locating hash: %s" hash);
+          Error Not_found
+      | Some unit ->
+          let deps = match unit.kind with `Intf { deps; _ } -> deps in
+          let _fibers =
+            Fiber.List.map
+              (fun (other_unit : Odoc_unit.intf Odoc_unit.unit) ->
+                match compile_other other_unit with
+                | Ok r -> Some r
+                | Error _exn ->
+                    Logs.debug (fun m ->
+                        m
+                          "Error during compilation of module %s (hash %s, \
+                           required by %s)"
+                          (Fpath.filename other_unit.input_file)
+                          (match other_unit.kind with
+                          | `Intf { hash; _ } -> hash)
+                          (Fpath.filename unit.input_file));
+                    None)
+              deps
+          in
+          let includes = Fpath.Set.of_list unit.include_dirs in
+          Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
+            ~includes ~parent_id:unit.parent_id;
+          Atomic.incr Stats.stats.compiled_units;
+
+          Ok unit
+    in
+    let rec compile_mod :
+        Odoc_unit.intf Odoc_unit.unit ->
+        (Odoc_unit.intf Odoc_unit.unit, exn) Result.t =
+     fun unit ->
+      let hash = match unit.kind with `Intf { hash; _ } -> hash in
+      match Hashtbl.find_opt tbl hash with
+      | Some p -> Promise.await p
+      | None ->
+          let p, r = Promise.create () in
+          Hashtbl.add tbl hash p;
+          let result = compile_one compile_mod hash in
+          Promise.resolve r result;
+          result
+    in
+    compile_mod
   in
-  let compile_one compile_other hash =
-    match Util.StringMap.find_opt hash all_hashes with
-    | None ->
-        Logs.debug (fun m -> m "Error locating hash: %s" hash);
-        Error Not_found
-    | Some unit ->
-        let deps = match unit.kind with `Intf { deps; _ } -> deps in
-        let _fibers =
-          Fiber.List.map
-            (fun other_unit ->
-              match compile_other other_unit with
-              | Ok r -> Some r
-              | Error _exn ->
-                  Logs.debug (fun m ->
-                      m "Missing module %s (hash %s, required by %s)" "TODO"
-                        (* n h *) "TODO" "TODO" (* unit.m_name *));
-                  None)
-            deps
-        in
+
+  let compile (unit : Odoc_unit.t) =
+    match unit.kind with
+    | `Intf _ as kind ->
+        (compile_mod { unit with kind } :> (Odoc_unit.t, _) Result.t)
+    | `Impl src ->
+        let includes = Fpath.Set.of_list unit.include_dirs in
+        let source_id = src.src_id in
+        Odoc.compile_impl ~output_dir:unit.output_dir
+          ~input_file:unit.input_file ~includes ~parent_id:unit.parent_id
+          ~source_id;
+        Atomic.incr Stats.stats.compiled_impls;
+        Ok unit
+    | `Asset ->
+        Odoc.compile_asset ~output_dir:unit.output_dir ~parent_id:unit.parent_id
+          ~name:(Fpath.filename unit.input_file);
+        Ok unit
+    | `Mld ->
         let includes = Fpath.Set.of_list unit.include_dirs in
         Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
           ~includes ~parent_id:unit.parent_id;
-        Atomic.incr Stats.stats.compiled_units;
-
+        Atomic.incr Stats.stats.compiled_mlds;
         Ok unit
   in
-
-  let rec compile_mod :
-      Odoc_unit.intf Odoc_unit.unit ->
-      (Odoc_unit.intf Odoc_unit.unit, exn) Result.t =
-   fun unit ->
-    let hash = match unit.kind with `Intf { hash; _ } -> hash in
-    match Hashtbl.find_opt tbl hash with
-    | Some p -> Promise.await p
-    | None ->
-        let p, r = Promise.create () in
-        Hashtbl.add tbl hash p;
-        let result = compile_one compile_mod hash in
-        Promise.resolve r result;
-        result
-  in
-  let to_build = Util.StringMap.bindings hashes |> List.map snd in
-  let mod_results = Fiber.List.map compile_mod to_build in
-  let compile_mld (unit : Odoc_unit.mld Odoc_unit.unit) =
-    let includes = Fpath.Set.of_list unit.include_dirs in
-    Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
-      ~includes ~parent_id:unit.parent_id;
-    Atomic.incr Stats.stats.compiled_mlds
-  in
-  let () = Fiber.List.iter compile_mld mld_units in
-  let compile_impl (unit : Odoc_unit.impl Odoc_unit.unit) =
-    let includes = Fpath.Set.of_list unit.include_dirs in
-    let source_id = match unit.kind with `Impl src -> src.src_id in
-    Odoc.compile_impl ~output_dir:unit.output_dir ~input_file:unit.input_file
-      ~includes ~parent_id:unit.parent_id ~source_id;
-    Atomic.incr Stats.stats.compiled_impls
-  in
-  let () = Fiber.List.iter compile_impl impl_units in
-  let zipped_res =
-    List.map2
-      (fun Odoc_unit.{ kind = `Intf { hash; _ }; _ } b -> (hash, b))
-      to_build mod_results
-  in
+  let res = Fiber.List.map compile all in
+  (* For voodoo mode, we need to keep which modules successfully compiled *)
   let zipped =
-    List.filter_map (function a, Ok b -> Some (a, b) | _ -> None) zipped_res
+    List.filter_map
+      (function
+        | Ok (Odoc_unit.{ kind = `Intf { hash; _ }; _ } as b) -> Some (hash, b)
+        | _ -> None)
+      res
   in
   (match partial with
   | Some l -> marshal (zipped, hashes) Fpath.(l / "index.m")
@@ -193,6 +199,7 @@ let link : compiled list -> _ =
         (match c.kind with
         | `Intf _ -> Atomic.incr Stats.stats.linked_units
         | `Mld -> Atomic.incr Stats.stats.linked_mlds
+        | `Asset -> () (* TODO *)
         | `Impl _ -> Atomic.incr Stats.stats.linked_impls);
         c
   in
@@ -239,6 +246,9 @@ let html_generate output_dir linked =
         Odoc.html_generate ~search_uris:[] ~output_dir ~input_file
           ~source:src_path ();
         Atomic.incr Stats.stats.generated_units
+    | `Asset ->
+        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

src/driver/dune_style.ml

@@ -53,6 +53,7 @@ let of_dune_build dir =
                       version = "1.0";
                       libraries = [ lib ];
                       mlds = [];
+                      assets = [] (* TODO *);
                       pkg_dir;
                       other_docs = Fpath.Set.empty;
                     } )

src/driver/odoc.ml

@@ -45,6 +45,20 @@ let compile ~output_dir ~input_file:file ~includes ~parent_id =
   Cmd_outputs.(
     add_prefixed_output cmd compile_output (Fpath.to_string file) lines)
 
+let compile_asset ~output_dir ~name ~parent_id =
+  let open Cmd in
+  let output_file =
+    Some Fpath.(output_dir // 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 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)
+
 let compile_impl ~output_dir ~input_file:file ~includes ~parent_id ~source_id =
   let open Cmd in
   let includes =
@@ -156,6 +170,19 @@ let html_generate ~output_dir ?index ?(ignore_output = false) ?(assets = [])
     Cmd_outputs.(
       add_prefixed_output cmd generate_output (Fpath.to_string file) lines)
 
+let html_generate_asset ~output_dir ?(ignore_output = false) ~input_file:file
+    ~asset_path () =
+  let open Cmd in
+  let cmd =
+    !odoc % "html-generate" % p file % "-o" % output_dir % "--asset-path"
+    % p asset_path
+  in
+  let desc = Printf.sprintf "Copying asset %s" (Fpath.to_string file) in
+  let lines = Cmd_outputs.submit desc cmd None in
+  if not ignore_output then
+    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

src/driver/odoc.mli

@@ -24,6 +24,8 @@ val compile :
   parent_id:id ->
   unit
 
+val compile_asset : output_dir:Fpath.t -> name:string -> parent_id:id -> unit
+
 val link :
   ?ignore_output:bool ->
   input_file:Fpath.t ->
@@ -54,6 +56,15 @@ val html_generate :
   input_file:Fpath.t ->
   unit ->
   unit
+
+val html_generate_asset :
+  output_dir:string ->
+  ?ignore_output:bool ->
+  input_file:Fpath.t ->
+  asset_path:Fpath.t ->
+  unit ->
+  unit
+
 val support_files : Fpath.t -> string list
 
 val count_occurrences : Fpath.t -> string list

src/driver/odoc_unit.ml

@@ -32,7 +32,9 @@ type impl = [ `Impl of impl_extra ]
 
 type mld = [ `Mld ]
 
-type t = [ impl | intf | mld ] unit
+type asset = [ `Asset ]
+
+type t = [ impl | intf | mld | asset ] unit
 
 let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
     t list =
@@ -90,14 +92,13 @@ let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
     let output_file = Fpath.(index_dir / pkg.name / Odoc.index_filename) in
     { pkg_args; output_file; json = false; search_dir = pkg.pkg_dir }
   in
-  let make_unit ~kind ~rel_dir ~input_file ~prefix ~pkg ~include_dirs : _ unit =
+  let make_unit ~name ~kind ~rel_dir ~input_file ~pkg ~include_dirs : _ unit =
     let ( // ) = Fpath.( // ) in
     let ( / ) = Fpath.( / ) in
-    let filename = input_file |> Fpath.rem_ext |> Fpath.basename in
     let odoc_dir = output_dir // rel_dir in
     let parent_id = rel_dir |> Odoc.id_of_fpath in
-    let odoc_file = odoc_dir / (prefix ^ filename ^ ".odoc") in
-    let odocl_file = linked_dir // rel_dir / (prefix ^ filename ^ ".odocl") in
+    let odoc_file = odoc_dir / (name ^ ".odoc") in
+    let odocl_file = linked_dir // rel_dir / (name ^ ".odocl") in
     {
       output_dir;
       pkgname = pkg.Packages.name;
@@ -134,7 +135,8 @@ let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
           let kind = `Intf { hidden; hash = intf.mif_hash; deps } in
           (include_dirs, kind)
         in
-        make_unit ~kind ~rel_dir ~prefix:"" ~input_file:intf.mif_path ~pkg
+        let name = intf.mif_path |> Fpath.rem_ext |> Fpath.basename in
+        make_unit ~name ~kind ~rel_dir ~input_file:intf.mif_path ~pkg
           ~include_dirs
   in
   let of_impl pkg libname (impl : Packages.impl) : impl unit option =
@@ -154,9 +156,12 @@ let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
           in
           `Impl { src_id; src_path }
         in
+        let name =
+          impl.mip_path |> Fpath.rem_ext |> Fpath.basename |> ( ^ ) "impl-"
+        in
         let unit =
-          make_unit ~kind ~rel_dir ~input_file:impl.mip_path ~pkg ~include_dirs
-            ~prefix:"impl-"
+          make_unit ~name ~kind ~rel_dir ~input_file:impl.mip_path ~pkg
+            ~include_dirs
         in
         Some unit
   in
@@ -187,15 +192,31 @@ let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
     in
     let include_dirs = (output_dir // rel_dir) :: include_dirs in
     let kind = `Mld in
+    let name = mld_path |> Fpath.rem_ext |> Fpath.basename |> ( ^ ) "page-" in
+    let unit =
+      make_unit ~name ~kind ~rel_dir ~input_file:mld_path ~pkg ~include_dirs
+    in
+    [ unit ]
+  in
+  let of_asset pkg (asset : Packages.asset) : asset unit list =
+    let open Fpath in
+    let { Packages.asset_path; asset_rel_path } = asset in
+    let rel_dir =
+      pkg.Packages.pkg_dir / "doc" // Fpath.parent asset_rel_path
+      |> Fpath.normalize
+    in
+    let include_dirs = [] in
+    let kind = `Asset in
     let unit =
-      make_unit ~kind ~rel_dir ~input_file:mld_path ~pkg ~include_dirs
-        ~prefix:"page-"
+      let name = asset_path |> Fpath.basename |> ( ^ ) "asset-" in
+      make_unit ~name ~kind ~rel_dir ~input_file:asset_path ~pkg ~include_dirs
     in
     [ unit ]
   in
   let of_package (pkg : Packages.t) : t list =
     let lib_units :> t list list = List.map (of_lib pkg) pkg.libraries in
     let mld_units :> t list list = List.map (of_mld pkg) pkg.mlds in
-    List.concat (List.rev_append lib_units mld_units)
+    let asset_units :> t list list = List.map (of_asset pkg) pkg.assets in
+    List.concat (lib_units @ mld_units @ asset_units)
   in
   List.concat_map of_package pkgs

src/driver/odoc_unit.mli

@@ -32,7 +32,9 @@ type impl = [ `Impl of impl_extra ]
 
 type mld = [ `Mld ]
 
-type t = [ impl | intf | mld ] unit
+type asset = [ `Asset ]
+
+type t = [ impl | intf | mld | asset ] unit
 
 val of_packages :
   output_dir:Fpath.t ->

src/driver/opam.ml

@@ -135,6 +135,10 @@ let pkg_to_dir_map () =
               | "doc" :: _pkg :: "odoc-pages" :: _ ->
                   Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
 
+                  (Fpath.Set.add Fpath.(v prefix // fpath) odoc_pages, others)
+              | "doc" :: _pkg :: "odoc-assets" :: _ ->
+                  Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
+
                   (Fpath.Set.add Fpath.(v prefix // fpath) odoc_pages, others)
               | "doc" :: _ ->
                   Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);