diff --git a/doc/changes/9496.md b/doc/changes/9496.md new file mode 100644 index 00000000000..c0f8e95bb6f --- /dev/null +++ b/doc/changes/9496.md @@ -0,0 +1,3 @@ +- Resolve various public binaries to their build location, rather than to where + they're copied in the `_build/install` directory (#9496, fixes #7908, + @rgrinberg). diff --git a/otherlibs/stdune/src/map.ml b/otherlibs/stdune/src/map.ml index 9ac5febe2c1..ccd9deb887e 100644 --- a/otherlibs/stdune/src/map.ml +++ b/otherlibs/stdune/src/map.ml @@ -44,6 +44,12 @@ module Make (Key : Key) : S with type key = Key.t = struct let merge a b ~f = merge a b ~f let union a b ~f = union a b ~f + let union_all maps ~f = + match maps with + | [] -> empty + | init :: maps -> List.fold_left maps ~init ~f:(fun acc map -> union acc map ~f) + ;; + let union_exn a b = union a b ~f:(fun key _ _ -> Code_error.raise diff --git a/otherlibs/stdune/src/map_intf.ml b/otherlibs/stdune/src/map_intf.ml index 01b33baad49..570ab64d235 100644 --- a/otherlibs/stdune/src/map_intf.ml +++ b/otherlibs/stdune/src/map_intf.ml @@ -20,6 +20,7 @@ module type S = sig val add_multi : 'a list t -> key -> 'a -> 'a list t val merge : 'a t -> 'b t -> f:(key -> 'a option -> 'b option -> 'c option) -> 'c t val union : 'a t -> 'a t -> f:(key -> 'a -> 'a -> 'a option) -> 'a t + val union_all : 'a t list -> f:(key -> 'a -> 'a -> 'a option) -> 'a t (** Like [union] but raises a code error if a key appears in both maps. *) val union_exn : 'a t -> 'a t -> 'a t diff --git a/src/dune_rules/artifacts.ml b/src/dune_rules/artifacts.ml index f8e43b36fae..75577ee4431 100644 --- a/src/dune_rules/artifacts.ml +++ b/src/dune_rules/artifacts.ml @@ -4,6 +4,22 @@ open Memo.O let bin_dir_basename = ".bin" let local_bin p = Path.Build.relative p bin_dir_basename +type origin = + { binding : File_binding.Unexpanded.t + ; dir : Path.Build.t + ; dst : Path.Local.t + } + +type where = + | Install_dir + | Original_path + +type path = + | Resolved of Path.Build.t + | Origin of origin + +type local_bins = path Filename.Map.t + type t = { context : Context.t ; (* Mapping from executable names to their actual path in the workspace. @@ -11,42 +27,60 @@ type t = Enumerating binaries from install stanzas may involve expanding globs, but the artifacts database is depended on by the logic which expands globs. The computation of this field is deferred to break the cycle. *) - local_bins : Path.Build.t Filename.Map.t Memo.Lazy.t + local_bins : local_bins Memo.Lazy.t } let force { local_bins; _ } = - let+ (_ : Path.Build.t Filename.Map.t) = Memo.Lazy.force local_bins in + let+ (_ : local_bins) = Memo.Lazy.force local_bins in () ;; +let expand = Fdecl.create Dyn.opaque + let analyze_binary t name = match Filename.is_relative name with - | false -> Memo.return (Some (Path.of_filename_relative_to_initial_cwd name)) + | false -> Memo.return (`Resolved (Path.of_filename_relative_to_initial_cwd name)) | true -> let* local_bins = Memo.Lazy.force t.local_bins in (match Filename.Map.find local_bins name with - | Some path -> Memo.return (Some (Path.build path)) - | None -> Context.which t.context name) + | Some (Resolved p) -> Memo.return (`Resolved (Path.build p)) + | Some (Origin o) -> Memo.return (`Origin o) + | None -> + Context.which t.context name + >>| (function + | None -> `None + | Some path -> `Resolved path)) ;; -let binary t ?hint ~loc name = +let binary t ?hint ?(where = Install_dir) ~loc name = analyze_binary t name - >>| function - | Some path -> Ok path - | None -> + >>= function + | `Resolved path -> Memo.return @@ Ok path + | `None -> let context = Context.name t.context in - Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ()) + Memo.return + @@ Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ()) + | `Origin { dir; binding; dst } -> + (match where with + | Install_dir -> + let install_dir = Install.Context.bin_dir ~context:(Context.name t.context) in + Memo.return @@ Ok (Path.build @@ Path.Build.append_local install_dir dst) + | Original_path -> + let+ expanded = + File_binding.Unexpanded.expand + binding + ~dir + ~f:(Fdecl.get expand ~context:t.context ~dir) + in + let src = File_binding.Expanded.src expanded in + Ok (Path.build src)) ;; let binary_available t name = analyze_binary t name - >>= function - | None -> Memo.return false - | Some path -> - (match path with - | External e -> Fs_memo.file_exists @@ External e - | In_source_tree e -> Fs_memo.file_exists @@ In_source_dir e - | In_build_dir _ -> Memo.return true) + >>| function + | `None -> false + | `Resolved _ | `Origin _ -> true ;; let add_binaries t ~dir l = @@ -55,7 +89,7 @@ let add_binaries t ~dir l = let+ local_bins = Memo.Lazy.force t.local_bins in List.fold_left l ~init:local_bins ~f:(fun acc fb -> let path = File_binding.Expanded.dst_path fb ~dir:(local_bin dir) in - Filename.Map.set acc (Path.Build.basename path) path)) + Filename.Map.set acc (Path.Build.basename path) (Resolved path))) in { t with local_bins } ;; @@ -70,10 +104,9 @@ let create = let local_bins = Memo.lazy_ (fun () -> let+ local_bins = Memo.Lazy.force local_bins in - Path.Build.Set.fold local_bins ~init:Filename.Map.empty ~f:(fun path acc -> - let name = Path.Build.basename path in + Filename.Map.foldi local_bins ~init:Filename.Map.empty ~f:(fun name origin acc -> let key = drop_suffix name in - Filename.Map.set acc key path)) + Filename.Map.set acc key (Origin origin))) in { context; local_bins } ;; diff --git a/src/dune_rules/artifacts.mli b/src/dune_rules/artifacts.mli index 8ef0c8f6c2d..eaef5c14fed 100644 --- a/src/dune_rules/artifacts.mli +++ b/src/dune_rules/artifacts.mli @@ -2,6 +2,16 @@ open Import type t +type origin = + { binding : File_binding.Unexpanded.t + ; dir : Path.Build.t + ; dst : Path.Local.t + } + +type where = + | Install_dir + | Original_path + (** Force the computation of the internal list of binaries. This is exposed as some error checking is only performed during this computation and some errors will go unreported unless this computation takes place. *) @@ -15,8 +25,17 @@ val local_bin : Path.Build.t -> Path.Build.t (** A named artifact that is looked up in the PATH if not found in the tree If the name is an absolute path, it is used as it. *) -val binary : t -> ?hint:string -> loc:Loc.t option -> string -> Action.Prog.t Memo.t +val binary + : t + -> ?hint:string + -> ?where:where + -> loc:Loc.t option + -> Filename.t + -> Action.Prog.t Memo.t val binary_available : t -> string -> bool Memo.t val add_binaries : t -> dir:Path.Build.t -> File_binding.Expanded.t list -> t -val create : Context.t -> local_bins:Path.Build.Set.t Memo.Lazy.t -> t +val create : Context.t -> local_bins:origin Filename.Map.t Memo.Lazy.t -> t + +val expand + : (context:Context.t -> dir:Path.Build.t -> String_with_vars.t -> string Memo.t) Fdecl.t diff --git a/src/dune_rules/artifacts_db.ml b/src/dune_rules/artifacts_db.ml index 72ebec3ff09..022f5f80002 100644 --- a/src/dune_rules/artifacts_db.ml +++ b/src/dune_rules/artifacts_db.ml @@ -36,8 +36,8 @@ let available_exes ~dir (exes : Dune_file.Executables.t) = ;; let get_installed_binaries ~(context : Context.t) stanzas = + let merge _ _ x = Some x in let open Memo.O in - let install_dir = Install.Context.bin_dir ~context:(Context.name context) in let expand ~dir sw = Expander.With_reduced_var_set.expand ~context ~dir sw in let expand_str ~dir sw = Expander.With_reduced_var_set.expand_str ~context ~dir sw in let expand_str_partial ~dir sw = @@ -57,12 +57,14 @@ let get_installed_binaries ~(context : Context.t) stanzas = ~expand:(expand_str ~dir) ~expand_partial:(expand_str_partial ~dir) in - let p = Path.Local.of_string (Install.Entry.Dst.to_string p) in - if Path.Local.is_root (Path.Local.parent_exn p) - then Some (Path.Build.append_local install_dir p) + let dst = Path.Local.of_string (Install.Entry.Dst.to_string p) in + if Path.Local.is_root (Path.Local.parent_exn dst) + then ( + let origin = { Artifacts.binding = fb; dir; dst } in + Some (Path.Local.basename dst, origin)) else None) >>| List.filter_opt - >>| Path.Build.Set.of_list + >>| Filename.Map.of_list_reduce ~f:(fun _ y -> y) in Memo.List.map d.stanzas ~f:(fun stanza -> match Stanza.repr stanza with @@ -80,12 +82,10 @@ let get_installed_binaries ~(context : Context.t) stanzas = | false -> Memo.return true | true -> available_exes ~dir exes) in - if available - then binaries_from_install files - else Memo.return Path.Build.Set.empty - | _ -> Memo.return Path.Build.Set.empty) - >>| Path.Build.Set.union_all) - >>| Path.Build.Set.union_all + if available then binaries_from_install files else Memo.return Filename.Map.empty + | _ -> Memo.return Filename.Map.empty) + >>| Filename.Map.union_all ~f:merge) + >>| Filename.Map.union_all ~f:merge ;; let all = diff --git a/src/dune_rules/cinaps.ml b/src/dune_rules/cinaps.ml index 895ab91a229..0b58c510860 100644 --- a/src/dune_rules/cinaps.ml +++ b/src/dune_rules/cinaps.ml @@ -127,6 +127,7 @@ let gen_rules sctx t ~dir ~scope = Super_context.resolve_program sctx ~dir + ~where:Original_path ~loc:(Some loc) name ~hint:"opam install cinaps" diff --git a/src/dune_rules/coq/coq_config.ml b/src/dune_rules/coq/coq_config.ml index a033f511a17..3e3d3c77855 100644 --- a/src/dune_rules/coq/coq_config.ml +++ b/src/dune_rules/coq/coq_config.ml @@ -269,7 +269,7 @@ let by_name { version_info; coqlib; coqcorelib; coq_native_compiler_default } na let expand source macro artifacts_host = let s = Pform.Macro_invocation.Args.whole macro in let open Memo.O in - let* coqc = Artifacts.binary artifacts_host ~loc:None "coqc" in + let* coqc = Artifacts.binary artifacts_host ~where:Original_path ~loc:None "coqc" in let+ t = make ~coqc in match t with | Error msg -> diff --git a/src/dune_rules/coq/coq_rules.ml b/src/dune_rules/coq/coq_rules.ml index 03f76e41e76..47edce28fdf 100644 --- a/src/dune_rules/coq/coq_rules.ml +++ b/src/dune_rules/coq/coq_rules.ml @@ -95,6 +95,7 @@ let coqc ~loc ~dir ~sctx = Super_context.resolve_program_memo sctx "coqc" + ~where:Original_path ~dir ~loc:(Some loc) ~hint:"opam install coq" @@ -488,6 +489,7 @@ let setup_coqdep_for_theory_rule sctx "coqdep" ~dir + ~where:Original_path ~loc:(Some loc) ~hint:"opam install coq" in @@ -746,6 +748,7 @@ let setup_coqdoc_rules ~sctx ~dir ~theories_deps (s : Coq_stanza.Theory.t) coq_m sctx "coqdoc" ~dir + ~where:Original_path ~loc:(Some loc) ~hint:"opam install coq" in @@ -1075,6 +1078,7 @@ let setup_coqpp_rules ~sctx ~dir ({ loc; modules } : Coq_stanza.Coqpp.t) = Super_context.resolve_program_memo sctx "coqpp" + ~where:Original_path ~dir ~loc:(Some loc) ~hint:"opam install coq" diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index 60e6180d18f..01483d21404 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -925,3 +925,8 @@ let expand_lock ~base expander (Locks.Lock sw) = let expand_locks ~base expander locks = Memo.List.map locks ~f:(expand_lock ~base expander) |> Action_builder.of_memo ;; + +let () = + Fdecl.set Artifacts.expand (fun ~context ~dir sw -> + With_reduced_var_set.expand_str ~context ~dir sw) +;; diff --git a/src/dune_rules/fdo.ml b/src/dune_rules/fdo.ml index 5a69f9ccc75..a16ff54093a 100644 --- a/src/dune_rules/fdo.ml +++ b/src/dune_rules/fdo.ml @@ -35,6 +35,7 @@ let ocamlfdo_binary sctx dir = Super_context.resolve_program sctx ~dir + ~where:Original_path ~loc:None "ocamlfdo" ~hint:"opam install ocamlfdo" diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index a74207d5aa3..f52b2c4064c 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -263,7 +263,13 @@ include Sub_system.Register_end_point (struct let+ flags = flags in Action.run (Ok exe) flags | Some runner -> - let* prog = Super_context.resolve_program ~dir sctx ~loc:(Some loc) runner + let* prog = + Super_context.resolve_program + ~dir + sctx + ~where:Original_path + ~loc:(Some loc) + runner and* flags = flags in let action = Action.run prog (Path.reach exe ~from:(Path.build dir) :: flags) diff --git a/src/dune_rules/jsoo/jsoo_rules.ml b/src/dune_rules/jsoo/jsoo_rules.ml index 614ee32f07d..90c97dbb47b 100644 --- a/src/dune_rules/jsoo/jsoo_rules.ml +++ b/src/dune_rules/jsoo/jsoo_rules.ml @@ -185,7 +185,13 @@ let in_obj_dir' ~obj_dir ~config args = ;; let jsoo ~dir sctx = - Super_context.resolve_program sctx ~dir ~loc:None ~hint:install_jsoo_hint "js_of_ocaml" + Super_context.resolve_program + sctx + ~dir + ~loc:None + ~where:Original_path + ~hint:install_jsoo_hint + "js_of_ocaml" ;; type sub_command = diff --git a/src/dune_rules/mdx.ml b/src/dune_rules/mdx.ml index dd083f50bcb..4d5c090e7fb 100644 --- a/src/dune_rules/mdx.ml +++ b/src/dune_rules/mdx.ml @@ -509,6 +509,7 @@ let gen_rules t ~sctx ~dir ~scope ~expander = let mdx_prog = Super_context.resolve_program sctx + ~where:Original_path ~dir ~loc:(Some t.loc) ~hint:"opam install mdx" diff --git a/src/dune_rules/melange/melange_binary.ml b/src/dune_rules/melange/melange_binary.ml index 219c1d6ed3f..5f1573194af 100644 --- a/src/dune_rules/melange/melange_binary.ml +++ b/src/dune_rules/melange/melange_binary.ml @@ -1,7 +1,13 @@ open Import let melc sctx ~loc ~dir = - Super_context.resolve_program_memo sctx ~loc ~dir ~hint:"opam install melange" "melc" + Super_context.resolve_program_memo + sctx + ~loc + ~dir + ~where:Original_path + ~hint:"opam install melange" + "melc" ;; let where = diff --git a/src/dune_rules/menhir/menhir_rules.ml b/src/dune_rules/menhir/menhir_rules.ml index 119e724b81d..d07ca7afa2d 100644 --- a/src/dune_rules/menhir/menhir_rules.ml +++ b/src/dune_rules/menhir/menhir_rules.ml @@ -119,7 +119,13 @@ module Run (P : PARAMS) = struct (* Rule generation. *) let menhir_binary = - Super_context.resolve_program sctx ~dir "menhir" ~loc:None ~hint:"opam install menhir" + Super_context.resolve_program + sctx + ~dir + ~where:Original_path + "menhir" + ~loc:None + ~hint:"opam install menhir" ;; (* Reminder (from command.mli): diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 7088ce44afb..1c5c58a5f4e 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -247,7 +247,13 @@ let odoc_base_flags quiet build_dir = ;; let odoc_program sctx dir = - Super_context.resolve_program sctx ~dir "odoc" ~loc:None ~hint:"opam install odoc" + Super_context.resolve_program + sctx + ~dir + ~where:Original_path + "odoc" + ~loc:None + ~hint:"opam install odoc" ;; let run_odoc sctx ~dir command ~quiet ~flags_for args = diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index 8d5b46b8a71..f45de64358a 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -231,13 +231,13 @@ let add_alias_action t alias ~dir ~loc action = let env_node = Env_tree.get_node -let resolve_program_memo t ~dir ?hint ~loc bin = +let resolve_program_memo t ~dir ?where ?hint ~loc bin = let* artifacts = Env_tree.artifacts_host t ~dir in - Artifacts.binary ?hint ~loc artifacts bin + Artifacts.binary ?hint ?where ~loc artifacts bin ;; -let resolve_program t ~dir ?hint ~loc bin = - Action_builder.of_memo @@ resolve_program_memo t ~dir ?hint ~loc bin +let resolve_program t ~dir ?where ?hint ~loc bin = + Action_builder.of_memo @@ resolve_program_memo t ~dir ?where ?hint ~loc bin ;; let make_default_env_node diff --git a/src/dune_rules/super_context.mli b/src/dune_rules/super_context.mli index c5685164590..e01963f57d7 100644 --- a/src/dune_rules/super_context.mli +++ b/src/dune_rules/super_context.mli @@ -69,6 +69,7 @@ val add_alias_action val resolve_program : t -> dir:Path.Build.t + -> ?where:Artifacts.where -> ?hint:string -> loc:Loc.t option -> string @@ -78,6 +79,7 @@ val resolve_program val resolve_program_memo : t -> dir:Path.Build.t + -> ?where:Artifacts.where -> ?hint:string -> loc:Loc.t option -> string