Driver: package and library arguments

odoc-driver.opam

@@ -46,6 +46,7 @@ depends: [
   "cmdliner"
   "sexplib"
   "ppx_sexp_conv"
+  "opam-state"
 ]
 
 build: [

src/driver/cmd_outputs.ml

@@ -1,22 +1,27 @@
-let submit desc cmd output_file =
-  match Worker_pool.submit desc cmd output_file with
-  | Ok x -> x
-  | Error exn -> raise exn
-
-let compile_output = ref [ "" ]
-
-let compile_src_output = ref [ "" ]
+type log_dest =
+  [ `Compile
+  | `Compile_src
+  | `Link
+  | `Count_occurrences
+  | `Generate
+  | `Index
+  | `Source_tree
+  | `Sherlodoc
+  | `Classify ]
 
-let link_output = ref [ "" ]
+let outputs : (log_dest * [ `Out | `Err ] * string * string) list ref = ref []
 
-let generate_output = ref [ "" ]
+let maybe_log log_dest r =
+  match log_dest with
+  | Some (dest, prefix) ->
+      let add ty s = outputs := !outputs @ [ (dest, ty, prefix, s) ] in
+      add `Out r.Run.output;
+      add `Err r.Run.errors
+  | None -> ()
 
-let index_output = ref [ "" ]
-
-let source_tree_output = ref [ "" ]
-
-let add_prefixed_output cmd list prefix lines =
-  if List.length lines > 0 then
-    list :=
-      !list
-      @ (Bos.Cmd.to_string cmd :: List.map (fun l -> prefix ^ ": " ^ l) lines)
+let submit log_dest desc cmd output_file =
+  match Worker_pool.submit desc cmd output_file with
+  | Ok x ->
+      maybe_log log_dest x;
+      String.split_on_char '\n' x.output
+  | Error exn -> raise exn

src/driver/compile.ml

@@ -213,20 +213,20 @@ let link : compiled list -> _ =
  fun compiled ->
   let link : compiled -> linked =
    fun c ->
-    let link input_file output_file =
+    let link input_file output_file enable_warnings =
       let libs = Odoc_unit.Pkg_args.compiled_libs c.pkg_args in
       let pages = Odoc_unit.Pkg_args.compiled_pages c.pkg_args in
       let includes = c.include_dirs in
       Odoc.link ~input_file ~output_file ~includes ~libs ~docs:pages
-        ?current_package:c.pkgname ()
+        ~ignore_output:(not enable_warnings) ?current_package:c.pkgname ()
     in
     match c.kind with
     | `Intf { hidden = true; _ } ->
         Logs.debug (fun m -> m "not linking %a" Fpath.pp c.odoc_file);
         c
     | _ ->
         Logs.debug (fun m -> m "linking %a" Fpath.pp c.odoc_file);
-        link c.odoc_file c.odocl_file;
+        link c.odoc_file c.odocl_file c.enable_warnings;
         (match c.kind with
         | `Intf _ -> Atomic.incr Stats.stats.linked_units
         | `Mld -> Atomic.incr Stats.stats.linked_mlds

src/driver/db.ml

@@ -0,0 +1,10 @@
+(* Db - a type to help determine which modules belong in which libraries *)
+
+type t = {
+  all_libs : Util.StringSet.t;
+  all_lib_deps : Util.StringSet.t Util.StringMap.t;
+  lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
+  archives_by_dir : Util.StringSet.t Fpath.map;
+  libname_of_archive : string Fpath.map;
+  cmi_only_libs : (Fpath.t * string) list;
+}

src/driver/dune

@@ -17,4 +17,5 @@
   logs.fmt
   eio_main
   sexplib
-  odoc_utils))
+  odoc_utils
+  opam-state))

src/driver/dune_style.ml

@@ -35,9 +35,7 @@ let of_dune_describe txt =
 let dune_describe dir =
   let cmd = Cmd.(!dune % "describe" % "--root" % p dir) in
   let out = Worker_pool.submit "dune describe" cmd None in
-  match out with
-  | Error _ -> []
-  | Ok out -> of_dune_describe (String.concat "\n" out)
+  match out with Error _ -> [] | Ok out -> of_dune_describe out.Run.output
 
 let of_dune_build dir =
   let contents =
@@ -91,6 +89,12 @@ let of_dune_build dir =
             | _ -> None)
           sorted
       in
+      let libname_of_archive =
+        List.fold_left
+          (fun acc (libname, path) ->
+            Fpath.Map.add Fpath.(path / libname) libname acc)
+          Fpath.Map.empty libs
+      in
       let libs =
         List.map
           (fun (libname, path) ->
@@ -99,11 +103,8 @@ let of_dune_build dir =
             in
             let pkg_dir = Fpath.rem_prefix dir path |> Option.get in
             ( pkg_dir,
-              Packages.Lib.v
-                ~libname_of_archive:
-                  (Fpath.Map.singleton Fpath.(path / libname) libname)
-                ~pkg_name:libname ~dir:path ~cmtidir:(Some cmtidir)
-                ~all_lib_deps ~cmi_only_libs:[] ))
+              Packages.Lib.v ~libname_of_archive ~pkg_name:libname ~dir:path
+                ~cmtidir:(Some cmtidir) ~all_lib_deps ~cmi_only_libs:[] ))
           libs
       in
       let packages =
@@ -121,6 +122,7 @@ let of_dune_build dir =
                       assets =
                         []
                         (* When dune has a notion of doc assets, do something *);
+                      enable_warnings = false;
                       pkg_dir;
                       other_docs = Fpath.Set.empty;
                       config = Global_config.empty;

src/driver/global_config.ml

@@ -43,3 +43,9 @@ let parse s =
   of_ast ast
 
 let empty = { deps = { libraries = []; packages = [] } }
+
+let load pkg_name =
+  let config_file =
+    Fpath.(v (Opam.prefix ()) / "doc" / pkg_name / "odoc-config.sexp")
+  in
+  match Bos.OS.File.read config_file with Error _ -> empty | Ok s -> parse s

src/driver/global_config.mli

@@ -5,3 +5,5 @@ type t = { deps : deps }
 val empty : t
 
 val parse : string -> t
+
+val load : string -> t

src/driver/landing_pages.ml

@@ -18,6 +18,7 @@ let make_index ~dirs ~rel_dir ?index ~content () =
     odoc_file;
     odocl_file;
     include_dirs = Fpath.Set.empty;
+    enable_warnings = false;
     kind = `Mld;
     index;
   }

src/driver/ocamlfind.ml

@@ -16,10 +16,9 @@ let get_dir lib =
   try
     init ();
     Fl_package_base.query lib |> fun x ->
-    Logs.debug (fun m -> m "Package %s is in directory %s@." lib x.package_dir);
     Ok Fpath.(v x.package_dir |> to_dir_path)
   with e ->
-    Printf.eprintf "Error: %s\n" (Printexc.to_string e);
+    Logs.err (fun m -> m "Error: %s\n" (Printexc.to_string e));
     Error (`Msg "Error getting directory")
 
 let archives pkg =
@@ -51,11 +50,166 @@ let sub_libraries top =
       if package = top then Util.StringSet.add lib acc else acc)
     Util.StringSet.empty packages
 
+(* Returns deep dependencies for the given package *)
+let rec dep =
+  let memo = ref Util.StringMap.empty in
+  fun pkg ->
+    init ();
+    try Util.StringMap.find pkg !memo
+    with Not_found -> (
+      try
+        let deps = Fl_package_base.requires ~preds:[ "ppx_driver" ] pkg in
+        let result =
+          List.fold_left
+            (fun acc x ->
+              match dep x with
+              | Ok dep_deps -> Util.StringSet.(union acc (add x dep_deps))
+              | Error _ -> acc)
+            Util.StringSet.empty deps
+        in
+        memo := Util.StringMap.add pkg (Ok result) !memo;
+        Ok result
+      with e ->
+        let result = Error (`Msg (Printexc.to_string e)) in
+        memo := Util.StringMap.add pkg result !memo;
+        result)
+
 let deps pkgs =
-  init ();
-  try
-    let packages =
-      Fl_package_base.requires_deeply ~preds:[ "ppx_driver" ] pkgs
+  let results = List.map dep pkgs in
+  Ok
+    (List.fold_left Util.StringSet.union
+       (Util.StringSet.singleton "stdlib")
+       (List.map (Result.value ~default:Util.StringSet.empty) results))
+
+module Db = struct
+  type t = {
+    all_libs : Util.StringSet.t;
+    all_lib_deps : Util.StringSet.t Util.StringMap.t;
+    lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
+    archives_by_dir : Util.StringSet.t Fpath.map;
+    libname_of_archive : string Fpath.map;
+    cmi_only_libs : (Fpath.t * string) list;
+  }
+
+  let create libs =
+    let _ = Opam.prefix () in
+    let libs = Util.StringSet.to_seq libs |> List.of_seq in
+
+    (* First, find the complete set of libraries - that is, including all of
+       the dependencies of the libraries supplied on the commandline *)
+    let all_libs_deps =
+      match deps libs with
+      | Error (`Msg msg) ->
+          Logs.err (fun m -> m "Error finding dependencies: %s" msg);
+          Util.StringSet.empty
+      | Ok libs -> Util.StringSet.add "stdlib" libs
+    in
+
+    let all_libs_set =
+      Util.StringSet.union all_libs_deps (Util.StringSet.of_list libs)
+    in
+    let all_libs = Util.StringSet.elements all_libs_set in
+
+    (* Now we need the dependency tree of those libraries *)
+    let all_lib_deps =
+      List.fold_right
+        (fun lib_name acc ->
+          match deps [ lib_name ] with
+          | Ok deps -> Util.StringMap.add lib_name deps acc
+          | Error (`Msg msg) ->
+              Logs.err (fun m ->
+                  m
+                    "Error finding dependencies of library '%s' through \
+                     ocamlfind: %s"
+                    lib_name msg);
+              acc)
+        all_libs Util.StringMap.empty
+    in
+
+    (* We also need to find, for each library, the library directory and
+       the list of archives for that library *)
+    let lib_dirs_and_archives =
+      List.filter_map
+        (fun lib ->
+          match get_dir lib with
+          | Error _ ->
+              Logs.err (fun m -> m "No dir for library %s" lib);
+              None
+          | Ok p ->
+              let archives = archives lib in
+              let archives =
+                List.map
+                  (fun x ->
+                    try Filename.chop_extension x
+                    with e ->
+                      Logs.err (fun m -> m "Can't chop extension from %s" x);
+                      raise e)
+                  archives
+              in
+              let archives = Util.StringSet.(of_list archives) in
+              Some (lib, p, archives))
+        all_libs
+    in
+
+    (* An individual directory may contain multiple libraries, each with
+       zero or more archives. We need to know which directories contain
+       which archives *)
+    let archives_by_dir =
+      List.fold_left
+        (fun set (_lib, p, archives) ->
+          Fpath.Map.update p
+            (function
+              | Some set -> Some (Util.StringSet.union set archives)
+              | None -> Some archives)
+            set)
+        Fpath.Map.empty lib_dirs_and_archives
+    in
+
+    (* Compute the mapping between full path of an archive to the
+       name of the libary *)
+    let libname_of_archive =
+      List.fold_left
+        (fun map (lib, dir, archives) ->
+          match Util.StringSet.elements archives with
+          | [] -> map
+          | [ archive ] ->
+              Fpath.Map.update
+                Fpath.(dir / archive)
+                (function
+                  | None -> Some lib
+                  | Some x ->
+                      Logs.info (fun m ->
+                          m
+                            "Multiple libraries for archive %s: %s and %s. \
+                             Arbitrarily picking the latter."
+                            archive x lib);
+                      Some lib)
+                map
+          | xs ->
+              Logs.err (fun m ->
+                  m "multiple archives detected: [%a]"
+                    Fmt.(list ~sep:sp string)
+                    xs);
+              assert false)
+        Fpath.Map.empty lib_dirs_and_archives
+    in
+
+    (* We also need to know about libraries that have no archives at all
+       (these are virtual libraries usually) *)
+    let cmi_only_libs =
+      List.fold_left
+        (fun map (lib, dir, archives) ->
+          match Util.StringSet.elements archives with
+          | [] -> (dir, lib) :: map
+          | _ -> map)
+        [] lib_dirs_and_archives
     in
-    Ok packages
-  with e -> Error (`Msg (Printexc.to_string e))
+    {
+      all_libs = all_libs_set;
+      all_lib_deps;
+      lib_dirs_and_archives;
+      archives_by_dir;
+      libname_of_archive;
+      cmi_only_libs;
+    }
+end

src/driver/ocamlfind.mli

@@ -10,5 +10,18 @@ val archives : string -> string list
 val sub_libraries : string -> Util.StringSet.t
 (** Returns the list of sublibraries of a given library *)
 
-val deps : string list -> (string list, [> `Msg of string ]) result
+val deps : string list -> (Util.StringSet.t, [> `Msg of string ]) result
 (** Returns the list of transitive package dependencies of given libraries *)
+
+module Db : sig
+  type t = {
+    all_libs : Util.StringSet.t;
+    all_lib_deps : Util.StringSet.t Util.StringMap.t;
+    lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
+    archives_by_dir : Util.StringSet.t Fpath.map;
+    libname_of_archive : string Fpath.map;
+    cmi_only_libs : (Fpath.t * string) list;
+  }
+
+  val create : Util.StringSet.t -> t
+end

src/driver/ocamlobjinfo.ml

@@ -26,7 +26,7 @@ let get_source file srcdirs =
   in
   let lines =
     match lines_res with
-    | Ok l -> l
+    | Ok l -> String.split_on_char '\n' l.output
     | Error e ->
         Logs.err (fun m ->
             m "Error finding source for module %a: %s" Fpath.pp file