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

@@ -24,7 +24,7 @@ type input =
 type 'a t = {
   name : string;
   render : 'a -> Types.Block.t option -> Types.Document.t -> page list;
-  extra_documents : 'a -> input -> Types.Document.t list;
+  filepath : 'a -> Url.Path.t -> Fpath.t;
 }
 
 let document_of_page ~syntax v =

src/document/types.ml

@@ -196,13 +196,8 @@ and Source_page : sig
 end =
   Source_page
 
-and Asset : sig
-  type t = { url : Url.Path.t; src : Fpath.t }
-end =
-  Asset
-
 module Document = struct
-  type t = Page of Page.t | Source_page of Source_page.t | Asset of Asset.t
+  type t = Page of Page.t | Source_page of Source_page.t
 end
 
 let inline ?(attr = []) desc = Inline.{ attr; desc }

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_source ~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,9 @@ let of_dune_build dir =
                       version = "1.0";
                       libraries = [ lib ];
                       mlds = [];
+                      assets =
+                        []
+                        (* When dune has a notion of doc assets, do something *);
                       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 =
@@ -129,30 +143,39 @@ let compile_index ?(ignore_output = false) ~output_file ~json ~docs ~libs () =
     Cmd_outputs.(
       add_prefixed_output cmd link_output (Fpath.to_string output_file) lines)
 
-let html_generate ~output_dir ?index ?(ignore_output = false) ?(assets = [])
+let html_generate ~output_dir ?index ?(ignore_output = false)
     ?(search_uris = []) ~input_file:file () =
   let open Cmd in
   let index =
     match index with None -> empty | Some idx -> v "--index" % p idx
   in
-  let assets =
-    List.fold_left (fun acc filename -> acc % "--asset" % filename) empty assets
-  in
   let search_uris =
     List.fold_left
       (fun acc filename -> acc % "--search-uri" % p filename)
       empty search_uris
   in
   let cmd =
-    !odoc % "html-generate" % p file %% assets %% index %% search_uris % "-o"
-    % output_dir
+    !odoc % "html-generate" % p file %% index %% search_uris % "-o" % output_dir
   in
   let desc = Printf.sprintf "Generating HTML for %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 html_generate_asset ~output_dir ?(ignore_output = false) ~input_file:file
+    ~asset_path () =
+  let open Cmd in
+  let cmd =
+    !odoc % "html-generate-asset" % 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 html_generate_source ~output_dir ?(ignore_output = false) ~source
     ?(search_uris = []) ~input_file:file () =
   let open Cmd 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 ->
@@ -48,12 +50,19 @@ val html_generate :
   output_dir:string ->
   ?index:Fpath.t ->
   ?ignore_output:bool ->
-  ?assets:string list ->
   ?search_uris:Fpath.t list ->
   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 html_generate_source :
   output_dir:string ->
   ?ignore_output:bool ->