Add support for directory targets

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

bin/exec.ml

@@ -72,10 +72,12 @@ let term =
       let not_found () =
         let open Memo.Build.O in
         let+ hints =
+          (* CR-someday amokhov: Currently we do not provide hints for directory
+             targets but it would be nice to do that. *)
           (* Good candidates for the "./x.exe" instead of "x.exe" error are
              executables present in the current directory *)
           let+ candidates =
-            Build_system.targets_of ~dir:(Path.build dir)
+            Build_system.file_targets_of ~dir:(Path.build dir)
             >>| Path.Set.to_list
             >>| List.filter ~f:(fun p -> Path.extension p = ".exe")
             >>| List.map ~f:(fun p -> "./" ^ Path.basename p)

bin/print_rules.ml

@@ -34,11 +34,16 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) =
       ; Action.for_shell rule.action
       ]
   in
+  (* Makefiles seem to allow directory targets, so we include them. *)
+  let targets =
+    Dune_engine.Targets.map rule.targets ~f:(fun ~files ~dirs ->
+        Path.Build.Set.union files dirs)
+  in
   Format.fprintf ppf
     "@[<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))
+    (List.map ~f:Path.build (Path.Build.Set.to_list targets))
     (fun ppf ->
       Path.Set.iter rule.expanded_deps ~f:(fun dep ->
           Format.fprintf ppf "@ %s" (Path.to_string dep)))
@@ -49,14 +54,22 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) =
     Action.for_shell action |> Action.For_shell.encode
   in
   let paths ps = Dune_lang.Encoder.list Dpath.encode (Path.Set.to_list ps) in
+  let file_targets, dir_targets =
+    Dune_engine.Targets.map rule.targets ~f:(fun ~files ~dirs -> (files, dirs))
+  in
+  let targets =
+    Path.Build.Set.union file_targets
+      (Path.Build.Set.map dir_targets ~f:(fun target ->
+           Path.Build.relative target "*"))
+  in
   let sexp =
     Dune_lang.Encoder.record
       (List.concat
          [ [ ("deps", Dep.Set.encode rule.deps)
            ; ( "targets"
              , paths
-                 (Path.Build.Set.to_list rule.targets
-                 |> Path.set_of_build_paths_list) )
+                 (Path.Build.Set.to_list targets |> Path.set_of_build_paths_list)
+             )
            ]
          ; (match rule.context with
            | None -> []

otherlibs/stdune-unstable/user_error.ml

@@ -40,6 +40,12 @@ module Annot = struct
 
     let to_dyn = Unit.to_dyn
   end)
+
+  module Needs_stack_trace = Make (struct
+    type payload = unit
+
+    let to_dyn = Unit.to_dyn
+  end)
 end
 
 exception E of User_message.t * Annot.t list
@@ -62,6 +68,10 @@ let has_embed_location annots =
   List.exists annots ~f:(fun annot ->
       Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false))
 
+let has_needs_stack_trace annots =
+  List.exists annots ~f:(fun annot ->
+      Annot.Needs_stack_trace.check annot (fun () -> true) (fun () -> false))
+
 let has_location (msg : User_message.t) annots =
   (not (is_loc_none msg.loc)) || has_embed_location annots
 

otherlibs/stdune-unstable/user_error.mli

@@ -19,6 +19,9 @@ module Annot : sig
 
   (** The message has a location embed in the text. *)
   module Has_embedded_location : S with type payload = unit
+
+  (** The message needs a stack trace for clarity. *)
+  module Needs_stack_trace : S with type payload = unit
 end
 
 (** User errors are errors that users need to fix themselves in order to make
@@ -52,6 +55,8 @@ val prefix : User_message.Style.t Pp.t
     text. *)
 val has_location : User_message.t -> Annot.t list -> bool
 
-(** Returns [true] if the following list of annotations contains
-    [Annot.Has_embedded_location]. *)
+(** Returns [true] if the list contains [Annot.Has_embedded_location]. *)
 val has_embed_location : Annot.t list -> bool
+
+(** Returns [true] if the list contains [Annot.Needs_stack_trace]. *)
+val has_needs_stack_trace : Annot.t list -> bool

src/dune_engine/action_builder.ml

@@ -142,33 +142,35 @@ let source_tree ~dir =
 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 =
     { 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 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,9 +188,9 @@ 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 (acc_build, acc_targets) x ->
+            (x.build :: acc_build, Targets.combine acc_targets x.targets))
       in
       { build = all (List.rev build); targets }
 
@@ -200,34 +202,36 @@ module With_targets = struct
   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 ~targets : _ With_targets.t =
+  { build; targets = Targets.Files.create (Path.Build.Set.of_list 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 ~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 ~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 ~targets:[ dst ]
+    (path src >>> return (Action.Copy (src, dst)))
 
 let copy_and_add_line_directive ~src ~dst =
-  with_targets ~targets:[ dst ]
+  with_file_targets ~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 ~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 ~targets:[ fn ]
     (return (Action.Redirect_out (Stdout, fn, perm, Action.empty)))
 
 let progn ts =

src/dune_engine/action_builder.mli

@@ -10,7 +10,7 @@ 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
@@ -42,12 +42,12 @@ 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 only file targets (and as a list). *)
+val with_file_targets : 'a t -> 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,15 @@ 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
+      let file_targets, (_dir_targets_not_allowed : Nothing.t list) =
+        Targets.to_list_map ectx.targets ~file:to_relative
+          ~dir:(fun _dir_target ->
+            User_error.raise ~loc:ectx.rule_loc
+              [ Pp.text
+                  "Directory targets are not compatible with dynamic actions"
+              ])
+      in
+      String.Set.of_list file_targets
     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