fix: remove incorrect warning when using dune-build-info and (subir ..)

Signed-off-by: Rudi Grinberg <[email protected]>

<!-- ps-id: 2a46d068-1637-4438-8db6-f4175cc268d9 -->

bin/install_uninstall.ml

@@ -204,7 +204,7 @@ module File_ops_real (W : sig
   open W
 
   let print_line = print_line ~verbosity
-  let get_vcs p = Dune_rules.Vcs_db.nearest_vcs p
+  let get_vcs p = Source_tree.nearest_vcs p
 
   type copy_special_file_status =
     | Done

doc/changes/10525.md

@@ -0,0 +1,3 @@
+- Fix incorrect warning for libraries defined inside non-existant directories
+  using `(subdir ..)` and used by executables using `dune-build-info` (#10525,
+  @rgrinberg)

src/dune_rules/artifact_substitution.ml

@@ -117,7 +117,7 @@ module Conf = struct
 
   let of_context (context : Context.t) =
     let open Memo.O in
-    let get_vcs = Vcs_db.nearest_vcs in
+    let get_vcs = Source_tree.nearest_vcs in
     let name = Context.name context in
     let get_location = Install.Paths.get_local_location name in
     let get_config_path = function
@@ -140,7 +140,7 @@ module Conf = struct
 
   let of_install ~relocatable ~roots ~(context : Context.t) =
     let open Memo.O in
-    let get_vcs = Vcs_db.nearest_vcs in
+    let get_vcs = Source_tree.nearest_vcs in
     let hardcoded_ocaml_path =
       match relocatable with
       | Some prefix -> Memo.return @@ Relocatable prefix

src/dune_rules/dune_rules.ml

@@ -59,7 +59,6 @@ module Command = Command
 module Clflags = Clflags
 module Dune_project = Dune_project
 module Dune_project_name = Dune_project_name
-module Vcs_db = Vcs_db
 module Source_tree = Source_tree
 module Source_dir_status = Source_dir_status
 module Dune_file0 = Dune_file0

src/dune_rules/link_time_code_gen.ml

@@ -91,7 +91,7 @@ let build_info_code cctx ~libs ~api_version =
   (match api_version with
    | Lib_info.Special_builtin_support.Build_info.V1 -> ());
   let placeholder placeholders p =
-    Vcs_db.nearest_vcs p
+    Source_tree.nearest_vcs p
     >>| function
     | None -> "None", placeholders
     | Some vcs ->

src/dune_rules/source_tree.ml

@@ -62,13 +62,31 @@ module Output = struct
 end
 
 module Dir0 = struct
+  module Vcs = struct
+    type nonrec t =
+      | This of Vcs.t
+      | Ancestor_vcs
+
+    let get_vcs ~default:vcs ~readdir ~path =
+      match
+        Filename.Set.union
+          (Readdir.files readdir)
+          (Filename.Set.of_list_map (Readdir.dirs readdir) ~f:fst)
+        |> Vcs.Kind.of_dir_contents
+      with
+      | None -> vcs
+      | Some kind -> This { Vcs.kind; root = Path.(append_source root) path }
+    ;;
+  end
+
   type t =
     { path : Path.Source.t
     ; status : Source_dir_status.t
     ; files : Filename.Set.t
     ; sub_dirs : sub_dir Filename.Map.t
     ; dune_file : Dune_file0.t option
     ; project : Dune_project.t
+    ; vcs : Vcs.t
     }
 
   and sub_dir =
@@ -77,7 +95,7 @@ module Dir0 = struct
     ; sub_dir_as_t : (Path.Source.t, t Output.t option) Memo.Cell.t
     }
 
-  let rec to_dyn { path; status; files; dune_file; sub_dirs; project = _ } =
+  let rec to_dyn { path; status; files; dune_file; sub_dirs; vcs = _; project = _ } =
     let open Dyn in
     Record
       [ "path", Path.Source.to_dyn path
@@ -204,6 +222,7 @@ end = struct
 
   let contents
     readdir
+    ~vcs
     ~path
     ~parent_dune_file
     ~dirs_visited
@@ -228,7 +247,8 @@ end = struct
         ~dune_file
         ~path
     in
-    { Dir0.project; status = dir_status; path; files; sub_dirs; dune_file }, dirs_visited
+    ( { Dir0.project; vcs; status = dir_status; path; files; sub_dirs; dune_file }
+    , dirs_visited )
   ;;
 
   let error_unable_to_load ~path unix_error =
@@ -262,13 +282,21 @@ end = struct
                    Package.Name.Map.empty)
         >>| Only_packages.filter_packages_in_project ~vendored:(dir_status = Vendored)
       in
+      let vcs = Dir0.Vcs.get_vcs ~default:Dir0.Vcs.Ancestor_vcs ~readdir ~path in
       let* dirs_visited =
         Readdir.File.of_source_path (In_source_dir path)
         >>| function
         | Ok file -> Dirs_visited.singleton path file
         | Error unix_error -> error_unable_to_load ~path unix_error
       in
-      contents readdir ~path ~parent_dune_file:None ~dirs_visited ~project ~dir_status
+      contents
+        readdir
+        ~vcs
+        ~path
+        ~parent_dune_file:None
+        ~dirs_visited
+        ~project
+        ~dir_status
     in
     { Output.dir; visited }
   ;;
@@ -321,10 +349,12 @@ end = struct
                         ~vendored:(dir_status = Vendored))
              >>| Option.value ~default:parent_dir.project
          in
+         let vcs = Dir0.Vcs.get_vcs ~default:parent_dir.vcs ~readdir ~path in
          let+ dir, visited =
            let dirs_visited = Dirs_visited.Per_fn.find dirs_visited path in
            contents
              readdir
+             ~vcs
              ~path
              ~parent_dune_file:parent_dir.dune_file
              ~dirs_visited
@@ -463,3 +493,32 @@ let is_vendored dir =
   | None -> false
   | Some d -> Dir.status d = Vendored
 ;;
+
+let ancestor_vcs =
+  Memo.lazy_ ~name:"ancestor_vcs" (fun () ->
+    if Execution_env.inside_dune
+    then Memo.return None
+    else (
+      let rec loop dir =
+        if Fpath.is_root dir
+        then None
+        else (
+          let dir = Filename.dirname dir in
+          match
+            Sys.readdir dir
+            |> Array.to_list
+            |> Filename.Set.of_list
+            |> Vcs.Kind.of_dir_contents
+          with
+          | Some kind -> Some { Vcs.kind; root = Path.of_string dir }
+          | None -> loop dir)
+      in
+      Memo.return (loop (Path.to_absolute_filename Path.root))))
+;;
+
+let nearest_vcs dir =
+  let* dir = nearest_dir dir in
+  match dir.vcs with
+  | This vcs -> Memo.return (Some vcs)
+  | Ancestor_vcs -> Memo.Lazy.force ancestor_vcs
+;;

src/dune_rules/source_tree.mli

@@ -55,3 +55,7 @@ val files_of : Path.Source.t -> Path.Source.Set.t Memo.t
 
 (** [true] iff the path is a vendored directory *)
 val is_vendored : Path.Source.t -> bool Memo.t
+
+(** [nearest_vcs t fn] returns the version control system with the longest root
+    path that is an ancestor of [fn]. *)
+val nearest_vcs : Path.Source.t -> Vcs.t option Memo.t

test/blackbox-tests/test-cases/dune-build-info-subdir.t

@@ -18,8 +18,3 @@ dune-build-info.
   > EOF
 
   $ dune build ./foo.exe
-  Warning: Unable to read directory bar. Ignoring.
-  Remove this message by ignoring by adding:
-  (dirs \ bar)
-  to the dune file: dune
-  Reason: opendir(bar): No such file or directory