fix(coq): delay loading rules for resolving coqc

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

<!-- ps-id: 76f077ec-d88b-4878-a538-c72deab5b9cd -->

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

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

src/dune_rules/artifacts.ml

@@ -4,35 +4,57 @@ 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.
        The keys are the executable names without the .exe, even on Windows.
        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 }
 ;;

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

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 =

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) =

src/dune_rules/file_binding.ml

@@ -108,6 +108,7 @@ end
 module Unexpanded = struct
   type nonrec t = (String_with_vars.t, String_with_vars.t) t
 
+  let src t = t.src
   let to_dyn = to_dyn String_with_vars.to_dyn String_with_vars.to_dyn
   let equal = equal String_with_vars.equal_no_loc String_with_vars.equal_no_loc
 

src/dune_rules/file_binding.mli

@@ -21,6 +21,7 @@ module Unexpanded : sig
 
   val to_dyn : t -> Dyn.t
   val equal : t -> t -> bool
+  val src : t -> String_with_vars.t
 
   val make
     :  src:Loc.t * string