From 5bd15b364d987822c2428778882eefbf9034fd1a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 3 Dec 2023 13:10:36 -0600 Subject: [PATCH] fix(coq): delay loading rules for resolving coqc Signed-off-by: Rudi Grinberg --- otherlibs/stdune/src/map.ml | 6 ++++ otherlibs/stdune/src/map_intf.ml | 1 + src/dune_rules/artifacts.ml | 49 ++++++++++++++++++++++++-------- src/dune_rules/artifacts.mli | 15 +++++++++- src/dune_rules/artifacts_db.ml | 15 ++++++---- src/dune_rules/coq/coq_rules.ml | 20 +++++++++---- 6 files changed, 81 insertions(+), 25 deletions(-) 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..e1491b2e1f9 100644 --- a/src/dune_rules/artifacts.ml +++ b/src/dune_rules/artifacts.ml @@ -4,6 +4,13 @@ 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 + } + +type local_bins = (Path.Build.t * origin option) Filename.Map.t + type t = { context : Context.t ; (* Mapping from executable names to their actual path in the workspace. @@ -11,28 +18,43 @@ 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 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 (Some (Path.of_filename_relative_to_initial_cwd name, None)) | 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 (path, origin) -> Memo.return (Some (Path.build path, origin)) + | None -> + let+ res = Context.which t.context name in + Option.map res ~f:(fun res -> res, None)) ;; let binary t ?hint ~loc name = analyze_binary t name >>| function - | Some path -> Ok path + | Some (path, _) -> Ok path + | None -> + let context = Context.name t.context in + Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ()) +;; + +let binary_with_origin t ?hint ~loc name = + analyze_binary t name + >>| function + | Some (path, origin) -> + Ok + (match origin with + | None -> `External path + | Some origin -> `Origin origin) | None -> let context = Context.name t.context in Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ()) @@ -42,7 +64,7 @@ let binary_available t name = analyze_binary t name >>= function | None -> Memo.return false - | Some path -> + | 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 @@ -55,7 +77,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) (path, None))) in { t with local_bins } ;; @@ -70,10 +92,13 @@ 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 - let key = drop_suffix name in - Filename.Map.set acc key path)) + Path.Build.Map.foldi + local_bins + ~init:Filename.Map.empty + ~f:(fun path origin acc -> + let name = Path.Build.basename path in + let key = drop_suffix name in + Filename.Map.set acc key (path, Some origin))) in { context; local_bins } ;; diff --git a/src/dune_rules/artifacts.mli b/src/dune_rules/artifacts.mli index 8ef0c8f6c2d..502d42ed57d 100644 --- a/src/dune_rules/artifacts.mli +++ b/src/dune_rules/artifacts.mli @@ -2,6 +2,11 @@ open Import type t +type origin = + { binding : File_binding.Unexpanded.t + ; dir : Path.Build.t + } + (** 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. *) @@ -19,4 +24,12 @@ val binary : t -> ?hint:string -> loc:Loc.t option -> string -> Action.Prog.t Me 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 binary_with_origin + : t + -> ?hint:string + -> loc:Loc.t option + -> Filename.t + -> ([ `External of Path.t | `Origin of origin ], Action.Prog.Not_found.t) result Memo.t + +val create : Context.t -> local_bins:origin Path.Build.Map.t Memo.Lazy.t -> t diff --git a/src/dune_rules/artifacts_db.ml b/src/dune_rules/artifacts_db.ml index 0e4cffdda89..ec8c08b897f 100644 --- a/src/dune_rules/artifacts_db.ml +++ b/src/dune_rules/artifacts_db.ml @@ -35,6 +35,7 @@ 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_str ~dir sw = Expander.With_reduced_var_set.expand_str ~context ~dir sw in @@ -60,10 +61,12 @@ let get_installed_binaries ~(context : Context.t) stanzas = 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) + then ( + let origin = { Artifacts.binding = fb; dir } in + Some (Path.Build.append_local install_dir p, origin)) else None) >>| List.filter_opt - >>| Path.Build.Set.of_list + >>| Path.Build.Map.of_list_reduce ~f:(fun _ y -> y) in Memo.List.map d.stanzas ~f:(fun stanza -> match (stanza : Stanza.t) with @@ -84,10 +87,10 @@ let get_installed_binaries ~(context : Context.t) stanzas = 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 + else Memo.return Path.Build.Map.empty + | _ -> Memo.return Path.Build.Map.empty) + >>| Path.Build.Map.union_all ~f:merge) + >>| Path.Build.Map.union_all ~f:merge ;; let all = diff --git a/src/dune_rules/coq/coq_rules.ml b/src/dune_rules/coq/coq_rules.ml index d197cc05a27..d36f2d8f16c 100644 --- a/src/dune_rules/coq/coq_rules.ml +++ b/src/dune_rules/coq/coq_rules.ml @@ -92,12 +92,20 @@ end = struct end let coqc ~loc ~dir ~sctx = - Super_context.resolve_program_memo - sctx - "coqc" - ~dir - ~loc:(Some loc) - ~hint:"opam install coq" + let* artifacts = Super_context.env_node sctx ~dir >>= Env_node.artifacts in + Artifacts.binary_with_origin artifacts ~loc:(Some loc) ~hint:"opam install coq" "coqc" + >>= function + | Error e -> Memo.return @@ Error e + | Ok (`External p) -> Memo.return @@ Ok p + | Ok (`Origin { Artifacts.binding; dir }) -> + let+ expanded = + File_binding.Unexpanded.expand binding ~dir ~f:(fun sw -> + Expander.With_reduced_var_set.expand_str + ~context:(Super_context.context sctx) + ~dir + sw) + in + Ok (Path.build (File_binding.Expanded.dst_path expanded ~dir)) ;; let select_native_mode ~sctx ~dir (buildable : Coq_stanza.Buildable.t) =