Factor out targets into a separate module

Signed-off-by: Andrey Mokhov <[email protected]>

Author: snowleopard

bin/import.ml

@@ -25,6 +25,7 @@ module Colors = Dune_rules.Colors
 module Dune_project = Dune_engine.Dune_project
 module Workspace = Dune_rules.Workspace
 module Cached_digest = Dune_engine.Cached_digest
+module Targets = Dune_engine.Targets
 module Profile = Dune_rules.Profile
 module Log = Dune_util.Log
 module Dune_rpc = Dune_rpc_private

bin/print_rules.ml

@@ -38,7 +38,7 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) =
     "@[<hov 2>@{<makefile-stuff>%a:%t@}@]@,@<0>\t@{<makefile-action>%a@}@,@,"
     (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p ->
          Format.pp_print_string ppf (Path.to_string p)))
-    (List.map ~f:Path.build (Path.Build.Set.to_list rule.targets))
+    (Targets.to_list_map rule.targets ~file:Path.build)
     (fun ppf ->
       Path.Set.iter rule.expanded_deps ~f:(fun dep ->
           Format.fprintf ppf "@ %s" (Path.to_string dep)))
@@ -55,7 +55,7 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) =
          [ [ ("deps", Dep.Set.encode rule.deps)
            ; ( "targets"
              , paths
-                 (Path.Build.Set.to_list rule.targets
+                 (Targets.to_list_map rule.targets ~file:Fun.id
                  |> Path.set_of_build_paths_list) )
            ]
          ; (match rule.context with

src/dune_engine/action_builder.ml

@@ -131,44 +131,42 @@ let source_tree ~dir =
     }
 
 (* CR-someday amokhov: The set of targets is accumulated using information from
-   multiple sources by calling [Path.Build.Set.union] and hence occasionally
-   duplicate declarations of the very same target go unnoticed. I think such
-   redeclarations are not erroneous but are merely redundant; it seems that it
-   would be better to rule them out completely.
-
-   Another improvement is to cache [Path.Build.Set.to_list targets] which is
-   currently performed multiple times on the very same
-   [Action_builder.With_targets.t]. *)
+   multiple sources by calling [Targets.combine], which performs set union and
+   hence duplicate declarations of the very same target can go unnoticed. I
+   think such redeclarations are not erroneous but are merely redundant; perhaps
+   we should detect and disallow them. *)
 module With_targets = struct
   type nonrec 'a t =
     { build : 'a t
-    ; targets : Path.Build.Set.t
+    ; targets : Targets.t
     }
 
   let map_build t ~f = { t with build = f t.build }
 
-  let return x = { build = return x; targets = Path.Build.Set.empty }
+  let return x = { build = return x; targets = Targets.empty }
 
-  let add t ~targets =
+  let add t ~file_targets =
     { build = t.build
-    ; targets = Path.Build.Set.union t.targets (Path.Build.Set.of_list targets)
+    ; targets =
+        Targets.combine t.targets
+          (Targets.Files.create (Path.Build.Set.of_list file_targets))
     }
 
   let map { build; targets } ~f = { build = map build ~f; targets }
 
   let map2 x y ~f =
     { build = map2 x.build y.build ~f
-    ; targets = Path.Build.Set.union x.targets y.targets
+    ; targets = Targets.combine x.targets y.targets
     }
 
   let both x y =
     { build = both x.build y.build
-    ; targets = Path.Build.Set.union x.targets y.targets
+    ; targets = Targets.combine x.targets y.targets
     }
 
   let seq x y =
     { build = x.build >>> y.build
-    ; targets = Path.Build.Set.union x.targets y.targets
+    ; targets = Targets.combine x.targets y.targets
     }
 
   module O = struct
@@ -186,48 +184,53 @@ module With_targets = struct
     | [] -> return []
     | xs ->
       let build, targets =
-        List.fold_left xs ~init:([], Path.Build.Set.empty)
-          ~f:(fun (xs, set) x ->
-            (x.build :: xs, Path.Build.Set.union set x.targets))
+        List.fold_left xs ~init:([], Targets.empty)
+          ~f:(fun (builds, targets) x ->
+            (x.build :: builds, Targets.combine x.targets targets))
       in
       { build = all (List.rev build); targets }
 
   let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
-    add ~targets:[ fn ]
+    add ~file_targets:[ fn ]
       (let+ s = s in
        Action.Write_file (fn, perm, s))
 
   let memoize name t = { build = memoize name t.build; targets = t.targets }
 end
 
-let with_targets build ~targets : _ With_targets.t =
-  { build; targets = Path.Build.Set.of_list targets }
+let with_targets build ~targets : _ With_targets.t = { build; targets }
 
-let with_targets_set build ~targets : _ With_targets.t = { build; targets }
+let with_file_targets build ~file_targets : _ With_targets.t =
+  { build
+  ; targets = Targets.Files.create (Path.Build.Set.of_list file_targets)
+  }
 
 let with_no_targets build : _ With_targets.t =
-  { build; targets = Path.Build.Set.empty }
+  { build; targets = Targets.empty }
 
 let write_file ?(perm = Action.File_perm.Normal) fn s =
-  with_targets ~targets:[ fn ] (return (Action.Write_file (fn, perm, s)))
+  with_file_targets ~file_targets:[ fn ]
+    (return (Action.Write_file (fn, perm, s)))
 
 let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
-  with_targets ~targets:[ fn ]
+  with_file_targets ~file_targets:[ fn ]
     (let+ s = s in
      Action.Write_file (fn, perm, s))
 
 let copy ~src ~dst =
-  with_targets ~targets:[ dst ] (path src >>> return (Action.Copy (src, dst)))
+  with_file_targets ~file_targets:[ dst ]
+    (path src >>> return (Action.Copy (src, dst)))
 
 let copy_and_add_line_directive ~src ~dst =
-  with_targets ~targets:[ dst ]
+  with_file_targets ~file_targets:[ dst ]
     (path src >>> return (Action.Copy_and_add_line_directive (src, dst)))
 
 let symlink ~src ~dst =
-  with_targets ~targets:[ dst ] (path src >>> return (Action.Symlink (src, dst)))
+  with_file_targets ~file_targets:[ dst ]
+    (path src >>> return (Action.Symlink (src, dst)))
 
 let create_file ?(perm = Action.File_perm.Normal) fn =
-  with_targets ~targets:[ fn ]
+  with_file_targets ~file_targets:[ fn ]
     (return (Action.Redirect_out (Stdout, fn, perm, Action.empty)))
 
 let progn ts =

src/dune_engine/action_builder.mli

@@ -10,14 +10,14 @@ module With_targets : sig
 
   type nonrec 'a t =
     { build : 'a t
-    ; targets : Path.Build.Set.t
+    ; targets : Targets.t
     }
 
   val map_build : 'a t -> f:('a build -> 'b build) -> 'b t
 
   val return : 'a -> 'a t
 
-  val add : 'a t -> targets:Path.Build.t list -> 'a t
+  val add : 'a t -> file_targets:Path.Build.t list -> 'a t
 
   val map : 'a t -> f:('a -> 'b) -> 'b t
 
@@ -42,12 +42,13 @@ module With_targets : sig
 end
 with type 'a build := 'a t
 
-(** Add a set of targets to an action builder, turning a target-less
-    [Action_builder.t] into [Action_builder.With_targets.t]. *)
-val with_targets : 'a t -> targets:Path.Build.t list -> 'a With_targets.t
+(** Add targets to an action builder, turning a target-less [Action_builder.t]
+    into [Action_builder.With_targets.t]. *)
+val with_targets : 'a t -> targets:Targets.t -> 'a With_targets.t
 
-(** [with_targets_set] is like [with_targets] but [targets] is a set *)
-val with_targets_set : 'a t -> targets:Path.Build.Set.t -> 'a With_targets.t
+(** Like [with_targets] but specifies a list of file targets. *)
+val with_file_targets :
+  'a t -> file_targets:Path.Build.t list -> 'a With_targets.t
 
 (** Create a value of [With_targets.t] with the empty set of targets. *)
 val with_no_targets : 'a t -> 'a With_targets.t

src/dune_engine/action_exec.ml

@@ -71,7 +71,7 @@ type done_or_more_deps =
   | Need_more_deps of (DAP.Dependency.Set.t * Dynamic_dep.Set.t)
 
 type exec_context =
-  { targets : Path.Build.Set.t
+  { targets : Targets.t
   ; context : Build_context.t option
   ; purpose : Process.purpose
   ; rule_loc : Loc.t
@@ -127,8 +127,7 @@ let exec_run_dynamic_client ~ectx ~eenv prog args =
       let to_relative path =
         path |> Stdune.Path.build |> Stdune.Path.reach ~from:eenv.working_dir
       in
-      Stdune.Path.Build.Set.to_list ectx.targets
-      |> String.Set.of_list_map ~f:to_relative
+      Targets.to_list_map ectx.targets ~file:to_relative |> String.Set.of_list
     in
     DAP.Run_arguments.
       { prepared_dependencies = eenv.prepared_dependencies; targets }

src/dune_engine/action_exec.mli

@@ -30,7 +30,7 @@ end
 (** [root] should be the root of the current build context, or the root of the
     sandbox if the action is sandboxed. *)
 val exec :
-     targets:Path.Build.Set.t
+     targets:Targets.t
   -> root:Path.t
   -> context:Build_context.t option
   -> env:Env.t

src/dune_engine/build_system.ml

@@ -520,7 +520,8 @@ let () =
       Path.Build.Set.iter fns ~f:(fun p -> Path.unlink_no_err (Path.build p)))
 
 let compute_target_digests targets =
-  Option.List.traverse (Path.Build.Set.to_list targets) ~f:(fun target ->
+  Option.List.traverse (Targets.to_list_map targets ~file:Fun.id)
+    ~f:(fun target ->
       Cached_digest.build_file target
       |> Cached_digest.Digest_result.to_option
       |> Option.map ~f:(fun digest -> (target, digest)))
@@ -535,15 +536,15 @@ let compute_target_digests_or_raise_error exec_params ~loc targets =
     (* FIXME: searching the dune version for each single target seems way
        suboptimal. This information could probably be stored in rules
        directly. *)
-    if Path.Build.Set.is_empty targets then
+    if Targets.is_empty targets then
       false
     else
       Execution_parameters.should_remove_write_permissions_on_generated_files
         exec_params
   in
   let good, missing, errors =
-    Path.Build.Set.fold targets ~init:([], [], [])
-      ~f:(fun target (good, missing, errors) ->
+    Targets.fold targets ~init:([], [], [])
+      ~file:(fun target (good, missing, errors) ->
         let expected_syscall_path = Path.to_string (Path.build target) in
         match Cached_digest.refresh ~remove_write_permissions target with
         | Ok digest -> ((target, digest) :: good, missing, errors)
@@ -773,13 +774,13 @@ end = struct
            we try to sandbox this. *)
           ~sandbox:Sandbox_config.no_sandboxing ~context:None
           ~info:(Source_file_copy path)
-          ~targets:(Path.Build.Set.singleton ctx_path)
+          ~targets:(Targets.File.create ctx_path)
           build)
 
   let compile_rules ~dir ~source_dirs rules =
     List.concat_map rules ~f:(fun rule ->
         assert (Path.Build.( = ) dir rule.Rule.dir);
-        Path.Build.Set.to_list_map rule.targets ~f:(fun target ->
+        Targets.to_list_map rule.targets ~file:(fun target ->
             if String.Set.mem source_dirs (Path.Build.basename target) then
               report_rule_src_dir_conflict dir target rule
             else
@@ -851,8 +852,9 @@ end = struct
             (* All targets are in [dir] and we know it correspond to a directory
                of a build context since there are source files to copy, so this
                call can't fail. *)
-            Path.Build.Set.to_list rule.targets
-            |> Path.Source.Set.of_list_map ~f:Path.Build.drop_build_context_exn
+            Targets.to_list_map rule.targets
+              ~file:Path.Build.drop_build_context_exn
+            |> Path.Source.Set.of_list
           in
           if Path.Source.Set.is_subset source_files_for_targets ~of_:to_copy
           then
@@ -1020,10 +1022,10 @@ end = struct
           match mode with
           | Promote { only = None; _ }
           | Ignore_source_files ->
-            Path.Build.Set.union targets acc_ignored
+            Path.Build.Set.union (Targets.files targets) acc_ignored
           | Promote { only = Some pred; _ } ->
             let to_ignore =
-              Path.Build.Set.filter targets ~f:(fun target ->
+              Path.Build.Set.filter (Targets.files targets) ~f:(fun target ->
                   Predicate_lang.Glob.exec pred
                     (Path.reach (Path.build target) ~from:(Path.build dir))
                     ~standard:Predicate_lang.any)
@@ -1361,7 +1363,7 @@ end = struct
     let trace =
       ( rule_digest_version (* Update when changing the rule digest scheme. *)
       , Dep.Facts.digest deps ~sandbox_mode ~env
-      , Path.Build.Set.to_list_map rule.targets ~f:Path.Build.to_string
+      , Targets.to_list_map rule.targets ~file:Path.Build.to_string
       , Option.map rule.context ~f:(fun c -> Context_name.to_string c.name)
       , Action.for_shell action
       , can_go_in_shared_cache
@@ -1430,7 +1432,8 @@ end = struct
     let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } =
       action
     in
-    pending_targets := Path.Build.Set.union targets !pending_targets;
+    let file_targets = Targets.files targets in
+    pending_targets := Path.Build.Set.union file_targets !pending_targets;
     let chdirs = Action.chdirs action in
     let sandbox =
       Option.map sandbox_mode ~f:(fun mode ->
@@ -1473,7 +1476,7 @@ end = struct
     in
     Option.iter sandbox ~f:Sandbox.destroy;
     (* All went well, these targets are no longer pending *)
-    pending_targets := Path.Build.Set.diff !pending_targets targets;
+    pending_targets := Path.Build.Set.diff !pending_targets file_targets;
     exec_result
 
   let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~targets =
@@ -1494,7 +1497,7 @@ end = struct
           Cached_digest.set target digest)
     in
     match
-      Path.Build.Set.to_list_map targets ~f:Dune_cache.Local.Target.create
+      Targets.to_list_map targets ~file:Dune_cache.Local.Target.create
       |> Option.List.all
     with
     | None -> Fiber.return None
@@ -1590,7 +1593,7 @@ end = struct
       rule
     in
     start_rule t rule;
-    let head_target = Path.Build.Set.choose_exn targets in
+    let head_target = Targets.head_exn targets in
     let* execution_parameters =
       match Dpath.Target_dir.of_target dir with
       | Regular (With_context (_, dir))
@@ -1745,7 +1748,7 @@ end = struct
               ~cache_debug_flags:t.cache_debug_flags ~head_target miss_reason;
             (* Step I. Remove stale targets both from the digest table and from
                the build directory. *)
-            Path.Build.Set.iter targets ~f:(fun target ->
+            Targets.iter targets ~file:(fun target ->
                 Cached_digest.remove target;
                 Path.Build.unlink_no_err target);
             (* Step II. Try to restore artifacts from the shared cache if the
@@ -1855,20 +1858,22 @@ end = struct
           | Promote { lifetime; into; only }, (Some Automatically | None) ->
             Fiber.parallel_iter_set
               (module Path.Build.Set)
-              targets
-              ~f:(fun path ->
+              (Targets.files targets)
+              ~f:(fun target ->
                 let consider_for_promotion =
                   match only with
                   | None -> true
                   | Some pred ->
                     Predicate_lang.Glob.exec pred
-                      (Path.reach (Path.build path) ~from:(Path.build dir))
+                      (Path.reach (Path.build target) ~from:(Path.build dir))
                       ~standard:Predicate_lang.any
                 in
                 match consider_for_promotion with
                 | false -> Fiber.return ()
                 | true ->
-                  let in_source_tree = Path.Build.drop_build_context_exn path in
+                  let in_source_tree =
+                    Path.Build.drop_build_context_exn target
+                  in
                   let in_source_tree =
                     match into with
                     | None -> in_source_tree
@@ -1910,7 +1915,7 @@ end = struct
                       | None -> false
                       | Some in_source_tree_digest -> (
                         match
-                          Cached_digest.build_file path
+                          Cached_digest.build_file target
                           |> Cached_digest.Digest_result.to_option
                         with
                         | None ->
@@ -1935,7 +1940,7 @@ end = struct
                        explicitly set the user writable bit. *)
                     let chmod n = n lor 0o200 in
                     Path.unlink_no_err (Path.source dst);
-                    t.promote_source ~src:path ~dst ~chmod context
+                    t.promote_source ~src:target ~dst ~chmod context
                   ))
         in
         t.rule_done <- t.rule_done + 1;
@@ -2005,7 +2010,7 @@ end = struct
           (match loc with
           | Some loc -> From_dune_file loc
           | None -> Internal)
-        ~targets:(Path.Build.Set.singleton target)
+        ~targets:(Targets.File.create target)
         (Action_builder.of_thunk
            { f =
                (fun mode ->