From fc6a3e8834a9e868f7514b29a202b73f89e45ee2 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 13 May 2024 19:12:12 -0600 Subject: [PATCH] fix: remove incorrect warning when using dune-build-info and (subir ..) Signed-off-by: Rudi Grinberg --- bin/install_uninstall.ml | 2 +- doc/changes/10525.md | 3 + src/dune_rules/artifact_substitution.ml | 4 +- src/dune_rules/dune_rules.ml | 1 - src/dune_rules/link_time_code_gen.ml | 2 +- src/dune_rules/source_tree.ml | 65 ++++++++++++++++++- src/dune_rules/source_tree.mli | 4 ++ src/dune_rules/vcs_db.ml | 62 ------------------ src/dune_rules/vcs_db.mli | 5 -- .../test-cases/dune-build-info-subdir.t | 5 -- 10 files changed, 73 insertions(+), 80 deletions(-) create mode 100644 doc/changes/10525.md delete mode 100644 src/dune_rules/vcs_db.ml delete mode 100644 src/dune_rules/vcs_db.mli diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index e4455e18ee2..1db2a69c6f4 100644 --- a/bin/install_uninstall.ml +++ b/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 diff --git a/doc/changes/10525.md b/doc/changes/10525.md new file mode 100644 index 00000000000..270aad014c4 --- /dev/null +++ b/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) diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index 3938e039ff2..3b4a8f40243 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/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 diff --git a/src/dune_rules/dune_rules.ml b/src/dune_rules/dune_rules.ml index 81e21043a3a..a8054fd659e 100644 --- a/src/dune_rules/dune_rules.ml +++ b/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 diff --git a/src/dune_rules/link_time_code_gen.ml b/src/dune_rules/link_time_code_gen.ml index bedf62744f6..ae635e1f14b 100644 --- a/src/dune_rules/link_time_code_gen.ml +++ b/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 -> diff --git a/src/dune_rules/source_tree.ml b/src/dune_rules/source_tree.ml index bdeea685453..ee18d160d47 100644 --- a/src/dune_rules/source_tree.ml +++ b/src/dune_rules/source_tree.ml @@ -62,6 +62,23 @@ 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 @@ -69,6 +86,7 @@ module Dir0 = struct ; 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 +;; diff --git a/src/dune_rules/source_tree.mli b/src/dune_rules/source_tree.mli index df8d561f1ab..222fa1f69ab 100644 --- a/src/dune_rules/source_tree.mli +++ b/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 diff --git a/src/dune_rules/vcs_db.ml b/src/dune_rules/vcs_db.ml deleted file mode 100644 index 10a1aa3a5c8..00000000000 --- a/src/dune_rules/vcs_db.ml +++ /dev/null @@ -1,62 +0,0 @@ -open Import -open Memo.O - -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 fold_parents = - let rec loop acc f t = function - | [] -> Memo.return acc - | comp :: components -> - (match Filename.Map.find (Source_tree.Dir.sub_dirs t) comp with - | None -> Memo.return acc - | Some sub_dir -> - let* sub_dir = Source_tree.Dir.sub_dir_as_t sub_dir in - let* acc = f sub_dir acc in - loop acc f sub_dir components) - in - fun path ~init ~f -> - let components = Path.Source.explode path in - let* root = Source_tree.root () in - let* acc = f root init in - loop acc f root components -;; - -(* there's no need for any memoization. we use this function sporadically and - it's already fast enough *) -let nearest_vcs = - let f dir acc = - Readdir.of_source_path (Source_tree.Dir.path dir) - >>| function - | Error _ -> acc - | Ok readdir -> - (match - Readdir.dirs readdir |> List.find_map ~f:(fun (s, _) -> Vcs.Kind.of_dir_name s) - with - | None -> acc - | Some kind -> Some { Vcs.kind; root = Path.source @@ Source_tree.Dir.path dir }) - in - fun path -> - let open Memo.O in - let* init = Memo.Lazy.force ancestor_vcs in - fold_parents ~f ~init path -;; diff --git a/src/dune_rules/vcs_db.mli b/src/dune_rules/vcs_db.mli deleted file mode 100644 index 49681c27a15..00000000000 --- a/src/dune_rules/vcs_db.mli +++ /dev/null @@ -1,5 +0,0 @@ -open Import - -(** [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 diff --git a/test/blackbox-tests/test-cases/dune-build-info-subdir.t b/test/blackbox-tests/test-cases/dune-build-info-subdir.t index 6ccdae63083..0c4373e51a1 100644 --- a/test/blackbox-tests/test-cases/dune-build-info-subdir.t +++ b/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