Allow more hierarchy to be compatible with -L and -P.

src/odoc/bin/main.ml

@@ -66,7 +66,7 @@ module Antichain = struct
     Fpath.normalize p
 
   (** Check that a list of directories form an antichain: they are all disjoints *)
-  let check l =
+  let check ~opt l =
     let l =
       List.map
         ~f:(fun p -> p |> Fs.Directory.to_fpath |> absolute_normalization)
@@ -81,7 +81,12 @@ module Antichain = struct
             rest
           && check rest
     in
-    check l
+    if check l then Result.Ok ()
+    else
+      let msg =
+        Format.sprintf "Paths given to all %s options must be disjoint" opt
+      in
+      Error (`Msg msg)
 end
 
 let docs = "ARGUMENTS"
@@ -467,13 +472,8 @@ module Indexing = struct
       occurrences =
     let marshall = if json then `JSON else `Marshall in
     output_file ~dst marshall >>= fun output ->
-    (if
-       not
-         (Antichain.check
-            (List.rev_append lib_roots page_roots |> List.map ~f:snd))
-     then Error (`Msg "Paths given to all -P and -L options must be disjoint")
-     else Ok ())
-    >>= fun () ->
+    Antichain.check (page_roots |> List.map ~f:snd) ~opt:"-P" >>= fun () ->
+    Antichain.check (lib_roots |> List.map ~f:snd) ~opt:"-L" >>= fun () ->
     Indexing.compile marshall ~output ~warnings_options ~occurrences ~lib_roots
       ~page_roots ~inputs_in_file ~odocls:inputs
   let cmd =
@@ -594,88 +594,50 @@ end = struct
         l
     in
     let o = Antichain.absolute_normalization o in
-    (* Taken from OCaml 5.2 standard library *)
-    let rec find_map ~f = function
-      | [] -> None
-      | x :: l -> (
-          match f x with Some _ as result -> result | None -> find_map ~f l)
-    in
     match l with
-    | [] -> Ok None
-    | _ -> (
-        match
-          find_map
-            ~f:(fun (pkg, path) ->
-              if Fpath.is_prefix path o then Some pkg else None)
-            l
-        with
-        | Some _ as r -> Ok r
-        | None -> Error `Not_found)
+    | [] -> None
+    | _ ->
+        Odoc_utils.List.find_map
+          (fun (root, path) ->
+            if Fpath.is_prefix path o then Some root else None)
+          l
 
   let current_library_of_input lib_roots input =
-    match find_root_of_input lib_roots input with
-    | Ok _ as ok -> ok
-    | Error `Not_found ->
-        Error (`Msg "The input file must be part of a directory passed as -L")
+    find_root_of_input lib_roots input
 
-  (** Whether if the package specified with [--current-package] is consistent
+  (** Checks if the package specified with [--current-package] is consistent
       with the pages roots and with the output path for pages. *)
   let validate_current_package ?detected_package page_roots current_package =
-    match current_package with
-    | Some curpkgnane -> (
-        if
-          not
-            (List.exists
-               ~f:(fun (pkgname, _) -> pkgname = curpkgnane)
-               page_roots)
+    match (current_package, detected_package) with
+    | Some curpkgnane, Some detected_package when detected_package <> curpkgnane
+      ->
+        Error
+          (`Msg
+            "The package name specified with --current-package is not \
+             consistent with the packages passed as a -P")
+    | _, (Some _ as r) (* we have equality or only detected package *) -> Ok r
+    | (Some given as g), None ->
+        if not (List.exists ~f:(fun (pkgname, _) -> pkgname = given) page_roots)
         then
           Error
             (`Msg
               "The package name specified with --current-package do not match \
                any package passed as a -P")
-        else
-          match detected_package with
-          | Some dpkg when dpkg <> curpkgnane ->
-              Error
-                (`Msg
-                  "The package name specified with --current-package is not \
-                   consistent with the packages passed as a -P")
-          | _ -> Ok current_package)
-    | None -> Ok detected_package
-
-  let current_package_of_page ~current_package page_roots input =
-    match find_root_of_input page_roots input with
-    | Ok detected_package ->
-        validate_current_package ?detected_package page_roots current_package
-    | Error `Not_found ->
-        Error (`Msg "The input file must be part of a directory passed as -P")
-
-  let is_page input =
-    input |> Fpath.filename |> Astring.String.is_prefix ~affix:"page-"
-
-  let is_asset input =
-    input |> Fpath.filename |> Astring.String.is_prefix ~affix:"asset-"
+        else Ok g
+    | None, None -> Ok None
+
+  let find_current_package ~current_package page_roots input =
+    let detected_package = find_root_of_input page_roots input in
+    validate_current_package ?detected_package page_roots current_package
 
   let link directories page_roots lib_roots input_file output_file
       current_package warnings_options open_modules =
     let input = Fs.File.of_string input_file in
     let output = get_output_file ~output_file ~input in
-    (if
-       not
-         (Antichain.check
-            (List.rev_append lib_roots page_roots |> List.map ~f:snd))
-     then
-       Error
-         (`Msg "Arguments given to -P and -L cannot be included in each others")
-     else Ok ())
-    >>= fun () ->
-    let is_page_or_asset = is_page input || is_asset input in
-    (if is_page_or_asset then Ok None
-     else current_library_of_input lib_roots input)
-    >>= fun current_lib ->
-    (if is_page_or_asset then
-       current_package_of_page ~current_package page_roots input
-     else validate_current_package page_roots current_package)
+    Antichain.check (page_roots |> List.map ~f:snd) ~opt:"-P" >>= fun () ->
+    Antichain.check (lib_roots |> List.map ~f:snd) ~opt:"-L" >>= fun () ->
+    let current_lib = current_library_of_input lib_roots input in
+    find_current_package ~current_package page_roots input
     >>= fun current_package ->
     let current_dir = Fs.File.dirname output in
     let roots =

src/odoc/resolver.ml

@@ -39,7 +39,13 @@ module Named_roots : sig
 
   type error = NoPackage | NoRoot
 
-  val create : (string * Fs.Directory.t) list -> current_root:string option -> t
+  type input = {
+    name : string;
+    dir : Fs.Directory.t;
+    omit : Fs.Directory.t list;
+  }
+
+  val create : input list -> current_root:string option -> t
 
   val all_of : ?root:string -> ext:string -> t -> (Fs.File.t list, error) result
 
@@ -57,34 +63,44 @@ end = struct
 
   type hierarchical = (Fs.File.t, Fs.File.t) Hashtbl.t * Fs.Directory.t
 
-  type pkg = { flat : flat; hierarchical : hierarchical }
+  type pkg = {
+    flat : flat;
+    hierarchical : hierarchical;
+    omit : Fs.Directory.t list;
+  }
 
   type t = {
     table : (string, pkg) Hashtbl.t;
     current_root : string option;
     current_root_dir : Fs.Directory.t option;
   }
 
+  type input = {
+    name : string;
+    dir : Fs.Directory.t;
+    omit : Fs.Directory.t list;
+  }
+
   type error = NoPackage | NoRoot
 
   let hashtbl_find_opt cache package =
     match Hashtbl.find cache package with
     | x -> Some x
     | exception Not_found -> None
 
-  let create pkglist ~current_root =
+  let create (pkglist : input list) ~current_root =
     let cache = Hashtbl.create 42 in
     List.iter
-      (fun (pkgname, root) ->
+      (fun { name = pkgname; dir = root; omit } ->
         let flat = Unvisited root
         and hierarchical = (Hashtbl.create 42, root) in
-        Hashtbl.add cache pkgname { flat; hierarchical })
+        Hashtbl.add cache pkgname { flat; hierarchical; omit })
       pkglist;
     let current_root_dir =
       match current_root with
       | Some root ->
           List.fold_left
-            (fun acc (x, dir) ->
+            (fun acc { name = x; dir; _ } ->
               if Astring.String.equal x root then Some dir else acc)
             None pkglist
       | None -> None
@@ -93,6 +109,11 @@ end = struct
 
   let current_root t = t.current_root_dir
 
+  let check_omit ~omit path =
+    List.for_all
+      (fun omit -> not @@ Fs.Directory.contains ~parentdir:omit path)
+      omit
+
   let find_by_path ?root { table = cache; current_root; _ } ~path =
     let path = Fpath.normalize path in
     let root =
@@ -102,25 +123,27 @@ end = struct
     in
     root >>= fun root ->
     match hashtbl_find_opt cache root with
-    | Some { hierarchical = cache, root; _ } -> (
+    | Some { hierarchical = cache, root; omit; _ } -> (
         match hashtbl_find_opt cache path with
         | Some x -> Ok (Some x)
         | None ->
             let full_path = Fpath.( // ) (Fs.Directory.to_fpath root) path in
-            if Fs.File.exists full_path then (
+            if Fs.File.exists full_path && check_omit ~omit full_path then (
               Hashtbl.add cache path full_path;
               Ok (Some full_path))
             else Ok None)
     | None -> Error NoPackage
 
-  let populate_flat_namespace ~root =
+  let populate_flat_namespace ~root ~omit =
     let flat_namespace = Hashtbl.create 42 in
     let () =
       match
         Fs.Directory.fold_files_rec_result
           (fun () path ->
             let name = Fpath.filename path in
-            Ok (Hashtbl.add flat_namespace name path))
+            if check_omit ~omit path then
+              Ok (Hashtbl.add flat_namespace name path)
+            else Ok ())
           () root
       with
       | Ok () -> ()
@@ -138,8 +161,8 @@ end = struct
     package >>= fun package ->
     match hashtbl_find_opt cache package with
     | Some { flat = Visited flat; _ } -> Ok (Hashtbl.find_all flat name)
-    | Some ({ flat = Unvisited root; _ } as p) ->
-        let flat = populate_flat_namespace ~root in
+    | Some ({ flat = Unvisited root; omit; _ } as p) ->
+        let flat = populate_flat_namespace ~omit ~root in
         Hashtbl.replace cache package { p with flat = Visited flat };
         Ok (Hashtbl.find_all flat name)
     | None -> Error NoPackage
@@ -157,8 +180,8 @@ end = struct
     in
     match Hashtbl.find table my_root with
     | { flat = Visited flat; _ } -> return flat
-    | { flat = Unvisited root; _ } as p ->
-        let flat = populate_flat_namespace ~root in
+    | { flat = Unvisited root; omit; _ } as p ->
+        let flat = populate_flat_namespace ~omit ~root in
         Hashtbl.replace table my_root { p with flat = Visited flat };
         return flat
     | exception Not_found -> Error NoPackage
@@ -544,6 +567,22 @@ let create ~important_digests ~directories ~open_modules ~roots =
     | None -> (None, None, None)
     | Some { page_roots; lib_roots; current_lib; current_package; current_dir }
       ->
+        let prepare roots omit =
+          List.map
+            (fun (name, dir) ->
+              let omit =
+                List.filter
+                  (fun o ->
+                    Fs.Directory.contains ~parentdir:dir
+                      (Fs.Directory.to_fpath o))
+                  omit
+              in
+              { Named_roots.name; dir; omit })
+            roots
+        in
+        let omit = List.map snd lib_roots in
+        let page_roots = prepare page_roots omit in
+        let lib_roots = prepare lib_roots [] in
         let pages = Named_roots.create ~current_root:current_package page_roots
         and libs = Named_roots.create ~current_root:current_lib lib_roots in
         (Some pages, Some libs, Some current_dir)