Driver

CHANGES.md

@@ -11,6 +11,7 @@
 - Navigation for the search bar : use '/' to enter search, up and down arrows to
   select a result, and enter to follow the selected link. (@EmileTrotignon, #1088)
 - OCaml 5.2.0 compatibility (@Octachron, #1094, #1112)
+- New driver package (@jonludlam, #1121)
 
 ### Changed
 

odoc-driver.opam

@@ -0,0 +1,59 @@
+opam-version: "2.0"
+
+version: "dev"
+homepage: "https://github.com/ocaml/odoc"
+doc: "https://ocaml.github.io/odoc/"
+bug-reports: "https://github.com/ocaml/odoc/issues"
+license: "ISC"
+
+maintainer: [
+  "Daniel Bünzli <daniel.buenzli@erratique.ch>"
+  "Jon Ludlam <jon@recoil.org>"
+  "Jules Aguillon <juloo.dsi@gmail.com>"
+  "Paul-Elliot Anglès d'Auriac <paul-elliot@tarides.com>"
+]
+authors: [
+  "Anton Bachin <antonbachin@yahoo.com>"
+  "Daniel Bünzli <daniel.buenzli@erratique.ch>"
+  "David Sheets <sheets@alum.mit.edu>"
+  "Jon Ludlam <jon@recoil.org>"
+  "Jules Aguillon <juloo.dsi@gmail.com>"
+  "Leo White <leo@lpw25.net>"
+  "Lubega Simon <lubegasimon73@gmail.com>"
+  "Paul-Elliot Anglès d'Auriac <paul-elliot@tarides.com>"
+  "Thomas Refis <trefis@janestreet.com>"
+]
+dev-repo: "git+https://github.com/ocaml/odoc.git"
+
+synopsis: "OCaml Documentation Generator - Driver"
+description: """
+The driver is a sample implementation of a tool to drive odoc to generate
+documentation for installed packages.
+"""
+
+
+depends: [
+  "odoc" {= version}
+  "bos" 
+  "fpath"
+  "yojson"
+  "ocamlfind"
+  "opam-format"
+  "logs"
+  "eio_main"
+]
+
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]

src/.ocamlformat-ignore

@@ -13,4 +13,5 @@ syntax_highlighter/syntax_highlighter.ml
 model/*.cppo.ml
 html_support_files/*.ml
 xref2/shape_tools.*
+odoc/classify.cppo.ml
 

src/driver/compile.ml

@@ -0,0 +1,161 @@
+(* compile *)
+
+type ty = Module of Packages.modulety | Mld of Packages.mld
+
+type compiled = {
+  m : ty;
+  output_dir : Fpath.t;
+  output_file : Fpath.t;
+  include_dirs : Fpath.Set.t;
+  impl : (Fpath.t * Fpath.t) option;
+}
+
+let mk_byhash (pkgs : Packages.t Util.StringMap.t) =
+  Util.StringMap.fold
+    (fun _pkg_name pkg acc ->
+      List.fold_left
+        (fun acc (lib : Packages.libty) ->
+          List.fold_left
+            (fun acc (m : Packages.modulety) ->
+              Util.StringMap.add m.m_intf.mif_hash m acc)
+            acc lib.modules)
+        acc pkg.Packages.libraries)
+    pkgs Util.StringMap.empty
+
+open Eio.Std
+
+let compile env all =
+  let hashes = mk_byhash all in
+  let tbl = Hashtbl.create 10 in
+  let output_dir = Fpath.v "_odoc" in
+
+  let compile_one compile_other hash =
+    match Util.StringMap.find_opt hash hashes with
+    | None ->
+        Logs.debug (fun m -> m "Error locating hash: %s" hash);
+        Error Not_found
+    | Some modty ->
+        let deps = modty.m_intf.mif_deps in
+        let output_file = Fpath.(output_dir // modty.m_intf.mif_odoc_file) in
+        let fibers =
+          Fiber.List.map
+            (fun (n, h) ->
+              match compile_other h with
+              | Ok r -> Some r
+              | Error _exn ->
+                  Logs.debug (fun m -> m "Missing module %s (hash %s)" n h);
+                  None)
+            deps
+        in
+        let includes =
+          List.fold_left
+            (fun acc opt ->
+              match opt with
+              | Some s -> Fpath.(Set.add s.output_dir acc)
+              | _ -> acc)
+            Fpath.Set.empty fibers
+        in
+        let includes = Fpath.Set.add output_dir includes in
+        let impl =
+          match modty.m_impl with
+          | Some impl -> (
+              match impl.mip_src_info with
+              | Some si ->
+                  let output_file = Fpath.(output_dir // impl.mip_odoc_file) in
+                  Odoc.compile_impl env output_dir impl.mip_path includes
+                    impl.mip_parent_id si.src_id;
+                  Some (output_file, si.src_path)
+              | None -> None)
+          | None -> None
+        in
+
+        Odoc.compile env output_dir modty.m_intf.mif_path includes
+          modty.m_intf.mif_parent_id;
+        let output_dir = Fpath.split_base output_file |> fst in
+        Ok
+          {
+            m = Module modty;
+            output_dir;
+            output_file;
+            include_dirs = includes;
+            impl;
+          }
+  in
+
+  let rec compile : string -> (compiled, exn) Result.t =
+   fun hash ->
+    match Hashtbl.find_opt tbl hash with
+    | Some p -> Promise.await_exn p
+    | None ->
+        let p, r = Promise.create () in
+        Hashtbl.add tbl hash p;
+        let result = compile_one compile hash in
+        Promise.resolve_ok r result;
+        result
+  in
+  let mods =
+    Util.StringMap.fold
+      (fun hash modty acc ->
+        match compile hash with
+        | Error exn ->
+            Logs.err (fun m ->
+                m "Error compiling module %s" modty.Packages.m_name);
+            raise exn
+        | Ok x -> x :: acc)
+      hashes []
+  in
+  Util.StringMap.fold
+    (fun _ (pkg : Packages.t) acc ->
+      Logs.debug (fun m ->
+          m "Package %s mlds: [%a]" pkg.name
+            Fmt.(list ~sep:sp Packages.pp_mld)
+            pkg.mlds);
+      List.fold_left
+        (fun acc (mld : Packages.mld) ->
+          let output_file = Fpath.(output_dir // mld.Packages.mld_odoc_file) in
+          let odoc_output_dir = Fpath.split_base output_file |> fst in
+          Odoc.compile env output_dir mld.mld_path Fpath.Set.empty
+            mld.mld_parent_id;
+          let include_dirs =
+            List.map (fun f -> Fpath.(output_dir // f)) mld.mld_deps
+            |> Fpath.Set.of_list
+          in
+          let include_dirs = Fpath.Set.add odoc_output_dir include_dirs in
+          { m = Mld mld; output_dir; output_file; include_dirs; impl = None }
+          :: acc)
+        acc pkg.mlds)
+    all mods
+
+type linked = { output_file : Fpath.t; src : Fpath.t option }
+
+let link : _ -> compiled list -> _ =
+ fun env compiled ->
+  let link : compiled -> linked list =
+   fun c ->
+    let include_dirs = Fpath.Set.add c.output_dir c.include_dirs in
+    let impl =
+      match c.impl with
+      | Some (x, y) ->
+          Logs.debug (fun m -> m "Linking impl: %a" Fpath.pp x);
+          Odoc.link env x include_dirs;
+          [ { output_file = Fpath.(set_ext "odocl" x); src = Some y } ]
+      | None -> []
+    in
+    match c.m with
+    | Module m when m.m_hidden ->
+        Logs.debug (fun m -> m "not linking %a" Fpath.pp c.output_file);
+        impl
+    | _ ->
+        Logs.debug (fun m -> m "linking %a" Fpath.pp c.output_file);
+        Odoc.link env c.output_file include_dirs;
+        { output_file = Fpath.(set_ext "odocl" c.output_file); src = None }
+        :: impl
+  in
+  Fiber.List.map link compiled |> List.concat
+
+let html_generate : _ -> linked list -> _ =
+ fun env linked ->
+  let html_generate : linked -> unit =
+   fun l -> Odoc.html_generate env l.output_file l.src
+  in
+  Fiber.List.iter html_generate linked

src/driver/dune

@@ -0,0 +1,4 @@
+(executable
+ (public_name odoc_driver)
+ (package odoc-driver)
+ (libraries bos fpath yojson findlib opam-format logs logs.fmt eio_main))

src/driver/indexes.ml

@@ -0,0 +1,7 @@
+let package fmt (pkg : Packages.t) =
+  Format.fprintf fmt "{0 Package %s}\n" pkg.name;
+  Format.fprintf fmt "{1 Libraries}\n";
+  List.iter
+    (fun (lib : Packages.libty) ->
+      Format.fprintf fmt "{2 %s}\n" lib.archive_name)
+    pkg.libraries

src/driver/ocamlfind.ml

@@ -0,0 +1,71 @@
+module StringSet = Set.Make (String)
+module StringMap = Map.Make (String)
+
+let package_to_dir_map () =
+  Findlib.init ();
+  let packages = Fl_package_base.list_packages () in
+  List.map
+    (fun pkg_name ->
+      let dir = (Fl_package_base.query pkg_name).package_dir in
+      (pkg_name, dir))
+    packages
+
+let get_dir lib =
+  try
+    Findlib.init ();
+    Fl_package_base.query lib |> fun x ->
+    Ok Fpath.(v x.package_dir |> to_dir_path)
+  with e ->
+    Printf.eprintf "Error: %s\n" (Printexc.to_string e);
+    Error (`Msg "Error getting directory")
+
+let top_libraries () =
+  Findlib.init ();
+  let packages = Fl_package_base.list_packages () in
+  List.fold_left
+    (fun acc lib ->
+      let package = String.split_on_char '.' lib |> List.hd in
+      StringSet.add package acc)
+    StringSet.empty packages
+
+let archives pkg =
+  Findlib.init ();
+  let package = Fl_package_base.query pkg in
+  let get_1 preds =
+    try
+      [
+        Fl_metascanner.lookup "archive" preds
+          package.Fl_package_base.package_defs;
+      ]
+    with _ -> []
+  in
+  match pkg with
+  | "stdlib" -> [ "stdlib.cma"; "stdlib.cmxa" ]
+  | _ ->
+      get_1 [ "native" ] @ get_1 [ "byte" ]
+      |> List.filter (fun x -> String.length x > 0)
+
+let sub_libraries top =
+  Findlib.init ();
+  let packages = Fl_package_base.list_packages () in
+  List.fold_left
+    (fun acc lib ->
+      let package = String.split_on_char '.' lib |> List.hd in
+      if package = top then StringSet.add lib acc else acc)
+    StringSet.empty packages
+  |> StringSet.elements
+
+let dir_to_package_map () =
+  let package_to_dir = package_to_dir_map () in
+  List.fold_left
+    (fun map (pkg_name, dir) ->
+      StringMap.update dir
+        (function None -> Some [ pkg_name ] | Some l -> Some (pkg_name :: l))
+        map)
+    StringMap.empty package_to_dir
+
+let deps pkgs =
+  try
+    let packages = Fl_package_base.requires_deeply ~preds:[] pkgs in
+    Ok packages
+  with e -> Error (`Msg (Printexc.to_string e))

src/driver/ocamlobjinfo.ml

@@ -0,0 +1,46 @@
+(* ocamlobjinfo *)
+
+open Bos
+let ocamlobjinfo = Cmd.v "ocamlobjinfo"
+
+let source_possibilities file =
+  let default = [ file ] in
+  let generated =
+    if Astring.String.is_suffix ~affix:"-gen" file then
+      let pos = String.length file - 4 in
+      [ Astring.String.take ~max:pos file ]
+    else []
+  in
+  default @ generated
+
+let get_source env file =
+  let cmd = Cmd.(ocamlobjinfo % p file) in
+  let lines = Run.run env cmd in
+  let f =
+    List.filter_map
+      (fun line ->
+        let affix = "Source file: " in
+        if Astring.String.is_prefix ~affix line then
+          let name =
+            String.sub line (String.length affix)
+              (String.length line - String.length affix)
+          in
+          let name = Fpath.(filename (v name)) in
+          let dir, _ = Fpath.split_base file in
+          let possibilities =
+            List.map
+              (fun poss -> Fpath.(dir / poss))
+              (source_possibilities name)
+          in
+          List.find_opt
+            (fun f -> Sys.file_exists (Fpath.to_string f))
+            possibilities
+        else None)
+      lines
+  in
+  match f with
+  | [] -> None
+  | x :: _ :: _ ->
+      Logs.warn (fun m -> m "Multiple source files found for %a" Fpath.pp file);
+      Some x
+  | x :: _ -> Some x