Use the source rendering feature

src/voodoo-do/do.ml

@@ -61,16 +61,29 @@ module IncludePaths = struct
     Index.M.fold (fun _ v acc -> Fpath.Set.add v acc) index.extern dirs
 end
 
-let get_source_info parent path =
+let get_source_info source_maps parent path =
   match Fpath.segs path with
-  | "prep" :: "universes" :: id :: pkg_name :: version :: _ -> (
+  | "prep" :: "universes" :: universe :: pkg_name :: version :: rest -> (
       match Odoc.compile_deps path with
       | Some (name, digest, deps) ->
+          let src_file =
+            match
+              List.assoc_opt
+                { Package.universe; name = pkg_name; version }
+                source_maps
+            with
+            | Some map ->
+                let path = String.concat "/" rest in
+                let p = Fpath.v path |> Fpath.set_ext ".cmt" in
+                Dune_rules.ml_of_cmt map p
+            | _ -> None
+          in
           [
             Sourceinfo.
               {
-                package = { universe = id; name = pkg_name; version };
+                package = { universe; name = pkg_name; version };
                 path;
+                src_file;
                 name;
                 digest;
                 deps;
@@ -141,6 +154,22 @@ let run pkg_name ~blessed ~failed =
       [] Paths.prep
     |> Result.get_ok
   in
+  let dune_rules =
+    Bos.OS.Dir.fold_contents ~dotfiles:false
+      (fun p acc ->
+        match Fpath.segs p with
+        | [ "prep"; "universes"; universe; name; version; "dune_rules" ] ->
+            if right_package p then
+              ({ Package.universe; name; version }, p) :: acc
+            else acc
+        | _ -> acc)
+      [] Paths.prep
+  in
+  let source_maps =
+    match dune_rules with
+    | Ok ps -> List.map (fun (pkg, rules) -> (pkg, Dune_rules.read rules)) ps
+    | _ -> []
+  in
   let modules =
     List.fold_left
       (fun acc f ->
@@ -150,6 +179,7 @@ let run pkg_name ~blessed ~failed =
       [] prep
   in
   let package = { Package.universe; name = pkg_name; version } in
+  let source_map = List.assoc_opt package source_maps in
   let output_path =
     if blessed then Fpath.(Paths.link / "p" / pkg_name / version)
     else Fpath.(Paths.link / "u" / universe / pkg_name / version)
@@ -188,14 +218,24 @@ let run pkg_name ~blessed ~failed =
 
   let error_log = Error_log.find package in
 
-  let parent =
-    Version.gen_parent package ~blessed ~modules ~dune ~libraries ~package_mlds
-      ~error_log ~failed
+  let src_files =
+    match source_map with
+    | Some map ->
+        Dune_rules.M.fold
+          (fun _cmt src acc -> Fpath.to_string src :: acc)
+          map.Dune_rules.src []
+    | None -> []
   in
 
-  let () = Package_info.gen ~output:output_path ~dune ~libraries in
+  let parent, src_parent =
+    Version.gen_parent package ~blessed ~modules ~src_files ~dune ~libraries
+      ~package_mlds ~error_log ~failed
+  in
 
-  let sis = Compat.List.concat_map (get_source_info parent) prep in
+  let src_parent_odoc = Src.output_file src_parent in
+
+  let () = Package_info.gen ~output:output_path ~dune ~libraries in
+  let sis = Compat.List.concat_map (get_source_info source_maps parent) prep in
   let this_index = InputSelect.select sis in
   Index.write this_index parent;
   let index = Index.combine this_index index in
@@ -212,7 +252,13 @@ let run pkg_name ~blessed ~failed =
       in
       let includes = IncludePaths.get index si in
       let output = Sourceinfo.output_file si in
-      Odoc.compile ~parent:parent.Mld.name ~output si.path ~includes
+      let source =
+        match si.src_file with
+        | Some fpath ->
+            Some (Fpath.to_string src_parent_odoc, Fpath.to_string fpath)
+        | None -> None
+      in
+      Odoc.compile ~parent:parent.Mld.name ~output si.path ~includes ?source
         ~children:[];
       si.path :: compiled
   in
@@ -226,32 +272,31 @@ let run pkg_name ~blessed ~failed =
   Util.mkdir_p output;
   Index.M.iter
     (fun _ si ->
-      if Sourceinfo.is_hidden si then ()
+      if Sourceinfo.is_hidden si then
+        let src = Sourceinfo.output_file si in
+        let dst = Sourceinfo.output_linked_odoc_for_src si in
+        let cmd = Bos.Cmd.(v "cp" % p src % p dst) in
+        Voodoo_lib.Util.run_silent cmd
       else
         Odoc.link
           (Sourceinfo.output_file si)
           ~includes:all_includes
           ~output:(Sourceinfo.output_odocl si))
     this_index.intern;
-  let odocls =
-    Index.M.fold
-      (fun _ si acc ->
-        if Sourceinfo.is_hidden si then acc
-        else Sourceinfo.output_odocl si :: acc)
-      this_index.intern []
-  in
   Odoc.link (Mld.output_file parent) ~includes:all_includes
     ~output:(Mld.output_odocl parent);
+  Odoc.link
+    (Src.output_file src_parent)
+    ~includes:all_includes
+    ~output:(Src.output_odocl src_parent);
   List.iter
     (fun mldv ->
       Odoc.link (Mld.output_file mldv) ~includes:all_includes
         ~output:(Mld.output_odocl mldv))
     mldvs;
-  let odocls = odocls @ List.map Mld.output_odocl (parent :: mldvs) in
   Format.eprintf "%d other files to copy\n%!" (List.length otherdocs);
   let otherdocs, _opam_file = Otherdocs.copy parent otherdocs opam_file in
   List.iter (fun p -> Format.eprintf "dest: %a\n%!" Fpath.pp p) otherdocs;
-  List.iter (Odoc.html ~output) odocls;
   let () =
     Bos.OS.File.delete (Fpath.v "compile/page-p.odoc") |> Result.get_ok
   in
@@ -262,6 +307,24 @@ let run pkg_name ~blessed ~failed =
     Bos.OS.File.delete (Fpath.v ("compile/p/page-" ^ pkg_name ^ ".odoc"))
     |> Result.get_ok
   in
+  (* copy source *)
+  let () =
+    let src_path =
+      Fpath.(Paths.prep / "universes" / universe / pkg_name / version / "src")
+    in
+    match Bos.OS.Dir.exists src_path with
+    | Ok true ->
+        let dst_path = output_path in
+        let cmd =
+          Bos.Cmd.(
+            v "rsync" % "-av" % Fpath.to_string src_path
+            % Fpath.to_string dst_path)
+        in
+        List.iter
+          (fun l -> Format.eprintf "%s\n%!" l)
+          (Util.lines_of_process cmd)
+    | _ -> ()
+  in
   if failed then
     Bos.OS.File.write Fpath.(output_path / "failed") "failed" |> Result.get_ok;
   ()

src/voodoo-gen/main.ml

@@ -68,6 +68,7 @@ let generate_pkgver output_dir name_filter version_filter =
             (fun p files ->
               match Fpath.get_ext p with
               | ".odocl" -> { files with odocls = p :: files.odocls }
+              | ".odoc" -> { files with odocls = p :: files.odocls }
               | _ -> (
                   match Fpath.basename p with
                   | "opam" -> files
@@ -101,10 +102,13 @@ let generate_pkgver output_dir name_filter version_filter =
               in
               Fpath.normalize @@ Odoc_odoc.Fs.File.append output_dir output_path
             in
-            let paths =
-              List.rev_map (Rendering.render ~output) files
-              |> List.rev_map Result.get_ok |> List.flatten
-            in
+            let root = Fpath.(pkg_path / "src") in
+            Voodoo_lib.Util.mkdir_p root;
+            let src_output = Odoc_odoc.Fs.Directory.to_string output_dir in
+            List.iter
+              (Voodoo_lib.Odoc.html_gen_source ~root ~output:src_output)
+              files;
+            let paths = [] in
             let foutput =
               Fpath.v (Odoc_odoc.Fs.Directory.to_string output_dir)
             in

src/voodoo-prep/dune

@@ -2,4 +2,4 @@
  (name main)
  (public_name voodoo-prep)
  (package voodoo-prep)
- (libraries cmdliner fpath bos opam-format))
+ (libraries cmdliner fpath bos.setup opam-format))

src/voodoo-prep/prep.ml

@@ -1,10 +1,20 @@
 type actions = { copy : (Fpath.t * Fpath.t) list; objinfo : Fpath.t list }
 
+module Result = Bos_setup.R
+open Result.Infix
+
 (** [process_package root p files] copies some files among [files] to the
     [Package.prep_path p]. Store the [ocamlobjinfo] of the [.cma] files. *)
-let process_package : Fpath.t -> Package.t -> Fpath.t list -> unit =
- fun root package files ->
+let process_package :
+    Fpath.t ->
+    Package.t ->
+    Fpath.t list ->
+    (Fpath.t * Fpath.t) list ->
+    Fpath.t ->
+    unit =
+ fun root package files src_files build_path ->
   let dest = Package.prep_path package in
+  let src_dest = Fpath.(dest / "src") in
 
   (* Some packages produce ocaml artefacts that can't be processed with the switch's
       ocaml compiler - most notably the secondary compiler! This switch is intended to
@@ -44,7 +54,10 @@ let process_package : Fpath.t -> Package.t -> Fpath.t list -> unit =
     let objinfo = if is_cma then fpath :: acc.objinfo else acc.objinfo in
     { copy; objinfo }
   in
-  let actions = List.fold_right foldfn files { copy = []; objinfo = [] } in
+  let copy =
+    List.map (fun (fpath, rpath) -> Fpath.(fpath, src_dest // rpath)) src_files
+  in
+  let actions = List.fold_right foldfn files { copy; objinfo = [] } in
   List.iter
     (fun (src, dst) ->
       let dir, _ = Fpath.split_base dst in
@@ -58,7 +71,35 @@ let process_package : Fpath.t -> Package.t -> Fpath.t list -> unit =
           Bos.Cmd.(v "ocamlobjinfo" % Fpath.(to_string (root // fpath)))
       in
       Util.write_file Fpath.(dest // set_ext "ocamlobjinfo" fpath) lines)
-    actions.objinfo
+    actions.objinfo;
+  let lines =
+    Bos.OS.Dir.with_current build_path
+      (fun () ->
+        Bos.OS.File.exists (Fpath.v "dune-project") >>= fun exists ->
+        Bos.OS.Dir.exists (Fpath.v "_build/default") >>= fun exists' ->
+        if exists && exists' then
+          Bos.OS.Dir.fold_contents ~dotfiles:true
+            (fun p acc -> if Fpath.has_ext ".cmt" p then p :: acc else acc)
+            []
+            Fpath.(v "_build")
+          >>= function
+          | [] -> Ok []
+          | cmts ->
+              let cmd =
+                List.fold_left
+                  (fun acc cmt -> Bos.Cmd.(acc % p cmt))
+                  Bos.Cmd.(v "dune" % "rules" % "-p" % package.name)
+                  cmts
+              in
+              let lines = try Util.lines_of_process cmd with _ -> [] in
+              Ok lines
+        else Ok [])
+      ()
+  in
+  match lines with
+  | Ok (Ok []) -> ()
+  | Ok (Ok l) -> Util.write_file Fpath.(dest / "dune_rules") l
+  | _ -> ()
 
 let run (universes : (string * string) list) =
   let get_universe =
@@ -93,11 +134,38 @@ let run (universes : (string * string) list) =
          []
   in
   let root = Opam.prefix () |> Fpath.v in
+  let pkg_src build_path =
+    let src_root = build_path in
+    let src_files =
+      let dune_src_root = Fpath.(src_root / "_build" / "default") in
+      let root =
+        match Bos.OS.Dir.exists dune_src_root with
+        | Ok true -> dune_src_root
+        | _ -> src_root
+      in
+      Bos.OS.Dir.fold_contents
+        (fun p acc ->
+          if Fpath.has_ext ".ml" p then
+            (p, Fpath.relativize ~root p |> Option.get) :: acc
+          else acc)
+        [] dune_src_root
+    in
+    Util.R.value ~default:[] src_files
+  in
   let pkg_contents =
-    List.map (fun package -> (package, Opam.pkg_contents package)) packages
+    List.map
+      (fun package ->
+        let build_path =
+          Fpath.(
+            root / ".opam-switch" / "build"
+            / (package.Package.name ^ "." ^ package.version))
+        in
+        (package, Opam.pkg_contents package, pkg_src build_path, build_path))
+      packages
   in
   List.iter
-    (fun (package, files) -> process_package root package files)
+    (fun (package, files, src_files, build_path) ->
+      process_package root package files src_files build_path)
     pkg_contents;
   List.iter
     (fun package ->

src/voodoo-prep/util.ml

@@ -40,3 +40,7 @@ let write_file filename lines =
   close_out oc
 
 let cp src dst = assert (lines_of_process Cmd.(v "cp" % src % dst) = [])
+
+module R = struct
+  let value ~default = function Ok x -> x | Error _ -> default
+end

src/voodoo-prep/util.mli

@@ -12,3 +12,7 @@ val write_file : Fpath.t -> string list -> unit
 
 val cp : string -> string -> unit
 (** [cp src dst] copies [src] to [dst]. *)
+
+module R : sig
+  val value : default:'a -> ('a, 'b) result -> 'a
+end

src/voodoo/dune.mli

@@ -22,7 +22,14 @@ end
 
 type t = { name : string; version : string option; libraries : Library.t list }
 
-val process_file : Fpath.t -> (t, [> `Msg of string ]) Bos_setup.result
+val assoc_list :
+  Sexplib.Sexp.t ->
+  ((string * Sexplib.Sexp.t list) list, [> Bos_setup.R.msg ]) Bos_setup.result
+
+val sexp_of_file :
+  Fpath.t -> (Sexplib.Sexp.t, [> Bos_setup.R.msg ]) Bos_setup.result
+
+val process_file : Fpath.t -> (t, [> Bos_setup.R.msg ]) Bos_setup.result
 (** [process_file f] processes the [dune-package] file located at [f]. *)
 
 val find : Package.t -> (Fpath.t, [> Bos_setup.R.msg ]) Bos_setup.result