Add ability to call generate commands on asset units

CHANGES.md

@@ -26,6 +26,7 @@
   (@panglesd, #1076).
 - Added a `compile-asset` command (@EmileTrotignon, @panglesd, #1170)
 - Allow referencing assets (@panglesd, #1171)
+- Added a `--asset-path` arg to `html-generate` (@panglesd, #1185)
 
 ### Changed
 

src/document/renderer.ml

@@ -42,3 +42,7 @@ let document_of_compilation_unit ~syntax v =
   match syntax with
   | Reason -> Reason.compilation_unit v
   | OCaml -> ML.compilation_unit v
+
+let document_of_asset path (v : Odoc_model.Lang.Asset.t) =
+  let url = Url.Path.from_identifier v.name in
+  Types.Document.Asset { url; src = path }

src/driver/compile.ml

@@ -2,37 +2,43 @@
 
 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) =
-  let total, total_impl, non_hidden, mlds, indexes =
+  let total, total_impl, non_hidden, mlds, assets, indexes =
     List.fold_left
-      (fun (total, total_impl, non_hidden, mlds, indexes) (unit : Odoc_unit.t) ->
+      (fun (total, total_impl, non_hidden, mlds, assets, indexes)
+           (unit : Odoc_unit.t) ->
         let total = match unit.kind with `Intf _ -> total + 1 | _ -> total in
         let total_impl =
           match unit.kind with `Impl _ -> total_impl + 1 | _ -> total_impl
         in
+        let assets =
+          match unit.kind with `Asset -> assets + 1 | _ -> assets
+        in
         let indexes = Fpath.Set.add unit.index.output_file indexes in
         let non_hidden =
           match unit.kind with
           | `Intf { hidden = false; _ } -> non_hidden + 1
           | _ -> non_hidden
         in
         let mlds = match unit.kind with `Mld -> mlds + 1 | _ -> mlds in
-        (total, total_impl, non_hidden, mlds, indexes))
-      (0, 0, 0, 0, Fpath.Set.empty)
+        (total, total_impl, non_hidden, mlds, assets, indexes))
+      (0, 0, 0, 0, 0, Fpath.Set.empty)
       units
   in
 
   Atomic.set Stats.stats.total_units total;
   Atomic.set Stats.stats.total_impls total_impl;
   Atomic.set Stats.stats.non_hidden_units non_hidden;
   Atomic.set Stats.stats.total_mlds mlds;
+  Atomic.set Stats.stats.total_assets assets;
   Atomic.set Stats.stats.total_indexes (Fpath.Set.cardinal indexes)
 
 open Eio.Std
@@ -78,93 +84,99 @@ 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);
+        Atomic.incr Stats.stats.compiled_assets;
+        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 +205,7 @@ let link : compiled list -> _ =
         (match c.kind with
         | `Intf _ -> Atomic.incr Stats.stats.linked_units
         | `Mld -> Atomic.incr Stats.stats.linked_mlds
+        | `Asset -> ()
         | `Impl _ -> Atomic.incr Stats.stats.linked_impls);
         c
   in
@@ -239,6 +252,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_driver.ml

@@ -451,6 +451,7 @@ let render_stats env nprocs =
   let total = Atomic.get Stats.stats.total_units in
   let total_impls = Atomic.get Stats.stats.total_impls in
   let total_mlds = Atomic.get Stats.stats.total_mlds in
+  let total_assets = Atomic.get Stats.stats.total_assets in
   let total_indexes = Atomic.get Stats.stats.total_indexes in
   let bar message total =
     let open Progress.Line in
@@ -474,19 +475,22 @@ let render_stats env nprocs =
       dline "Compiling" total
       ++ dline "Compiling impls" total_impls
       ++ dline "Compiling pages" total_mlds
+      ++ dline "Compiling assets" total_assets
       ++ dline "Linking" non_hidden
       ++ dline "Linking impls" total_impls
       ++ dline "Linking mlds" total_mlds
       ++ dline "Indexes" total_indexes
       ++ dline "HTML" (total_impls + non_hidden + total_mlds)
       ++ line (procs nprocs)
       ++ descriptions)
-    (fun comp compimpl compmld link linkimpl linkmld indexes html procs descr ->
-      let rec inner (a, b, c, d, e, f, i, g, h) =
+    (fun comp compimpl compmld compassets link linkimpl linkmld indexes html
+         procs descr ->
+      let rec inner (a, b, c, j, d, e, f, i, g, h) =
         Eio.Time.sleep clock 0.1;
         let a' = Atomic.get Stats.stats.compiled_units in
         let b' = Atomic.get Stats.stats.compiled_impls in
         let c' = Atomic.get Stats.stats.compiled_mlds in
+        let j' = Atomic.get Stats.stats.compiled_assets in
         let d' = Atomic.get Stats.stats.linked_units in
         let e' = Atomic.get Stats.stats.linked_impls in
         let f' = Atomic.get Stats.stats.linked_mlds in
@@ -499,16 +503,17 @@ let render_stats env nprocs =
         comp (a' - a);
         compimpl (b' - b);
         compmld (c' - c);
+        compassets (j' - j);
         link (d' - d);
         linkimpl (e' - e);
         linkmld (f' - f);
         indexes (i' - i);
         html (g' - g);
         procs (h' - h);
         if g' < non_hidden + total_impls + total_mlds then
-          inner (a', b', c', d', e', f', i', g', h')
+          inner (a', b', c', j', d', e', f', i', g', h')
       in
-      inner (0, 0, 0, 0, 0, 0, 0, 0, 0))
+      inner (0, 0, 0, 0, 0, 0, 0, 0, 0, 0))
 
 let run libs verbose packages_dir odoc_dir odocl_dir html_dir stats nb_workers
     odoc_bin voodoo package_name blessed dune_style =