Remove Build_system.set_packages

Signed-off-by: Jeremie Dimino <[email protected]>

Author: jeremiedimino

src/dune_engine/build_system.ml

@@ -384,8 +384,6 @@ type t =
            -> extra_sub_directories_to_keep Memo.Build.t)
           option)
       Fdecl.t
-  ; (* Package files are part of *)
-    packages : (Path.Build.t -> Package.Id.Set.t Memo.Build.t) Fdecl.t
   ; mutable caching : caching option
   ; sandboxing_preference : Sandbox_mode.t list
   ; mutable rule_done : int
@@ -2091,12 +2089,7 @@ let process_memcycle (cycle_error : Memo.Cycle_error.t) =
       ; Pp.chain cycle ~f:(fun p -> p)
       ]
 
-let set_packages f =
-  let t = t () in
-  Fdecl.set t.packages f
-
-let package_deps (pkg : Package.t) files =
-  let t = t () in
+let package_deps ~packages_of (pkg : Package.t) files =
   let rules_seen = ref Rule.Set.empty in
   let rec loop fn =
     match Path.as_in_build_dir fn with
@@ -2105,7 +2098,7 @@ let package_deps (pkg : Package.t) files =
          and it doesn't have dependencies that do *)
       Memo.Build.return Package.Id.Set.empty
     | Some fn ->
-      let* pkgs = Fdecl.get t.packages fn in
+      let* pkgs = packages_of fn in
       if Package.Id.Set.is_empty pkgs || Package.Id.Set.mem pkgs pkg.id then
         loop_deps fn
       else
@@ -2346,7 +2339,6 @@ let init ~stats ~contexts ~promote_source ?caching ~sandboxing_preference () =
   in
   let t =
     { contexts
-    ; packages = Fdecl.create Dyn.Encoder.opaque
     ; gen_rules = Fdecl.create Dyn.Encoder.opaque
     ; init_rules = Fdecl.create Dyn.Encoder.opaque
     ; vcs = Fdecl.create Dyn.Encoder.opaque

src/dune_engine/build_system.mli

@@ -105,13 +105,14 @@ val targets_of : dir:Path.t -> Path.Set.t Memo.Build.t
 (** Load the rules for this directory. *)
 val load_dir : dir:Path.t -> unit Memo.Build.t
 
-(** Sets the package assignment *)
-val set_packages : (Path.Build.t -> Package.Id.Set.t Memo.Build.t) -> unit
-
 (** Assuming [files] is the list of files in [_build/install] that belong to
     package [pkg], [package_deps t pkg files] is the set of direct package
     dependencies of [package]. *)
-val package_deps : Package.t -> Path.Set.t -> Package.Id.Set.t Memo.Build.t
+val package_deps :
+     packages_of:(Path.Build.t -> Package.Id.Set.t Memo.Build.t)
+  -> Package.t
+  -> Path.Set.t
+  -> Package.Id.Set.t Memo.Build.t
 
 (** {2 Aliases} *)
 

src/dune_rules/gen_rules.ml

@@ -390,22 +390,6 @@ let gen_rules ~sctx ~dir components =
 let init () =
   let open Fiber.O in
   let* sctxs = Memo.Build.run (Memo.Lazy.force Super_context.all) in
-  let () =
-    Build_system.set_packages (fun path ->
-        match
-          let open Option.O in
-          let* ctx_name, _ = Path.Build.extract_build_context path in
-          let* ctx_name = Context_name.of_string_opt ctx_name in
-          Context_name.Map.find sctxs ctx_name
-        with
-        | None -> Memo.Build.return Package.Id.Set.empty
-        | Some sctx ->
-          let open Memo.Build.O in
-          let+ map = Install_rules.packages sctx in
-          Option.value
-            (Path.Build.Map.find map path)
-            ~default:Package.Id.Set.empty)
-  in
   let+ () =
     Build_system.set_rule_generators
       ~init:(fun () ->

src/dune_rules/install_rules.ml

@@ -752,6 +752,48 @@ let install_entries sctx (package : Package.t) =
   let+ packages = Stanzas_to_entries.stanzas_to_entries sctx in
   Package.Name.Map.Multi.find packages (Package.name package)
 
+let packages =
+  let f sctx =
+    let packages = Package.Name.Map.values (Super_context.packages sctx) in
+    let+ l =
+      Memo.Build.parallel_map packages ~f:(fun (pkg : Package.t) ->
+          install_entries sctx pkg
+          >>| List.map ~f:(fun (_loc, (entry : _ Install.Entry.t)) ->
+                  (entry.src, pkg.id)))
+    in
+    Path.Build.Map.of_list_fold (List.concat l) ~init:Package.Id.Set.empty
+      ~f:Package.Id.Set.add
+  in
+  let memo =
+    Memo.create "package-map" ~doc:"Return a map assining package to files"
+      ~input:(module Super_context.As_memo_key)
+      ~visibility:Hidden
+      ~output:
+        (Allow_cutoff
+           (module struct
+             type t = Package.Id.Set.t Path.Build.Map.t
+
+             let to_dyn = Path.Build.Map.to_dyn Package.Id.Set.to_dyn
+
+             let equal = Path.Build.Map.equal ~equal:Package.Id.Set.equal
+           end))
+      f
+  in
+  fun sctx -> Memo.exec memo sctx
+
+let packages_file_is_part_of path =
+  Memo.Build.Option.bind
+    (let open Option.O in
+    let* ctx_name, _ = Path.Build.extract_build_context path in
+    Context_name.of_string_opt ctx_name)
+    ~f:Super_context.find
+  >>= function
+  | None -> Memo.Build.return Package.Id.Set.empty
+  | Some sctx ->
+    let open Memo.Build.O in
+    let+ map = packages sctx in
+    Option.value (Path.Build.Map.find map path) ~default:Package.Id.Set.empty
+
 let install_rules sctx (package : Package.t) =
   let package_name = Package.name package in
   let install_paths =
@@ -772,7 +814,9 @@ let install_rules sctx (package : Package.t) =
   let packages =
     let open Action_builder.O in
     let+ packages =
-      Action_builder.memo_build (Build_system.package_deps package files)
+      Action_builder.memo_build
+        (Build_system.package_deps package files
+           ~packages_of:packages_file_is_part_of)
     in
     match strict_package_deps with
     | false -> packages
@@ -932,32 +976,3 @@ let gen_rules sctx ~dir =
     Rules.produce_dir ~dir (Option.value ~default:Rules.Dir_rules.empty rules)
   in
   Build_system.Subdir_set.These subdirs
-
-let packages =
-  let f sctx =
-    let packages = Package.Name.Map.values (Super_context.packages sctx) in
-    let+ l =
-      Memo.Build.parallel_map packages ~f:(fun (pkg : Package.t) ->
-          install_entries sctx pkg
-          >>| List.map ~f:(fun (_loc, (entry : _ Install.Entry.t)) ->
-                  (entry.src, pkg.id)))
-    in
-    Path.Build.Map.of_list_fold (List.concat l) ~init:Package.Id.Set.empty
-      ~f:Package.Id.Set.add
-  in
-  let memo =
-    Memo.create "package-map" ~doc:"Return a map assining package to files"
-      ~input:(module Super_context.As_memo_key)
-      ~visibility:Hidden
-      ~output:
-        (Allow_cutoff
-           (module struct
-             type t = Package.Id.Set.t Path.Build.Map.t
-
-             let to_dyn = Path.Build.Map.to_dyn Package.Id.Set.to_dyn
-
-             let equal = Path.Build.Map.equal ~equal:Package.Id.Set.equal
-           end))
-      f
-  in
-  fun sctx -> Memo.exec memo sctx

src/dune_rules/install_rules.mli

@@ -20,5 +20,3 @@ val meta_and_dune_package_rules :
    aalekseyev: actually I think we should just remove
    [meta_and_dune_package_rules] from the interface and have [gen_rules] do
    everything. *)
-
-val packages : Super_context.t -> Package.Id.Set.t Path.Build.Map.t Memo.Build.t

src/memo/memo.ml

@@ -32,6 +32,16 @@ module Build = struct
       match option with
       | None -> return ()
       | Some a -> f a
+
+    let map option ~f =
+      match option with
+      | None -> return None
+      | Some a -> f a >>| Option.some
+
+    let bind option ~f =
+      match option with
+      | None -> return None
+      | Some a -> f a
   end
 
   module Result = struct

src/memo/memo.mli

@@ -86,6 +86,10 @@ module Build : sig
 
   module Option : sig
     val iter : 'a option -> f:('a -> unit t) -> unit t
+
+    val map : 'a option -> f:('a -> 'b t) -> 'b option t
+
+    val bind : 'a option -> f:('a -> 'b option t) -> 'b option t
   end
 
   module Result : sig