Factor out targets into a separate module (#5048)

A refactoring in preparation of #5025. 

* Create a new module [Targets] for representing rule targets. For now, it only
  represents file targets but the interface is designed to extend the module to
  support directory targets too. For example, various function arguments are
  called [~file] instead of more usual [~f] because directory targets will
  require a new argument [~dir].

* Rename [Dune_rules.Targets] to [Dune_rules.Targets_spec] to avoid confusion.

The only slight change of behaviour is around pretty printing of targets in an
error message in [rule.ml]: it used to simply turn paths into a string but the
new [Targets.pp] uses [Dpath.describe_target] as in other places where we pretty
print targets.


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