From adbbc2a545238aaa14164abd5e2d389d5439687a Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Sat, 23 Oct 2021 10:40:12 +0100 Subject: [PATCH] Add support for directory targets Signed-off-by: Andrey Mokhov --- bin/exec.ml | 4 +- bin/print_rules.ml | 19 +- otherlibs/stdune-unstable/user_error.ml | 6 +- src/dune_engine/action_builder.ml | 4 +- src/dune_engine/action_exec.ml | 10 +- src/dune_engine/build_system.ml | 431 +++++++++++++----- src/dune_engine/build_system.mli | 4 +- src/dune_engine/process.ml | 6 +- src/dune_engine/rule.ml | 60 +-- src/dune_engine/rule.mli | 1 + src/dune_engine/sandbox.ml | 54 ++- src/dune_engine/sandbox.mli | 5 +- src/dune_engine/string_with_vars.ml | 8 + src/dune_engine/string_with_vars.mli | 3 + src/dune_engine/targets.ml | 64 ++- src/dune_engine/targets.mli | 32 +- src/dune_rules/action_unexpanded.ml | 38 +- src/dune_rules/action_unexpanded.mli | 2 +- src/dune_rules/dir_contents.ml | 8 +- src/dune_rules/dune_file.ml | 20 + src/dune_rules/simple_rules.ml | 30 +- src/dune_rules/targets_spec.ml | 22 + src/dune_rules/targets_spec.mli | 17 +- .../test-cases/directory-targets.t/run.t | 317 +++++++++++++ 24 files changed, 939 insertions(+), 226 deletions(-) create mode 100644 test/blackbox-tests/test-cases/directory-targets.t/run.t diff --git a/bin/exec.ml b/bin/exec.ml index 0737e48a9065..d96a5cef0e8c 100644 --- a/bin/exec.ml +++ b/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) diff --git a/bin/print_rules.ml b/bin/print_rules.ml index 9d3a60144d23..5e9482ee3b72 100644 --- a/bin/print_rules.ml +++ b/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 "@[@{%a:%t@}@]@,@<0>\t@{%a@}@,@," (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p -> Format.pp_print_string ppf (Path.to_string p))) - (Targets.to_list_map rule.targets ~file:Path.build) + (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 - (Targets.to_list_map rule.targets ~file:Fun.id - |> Path.set_of_build_paths_list) ) + (Path.Build.Set.to_list targets |> Path.set_of_build_paths_list) + ) ] ; (match rule.context with | None -> [] diff --git a/otherlibs/stdune-unstable/user_error.ml b/otherlibs/stdune-unstable/user_error.ml index 09b11c1bc226..d287f9f5a5f3 100644 --- a/otherlibs/stdune-unstable/user_error.ml +++ b/otherlibs/stdune-unstable/user_error.ml @@ -68,13 +68,13 @@ let has_embedded_location annots = List.exists annots ~f:(fun annot -> Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false)) -let has_location (msg : User_message.t) annots = - (not (is_loc_none msg.loc)) || has_embedded_location annots - let 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_embedded_location annots + let () = Printexc.register_printer (function | E (t, []) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t)) diff --git a/src/dune_engine/action_builder.ml b/src/dune_engine/action_builder.ml index a67eb90878de..fb0704daafbb 100644 --- a/src/dune_engine/action_builder.ml +++ b/src/dune_engine/action_builder.ml @@ -185,8 +185,8 @@ module With_targets = struct | xs -> let build, targets = List.fold_left xs ~init:([], Targets.empty) - ~f:(fun (builds, targets) x -> - (x.build :: builds, Targets.combine x.targets targets)) + ~f:(fun (acc_build, acc_targets) x -> + (x.build :: acc_build, Targets.combine acc_targets x.targets)) in { build = all (List.rev build); targets } diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 47a0ff02653f..22c2b2972655 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -127,7 +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 - Targets.to_list_map ectx.targets ~file:to_relative |> String.Set.of_list + 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 } diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 65a66c782231..d07e7c1280f0 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -119,10 +119,20 @@ end let files_in_source_tree_to_delete () = Promoted_to_delete.get_db () module Loaded = struct + type rules_here = + { by_file_targets : Rule.t Path.Build.Map.t + ; by_directory_targets : Rule.t Path.Build.Map.t + } + + let no_rules_here = + { by_file_targets = Path.Build.Map.empty + ; by_directory_targets = Path.Build.Map.empty + } + type build = { allowed_subdirs : Path.Unspecified.w Dir_set.t ; rules_produced : Rules.t - ; rules_here : Rule.t Path.Build.Map.t + ; rules_here : rules_here ; aliases : (Loc.t * Rules.Dir_rules.Alias_spec.item) list Alias.Name.Map.t } @@ -134,7 +144,7 @@ module Loaded = struct Build { allowed_subdirs ; rules_produced = Rules.empty - ; rules_here = Path.Build.Map.empty + ; rules_here = no_rules_here ; aliases = Alias.Name.Map.empty } end @@ -507,6 +517,8 @@ let report_rule_conflict fn (rule' : Rule.t) (rule : Rule.t) = ] | _ -> []) +(* CR-someday amokhov: Clean up pending directory targets too? *) + (* This contains the targets of the actions that are being executed. On exit, we need to delete them as they might contain garbage. *) let pending_targets = ref Path.Build.Set.empty @@ -520,13 +532,15 @@ let () = Path.Build.Set.iter fns ~f:(fun p -> Path.unlink_no_err (Path.build p))) let compute_target_digests targets = - Option.List.traverse (Targets.to_list_map targets ~file:Fun.id) - ~f:(fun target -> + let file_targets, (_ignored_dir_targets : unit list) = + Targets.to_list_map targets ~file:Fun.id ~dir:ignore + in + Option.List.traverse file_targets ~f:(fun target -> Cached_digest.build_file target |> Cached_digest.Digest_result.to_option |> Option.map ~f:(fun digest -> (target, digest))) -let compute_target_digests_or_raise_error exec_params ~loc targets = +let compute_target_digests_or_raise_error exec_params ~loc file_targets = let remove_write_permissions = (* Remove write permissions on targets. A first theoretical reason is that the build process should be a computational graph and targets should not @@ -536,57 +550,58 @@ 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 Targets.is_empty targets then + if Path.Build.Set.is_empty file_targets then false else Execution_parameters.should_remove_write_permissions_on_generated_files exec_params in let 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) - | No_such_file -> (good, target :: missing, errors) - | Broken_symlink -> - let error = [ Pp.verbatim "Broken symlink" ] in - (good, missing, (target, error) :: errors) - | Unexpected_kind file_kind -> - let error = + let process_target 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) + | No_such_file -> (good, target :: missing, errors) + | Broken_symlink -> + let error = [ Pp.verbatim "Broken symlink" ] in + (good, missing, (target, error) :: errors) + | Unexpected_kind file_kind -> + let error = + [ Pp.verbatim + (sprintf "Unexpected file kind %S (%s)" + (File_kind.to_string file_kind) + (File_kind.to_string_hum file_kind)) + ] + in + (good, missing, (target, error) :: errors) + | Unix_error (error, syscall, path) -> + let error = + [ (if String.equal expected_syscall_path path then + Pp.verbatim syscall + else + Pp.concat + [ Pp.verbatim syscall + ; Pp.verbatim " " + ; Pp.verbatim (String.maybe_quoted path) + ]) + ; Pp.text (Unix.error_message error) + ] + in + (good, missing, (target, error) :: errors) + | Error exn -> + let error = + match exn with + | Sys_error msg -> [ Pp.verbatim - (sprintf "Unexpected file kind %S (%s)" - (File_kind.to_string file_kind) - (File_kind.to_string_hum file_kind)) + (String.drop_prefix_if_exists + ~prefix:(expected_syscall_path ^ ": ") + msg) ] - in - (good, missing, (target, error) :: errors) - | Unix_error (error, syscall, path) -> - let error = - [ (if String.equal expected_syscall_path path then - Pp.verbatim syscall - else - Pp.concat - [ Pp.verbatim syscall - ; Pp.verbatim " " - ; Pp.verbatim (String.maybe_quoted path) - ]) - ; Pp.text (Unix.error_message error) - ] - in - (good, missing, (target, error) :: errors) - | Error exn -> - let error = - match exn with - | Sys_error msg -> - [ Pp.verbatim - (String.drop_prefix_if_exists - ~prefix:(expected_syscall_path ^ ": ") - msg) - ] - | exn -> [ Pp.verbatim (Printexc.to_string exn) ] - in - (good, missing, (target, error) :: errors)) + | exn -> [ Pp.verbatim (Printexc.to_string exn) ] + in + (good, missing, (target, error) :: errors) + in + Path.Build.Set.fold file_targets ~init:([], [], []) ~f:process_target in match (missing, errors) with | [], [] -> List.rev good @@ -623,7 +638,10 @@ let remove_old_artifacts ~dir ~rules_here ~(subdirs_to_keep : Subdir_set.t) = | Ok files -> List.iter files ~f:(fun (fn, kind) -> let path = Path.Build.relative dir fn in - let path_is_a_target = Path.Build.Map.mem rules_here path in + let path_is_a_target = + (* CR-someday amokhov: Also check directory targets. *) + Path.Build.Map.mem rules_here.Loaded.by_file_targets path + in if not path_is_a_target then match kind with | Unix.S_DIR -> ( @@ -742,7 +760,9 @@ module rec Load_rules : sig val file_exists : Path.t -> bool Memo.Build.t - val targets_of : dir:Path.t -> Path.Set.t Memo.Build.t + val file_targets_of : dir:Path.t -> Path.Set.t Memo.Build.t + + val directory_targets_of : dir:Path.t -> Path.Set.t Memo.Build.t val lookup_alias : Alias.t @@ -778,14 +798,29 @@ end = struct build) let compile_rules ~dir ~source_dirs rules = - List.concat_map rules ~f:(fun rule -> - assert (Path.Build.( = ) dir rule.Rule.dir); - 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 - (target, rule))) - |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + let file_targets, directory_targets = + List.map rules ~f:(fun rule -> + assert (Path.Build.( = ) dir rule.Rule.dir); + 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 + (target, rule)) + ~dir:(fun target -> (target, rule))) + |> List.unzip + in + (* CR-someday amokhov: Report rule conflicts for all targets rather than + doing it separately for files and directories. *) + let by_file_targets = + List.concat file_targets + |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + in + let by_directory_targets = + List.concat directory_targets + |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + in + { Loaded.by_file_targets; by_directory_targets } (* Here we are doing a O(log |S|) lookup in a set S of files in the build directory [dir]. We could memoize these lookups, but it doesn't seem to be @@ -801,13 +836,28 @@ end = struct | Build { rules_here; _ } -> ( match Path.as_in_build_dir fn with | None -> false - | Some fn -> Path.Build.Map.mem rules_here fn) + | Some fn -> ( + match Path.Build.Map.mem rules_here.by_file_targets fn with + | true -> true + | false -> ( + match Path.Build.parent fn with + | None -> false + | Some dir -> Path.Build.Map.mem rules_here.by_directory_targets dir)) + ) + + let file_targets_of ~dir = + load_dir ~dir >>| function + | Non_build file_targets -> file_targets + | Build { rules_here; _ } -> + Path.Build.Map.keys rules_here.by_file_targets + |> Path.Set.of_list_map ~f:Path.build - let targets_of ~dir = + let directory_targets_of ~dir = load_dir ~dir >>| function - | Non_build targets -> targets + | Non_build _file_targets -> Path.Set.empty | Build { rules_here; _ } -> - Path.Build.Map.keys rules_here |> Path.Set.of_list_map ~f:Path.build + Path.Build.Map.keys rules_here.by_directory_targets + |> Path.Set.of_list_map ~f:Path.build let lookup_alias alias = load_dir ~dir:(Path.build (Alias.dir alias)) >>| function @@ -852,9 +902,14 @@ 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. *) - Targets.to_list_map rule.targets - ~file:Path.Build.drop_build_context_exn - |> Path.Source.Set.of_list + let file_targets, (_dir_targets_not_allowed : Nothing.t list) = + Targets.to_list_map rule.targets + ~file:Path.Build.drop_build_context_exn ~dir:(fun dir -> + Code_error.raise + "Unexpected directory target in a Fallback rule" + [ ("dir", Dyn.String (Path.Build.to_string dir)) ]) + in + Path.Source.Set.of_list file_targets in if Path.Source.Set.is_subset source_files_for_targets ~of_:to_copy then @@ -1018,20 +1073,38 @@ end = struct copied *) let source_files_to_ignore = List.fold_left rules ~init:Path.Build.Set.empty - ~f:(fun acc_ignored { Rule.targets; mode; _ } -> + ~f:(fun acc_ignored { Rule.targets; mode; loc; _ } -> + (* CR-someday amokhov: Remove this limitation. *) + let directory_targets_not_supported ~dirs = + if not (Path.Build.Set.is_empty dirs) then + User_error.raise ~loc + [ Pp.text "Directory targets are not supported for this mode" ] + in match mode with | Promote { only = None; _ } | Ignore_source_files -> - Path.Build.Set.union (Targets.files targets) acc_ignored + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + directory_targets_not_supported ~dirs; + files) + in + Path.Build.Set.union file_targets acc_ignored | Promote { only = Some pred; _ } -> + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + directory_targets_not_supported ~dirs; + files) + in let to_ignore = - Path.Build.Set.filter (Targets.files targets) ~f:(fun target -> + Path.Build.Set.filter file_targets ~f:(fun target -> Predicate_lang.Glob.exec pred (Path.reach (Path.build target) ~from:(Path.build dir)) ~standard:Predicate_lang.any) in Path.Build.Set.union to_ignore acc_ignored - | _ -> acc_ignored) + | Standard + | Fallback -> + acc_ignored) in let source_files_to_ignore = Path.Build.Set.to_list source_files_to_ignore @@ -1159,32 +1232,52 @@ open Load_rules let load_dir_and_get_buildable_targets ~dir = load_dir ~dir >>| function - | Non_build _ -> Path.Build.Map.empty + | Non_build _ -> Loaded.no_rules_here | Build { rules_here; _ } -> rules_here -let get_rule fn = - match Path.as_in_build_dir fn with - | None -> Memo.Build.return None - | Some fn -> ( - let dir = Path.Build.parent_exn fn in - load_dir ~dir:(Path.build dir) >>| function - | Non_build _ -> assert false - | Build { rules_here; _ } -> Path.Build.Map.find rules_here fn) - type rule_or_source = | Source of Digest.t | Rule of Path.Build.t * Rule.t +let get_rule_for_directory_target path = + let rec loop dir = + match Path.Build.parent dir with + | None -> Memo.Build.return None + | Some parent_dir -> ( + let* rules = + load_dir_and_get_buildable_targets ~dir:(Path.build parent_dir) + in + match Path.Build.Map.find rules.by_directory_targets dir with + | None -> loop parent_dir + | Some _ as rule -> Memo.Build.return rule) + in + loop path + +let get_rule path = + match Path.as_in_build_dir path with + | None -> Memo.Build.return None + | Some path -> ( + let dir = Path.Build.parent_exn path in + load_dir ~dir:(Path.build dir) >>= function + | Non_build _ -> assert false + | Build { rules_here; _ } -> ( + match Path.Build.Map.find rules_here.by_file_targets path with + | Some _ as rule -> Memo.Build.return rule + | None -> get_rule_for_directory_target path)) + let get_rule_or_source t path = let dir = Path.parent_exn path in if Path.is_strict_descendant_of_build_dir dir then let* rules = load_dir_and_get_buildable_targets ~dir in let path = Path.as_in_build_dir_exn path in - match Path.Build.Map.find rules path with + match Path.Build.Map.find rules.by_file_targets path with | Some rule -> Memo.Build.return (Rule (path, rule)) - | None -> - let* loc = Rule_fn.loc () in - no_rule_found t ~loc path + | None -> ( + get_rule_for_directory_target path >>= function + | Some rule -> Memo.Build.return (Rule (path, rule)) + | None -> + let* loc = Rule_fn.loc () in + no_rule_found t ~loc path) else let+ d = source_file_digest path in Source d @@ -1206,7 +1299,9 @@ let all_targets t = >>| function | Non_build _ -> Path.Build.Set.empty | Build { rules_here; _ } -> - Path.Build.Set.of_list (Path.Build.Map.keys rules_here))) + Path.Build.Set.of_list + (Path.Build.Map.keys rules_here.by_file_targets + @ Path.Build.Map.keys rules_here.by_directory_targets))) >>| Path.Build.Set.union_all let get_alias_definition alias = @@ -1252,6 +1347,23 @@ module type Rec = sig end end +let is_target file = + let parent_dir = Path.parent_exn file in + let* file_targets = file_targets_of ~dir:parent_dir in + match Path.Set.mem file_targets file with + | true -> Memo.Build.return true + | false -> + let rec loop dir = + match Path.parent dir with + | None -> Memo.Build.return false + | Some parent_dir -> ( + let* directory_targets = directory_targets_of ~dir:parent_dir in + match Path.Set.mem directory_targets dir with + | true -> Memo.Build.return true + | false -> loop parent_dir) + in + loop file + (* Separation between [Used_recursively] and [Exported] is necessary because at least one module in the recursive module group must be pure (i.e. only expose functions). *) @@ -1360,10 +1472,14 @@ end = struct let compute_rule_digest (rule : Rule.t) ~deps ~action ~sandbox_mode ~execution_parameters = let { Action.Full.action; env; locks; can_go_in_shared_cache } = action in + let file_targets, dir_targets = + Targets.to_list_map rule.targets ~file:Path.Build.to_string + ~dir:Path.Build.to_string + in let trace = ( rule_digest_version (* Update when changing the rule digest scheme. *) , Dep.Facts.digest deps ~sandbox_mode ~env - , Targets.to_list_map rule.targets ~file:Path.Build.to_string + , file_targets @ dir_targets , Option.map rule.context ~f:(fun c -> Context_name.to_string c.name) , Action.for_shell action , can_go_in_shared_cache @@ -1425,14 +1541,24 @@ end = struct | Not_found_in_cache -> Miss Not_found_in_cache | Error exn -> Miss (Error (Printexc.to_string exn)) + module Exec_result = struct + type t = + { paths_in_directory_targets : Path.Build.Set.t + ; action_exec_result : Action_exec.Exec_result.t + } + end + let execute_action_for_rule t ~rule_digest ~action ~deps ~loc ~(context : Build_context.t option) ~execution_parameters ~sandbox_mode ~dir ~targets = let open Fiber.O in + let file_targets, has_directory_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + (files, not (Path.Build.Set.is_empty dirs))) + in let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } = action in - 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 = @@ -1444,7 +1570,11 @@ end = struct in let action = match sandbox with - | None -> action + | None -> + if has_directory_targets then + User_error.raise ~loc + [ Pp.text "Rules with directory targets must be sandboxed" ]; + action | Some sandbox -> Action.sandbox action sandbox in let* () = @@ -1467,19 +1597,24 @@ end = struct in let+ exec_result = with_locks t locks ~f:(fun () -> - let+ exec_result = + let+ action_exec_result = Action_exec.exec ~root ~context ~env ~targets ~rule_loc:loc ~build_deps ~execution_parameters action in - Option.iter sandbox ~f:(Sandbox.move_targets_to_build_dir ~targets); - exec_result) + let paths_in_directory_targets = + match sandbox with + | None -> Path.Build.Set.empty + | Some sandbox -> + Sandbox.move_targets_to_build_dir sandbox ~loc ~targets + in + { Exec_result.paths_in_directory_targets; action_exec_result }) in Option.iter sandbox ~f:Sandbox.destroy; (* All went well, these targets are no longer pending *) pending_targets := Path.Build.Set.diff !pending_targets file_targets; exec_result - let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~targets = + let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~file_targets = let open Fiber.O in let hex = Digest.to_string rule_digest in let pp_error msg = @@ -1497,7 +1632,7 @@ end = struct Cached_digest.set target digest) in match - Targets.to_list_map targets ~file:Dune_cache.Local.Target.create + Path.Build.Set.to_list_map file_targets ~f:Dune_cache.Local.Target.create |> Option.List.all with | None -> Fiber.return None @@ -1748,7 +1883,13 @@ 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. *) - Targets.iter targets ~file:(fun target -> + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + (* CR-someday amokhov: Don't ignore directory targets *) + ignore dirs; + files) + in + Path.Build.Set.iter file_targets ~f:(fun target -> Cached_digest.remove target; Path.Build.unlink_no_err target); (* Step II. Try to restore artifacts from the shared cache if the @@ -1815,25 +1956,35 @@ end = struct (* Step IV. Store results to the shared cache and if that step fails, post-process targets by removing write permissions and computing their digests. *) + let file_targets, dir_targets = + Targets.map targets ~f:(fun ~files ~dirs -> (files, dirs)) + in match t.cache_config with | Enabled { storage_mode = mode; reproducibility_check = _ } - when can_go_in_shared_cache -> ( + when can_go_in_shared_cache + (* CR-someday amokhov: Add support for caching rules + with directory targets. *) + && Path.Build.Set.is_empty dir_targets -> ( let+ targets_and_digests = - try_to_store_to_shared_cache ~mode ~rule_digest ~targets - ~action:action.action + try_to_store_to_shared_cache ~mode ~rule_digest + ~file_targets ~action:action.action in match targets_and_digests with | Some targets_and_digests -> targets_and_digests | None -> compute_target_digests_or_raise_error execution_parameters - ~loc targets) + ~loc file_targets) | _ -> + let targets = + Path.Build.Set.union file_targets + exec_result.paths_in_directory_targets + in Fiber.return (compute_target_digests_or_raise_error execution_parameters ~loc targets) in let dynamic_deps_stages = - List.map exec_result.dynamic_deps_stages + List.map exec_result.action_exec_result.dynamic_deps_stages ~f:(fun (deps, fact_map) -> ( deps , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env @@ -1856,9 +2007,15 @@ end = struct | Promote _, Some Never -> Fiber.return () | Promote { lifetime; into; only }, (Some Automatically | None) -> + (* CR-someday amokhov: Don't ignore directory targets. *) + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + ignore dirs; + files) + in Fiber.parallel_iter_set (module Path.Build.Set) - (Targets.files targets) + file_targets ~f:(fun target -> let consider_for_promotion = match only with @@ -2127,14 +2284,46 @@ end = struct let t = t () in get_rule_or_source t path >>= function | Source digest -> Memo.Build.return digest - | Rule (path, rule) -> + | Rule (path, rule) -> ( let+ { deps = _; targets } = Memo.push_stack_frame (fun () -> execute_rule rule) ~human_readable_description:(fun () -> Pp.text (Path.to_string_maybe_quoted (Path.build path))) in - Path.Build.Map.find_exn targets path + match Path.Build.Map.find targets path with + | Some digest -> digest + | None -> ( + match Cached_digest.build_file path with + | Ok digest -> digest (* Must be a directory target *) + | _ -> + let target = + Path.Build.drop_build_context_exn path + |> Path.Source.to_string_maybe_quoted + in + let _matching_files, matching_dirs = + Targets.to_list_map rule.targets ~file:ignore ~dir:(fun dir -> + match Path.Build.is_descendant path ~of_:dir with + | true -> [ dir ] + | false -> []) + in + let matching_target = + match List.concat matching_dirs with + | [ dir ] -> + Path.Build.drop_build_context_exn dir + |> Path.Source.to_string_maybe_quoted + | [] + | _ :: _ -> + Code_error.raise "Multiple matching directory targets" + [ ("targets", Targets.to_dyn rule.targets) ] + in + User_error.raise ~loc:rule.loc + ~annots:[ User_error.Annot.Needs_stack_trace.make () ] + [ Pp.textf + "This rule defines a directory target %S that matches the \ + requested path %S but the rule's action didn't produce it" + matching_target target + ])) let dep_on_anonymous_action (x : Rule.Anonymous_action.t Action_builder.t) : _ Action_builder.t = @@ -2179,21 +2368,27 @@ end = struct let eval_impl g = let dir = File_selector.dir g in - load_dir ~dir >>| function - | Non_build targets -> Path.Set.filter targets ~f:(File_selector.test g) - | Build { rules_here; _ } -> + load_dir ~dir >>= function + | Non_build targets -> + Memo.Build.return (Path.Set.filter targets ~f:(File_selector.test g)) + | Build { rules_here; _ } -> ( let only_generated_files = File_selector.only_generated_files g in - Path.Build.Map.foldi ~init:[] rules_here - ~f:(fun s { Rule.info; _ } acc -> - match info with - | Rule.Info.Source_file_copy _ when only_generated_files -> acc - | _ -> - let s = Path.build s in - if File_selector.test g s then - s :: acc - else - acc) - |> Path.Set.of_list + let file_targets = + Path.Build.Map.foldi ~init:[] rules_here.by_file_targets + ~f:(fun s { Rule.info; _ } acc -> + match info with + | Rule.Info.Source_file_copy _ when only_generated_files -> acc + | _ -> + let s = Path.build s in + if File_selector.test g s then + s :: acc + else + acc) + |> Path.Set.of_list + in + is_target dir >>| function + | true -> Path.Set.add file_targets dir + | false -> file_targets) let eval_memo = Memo.create "eval-pred" @@ -2376,10 +2571,6 @@ let file_exists = file_exists let alias_exists = Load_rules.alias_exists -let is_target file = - let+ targets = targets_of ~dir:(Path.parent_exn file) in - Path.Set.mem targets file - let execute_action = execute_action let execute_action_stdout = execute_action_stdout @@ -2443,7 +2634,7 @@ let get_current_progress () = ; number_of_rules_discovered = t.rule_total } -let targets_of = targets_of +let file_targets_of = file_targets_of let all_targets () = all_targets (t ()) diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index 9703f3b06b8b..ff9a11b93d82 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -135,8 +135,8 @@ val eval_pred : File_selector.t -> Path.Set.t Memo.Build.t (** Same as [eval_pred] but also build the resulting set of files. *) val build_pred : File_selector.t -> Dep.Fact.Files.t Memo.Build.t -(** Returns the set of targets in the given directory. *) -val targets_of : dir:Path.t -> Path.Set.t Memo.Build.t +(** Returns the set of file targets in the given directory. *) +val file_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 diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index d9c2919967a3..172a6d97fd31 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -318,9 +318,11 @@ module Fancy = struct ("(internal)" :: targets_acc) (add_ctx ctx ctxs_acc) rest) in - let file_targets = Targets.to_list_map targets ~file:Fun.id in let target_names, contexts = - split_paths [] Context_name.Set.empty file_targets + let file_targets, directory_targets = + Targets.to_list_map targets ~file:Fun.id ~dir:Fun.id + in + split_paths [] Context_name.Set.empty (file_targets @ directory_targets) in let targets = List.map target_names ~f:Filename.split_extension_after_dot diff --git a/src/dune_engine/rule.ml b/src/dune_engine/rule.ml index 0217992cb936..92e651df1578 100644 --- a/src/dune_engine/rule.ml +++ b/src/dune_engine/rule.ml @@ -90,8 +90,8 @@ let add_sandbox_config : let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets action = - let open Memo.Build.O in let action = + let open Memo.Build.O in Action_builder.memoize "Rule.make" (Action_builder.of_thunk { f = @@ -101,36 +101,36 @@ let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context (action, deps)) }) in - let dir = - match Targets.validate targets with - | Valid { parent_dir } -> parent_dir - | No_targets -> ( - match info with - | From_dune_file loc -> - User_error.raise ~loc [ Pp.text "Rule has no targets specified" ] - | _ -> Code_error.raise "Build_interpret.Rule.make: no targets" []) - | Inconsistent_parent_dir -> ( - match info with - | Internal - | Source_file_copy _ -> - Code_error.raise "rule has targets in different directories" - [ ("targets", Targets.to_dyn targets) ] - | From_dune_file loc -> - User_error.raise ~loc - [ Pp.text "Rule has targets in different directories.\nTargets:" - ; Targets.pp targets - ]) - in - let loc = + match Targets.validate targets with + | No_targets -> ( match info with - | From_dune_file loc -> loc - | Internal -> - Loc.in_file - (Path.drop_optional_build_context - (Path.build (Path.Build.relative dir "_unknown_"))) - | Source_file_copy p -> Loc.in_file (Path.source p) - in - { id = Id.gen (); targets; context; action; mode; info; loc; dir } + | From_dune_file loc -> + User_error.raise ~loc [ Pp.text "Rule has no targets specified" ] + | Internal + | Source_file_copy _ -> + Code_error.raise "Rule.Targets: An internal rule with no targets" []) + | Inconsistent_parent_dir -> ( + match info with + | From_dune_file loc -> + User_error.raise ~loc + [ Pp.text "Rule has targets in different directories.\nTargets:" + ; Targets.pp targets + ] + | Internal + | Source_file_copy _ -> + Code_error.raise "Rule has targets in different directories" + [ ("targets", Targets.to_dyn targets) ]) + | Valid { parent_dir = dir } -> + let loc = + match info with + | From_dune_file loc -> loc + | Internal -> + Loc.in_file + (Path.drop_optional_build_context + (Path.build (Path.Build.relative dir "_unknown_"))) + | Source_file_copy p -> Loc.in_file (Path.source p) + in + { id = Id.gen (); targets; context; action; mode; info; loc; dir } let set_action t action = let action = Action_builder.memoize "Rule.set_action" action in diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index 3e220f54a97a..3828e730befd 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -4,6 +4,7 @@ open! Stdune open! Import module Action_builder := Action_builder0 +(** Information about the provenance of a build rule. *) module Info : sig type t = | From_dune_file of Loc.t diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index 4c0f329c7218..926b71c90567 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -112,8 +112,58 @@ let rename_optional_file ~src ~dst = | exception Unix.Unix_error (ENOENT, _, _) -> () | () -> ()) -let move_targets_to_build_dir t ~targets = - Targets.iter targets ~file:(fun target -> +(* Recursively move regular files from [src] to [dst] and return the set of + moved files. *) +let rename_dir_recursively ~loc ~src_dir ~dst_dir = + let rec loop ~src ~dst ~dst_parent = + (match Fpath.mkdir dst with + | Created -> () + | Already_exists -> (* CR-someday amokhov: Should we clear it? *) () + | Missing_parent_directory -> assert false); + match Dune_filesystem_stubs.read_directory_with_kinds src with + | Ok files -> + List.concat_map files ~f:(fun (file, kind) -> + let src = Filename.concat src file in + let dst = Filename.concat dst file in + match (kind : Dune_filesystem_stubs.File_kind.t) with + | S_REG -> + Unix.rename src dst; + [ Path.Build.relative dst_parent file ] + | S_DIR -> + loop ~src ~dst ~dst_parent:(Path.Build.relative dst_parent file) + | _ -> + User_error.raise ~loc + [ Pp.textf "Rule produced a file with unrecognised kind %S" + (Dune_filesystem_stubs.File_kind.to_string kind) + ]) + | Error (ENOENT, _, _) -> + User_error.raise ~loc + [ Pp.textf "Rule failed to produce directory %S" + (Path.of_string src + |> Path.drop_optional_build_context_maybe_sandboxed + |> Path.to_string_maybe_quoted) + ] + | Error (unix_error, _, _) -> + User_error.raise ~loc + [ Pp.textf "Rule produced unreadable directory %S" + (Path.of_string src + |> Path.drop_optional_build_context_maybe_sandboxed + |> Path.to_string_maybe_quoted) + ; Pp.verbatim (Unix.error_message unix_error) + ] + in + loop + ~src:(Path.Build.to_string src_dir) + ~dst:(Path.Build.to_string dst_dir) + ~dst_parent:dst_dir + |> Path.Build.Set.of_list + +let move_targets_to_build_dir t ~loc ~targets = + Targets.to_list_map targets + ~file:(fun target -> rename_optional_file ~src:(map_path t target) ~dst:target) + ~dir:(fun target -> + rename_dir_recursively ~loc ~src_dir:(map_path t target) ~dst_dir:target) + |> snd |> Path.Build.Set.union_all let destroy t = Path.rm_rf (Path.build t.dir) diff --git a/src/dune_engine/sandbox.mli b/src/dune_engine/sandbox.mli index ef41499601af..24179047e733 100644 --- a/src/dune_engine/sandbox.mli +++ b/src/dune_engine/sandbox.mli @@ -20,7 +20,8 @@ val create : -> t (** Move the targets created by the action from the sandbox to the build - directory. *) -val move_targets_to_build_dir : t -> targets:Targets.t -> unit + directory. Returns the set of paths discovered in directory targets. *) +val move_targets_to_build_dir : + t -> loc:Loc.t -> targets:Targets.t -> Path.Build.Set.t val destroy : t -> unit diff --git a/src/dune_engine/string_with_vars.ml b/src/dune_engine/string_with_vars.ml index 7eb40a411b93..15d920eaa6f6 100644 --- a/src/dune_engine/string_with_vars.ml +++ b/src/dune_engine/string_with_vars.ml @@ -312,6 +312,14 @@ let text_only t = | [ Text s ] -> Some s | _ -> None +let last_text_part t = + List.filter_map t.parts ~f:(function + | Text s -> Some s + | Error _ + | Pform _ -> + None) + |> List.last + let has_pforms t = Option.is_none (text_only t) let encode t = diff --git a/src/dune_engine/string_with_vars.mli b/src/dune_engine/string_with_vars.mli index dfc9d6767a8c..f65c0e699468 100644 --- a/src/dune_engine/string_with_vars.mli +++ b/src/dune_engine/string_with_vars.mli @@ -54,6 +54,9 @@ val has_pforms : t -> bool (** If [t] contains no variable, returns the contents of [t]. *) val text_only : t -> string option +(** The last text part of [t], if any. *) +val last_text_part : t -> string option + module Mode : sig (** How many values expansion of a template must produce. diff --git a/src/dune_engine/targets.ml b/src/dune_engine/targets.ml index b6f336a13b1a..2d39c2bc60c2 100644 --- a/src/dune_engine/targets.ml +++ b/src/dune_engine/targets.ml @@ -1,23 +1,40 @@ open! Stdune open Import -type t = { files : Path.Build.Set.t } [@@unboxed] +(* CR-someday amokhov: Most of these records will have [dir = empty]. We might + want to somehow optimise for the common case, e.g. by switching to a sum type + with the [Files_only] constructor. It's best not to expose the current + representation so we can easily change it in future. *) +type t = + { files : Path.Build.Set.t + ; dirs : Path.Build.Set.t + } module File = struct - let create file = { files = Path.Build.Set.singleton file } + let create file = + { files = Path.Build.Set.singleton file; dirs = Path.Build.Set.empty } end module Files = struct - let create files = { files } + let create files = { files; dirs = Path.Build.Set.empty } end -let empty = { files = Path.Build.Set.empty } +let create ~files ~dirs = { files; dirs } -let combine x y = { files = Path.Build.Set.union x.files y.files } +let empty = { files = Path.Build.Set.empty; dirs = Path.Build.Set.empty } -let is_empty t = Path.Build.Set.is_empty t.files +let combine x y = + { files = Path.Build.Set.union x.files y.files + ; dirs = Path.Build.Set.union x.dirs y.dirs + } -let head { files } = Path.Build.Set.choose files +let is_empty { files; dirs } = + Path.Build.Set.is_empty files && Path.Build.Set.is_empty dirs + +let head { files; dirs } = + match Path.Build.Set.choose files with + | Some _ as target -> target + | None -> Path.Build.Set.choose dirs let head_exn t = match head t with @@ -25,21 +42,33 @@ let head_exn t = | None -> Code_error.raise "Targets.head_exn applied to empty set of targets" [] -let to_dyn { files } = Dyn.Record [ ("files", Path.Build.Set.to_dyn files) ] +let to_dyn { files; dirs } = + Dyn.Record + [ ("files", Path.Build.Set.to_dyn files) + ; ("dirs", Path.Build.Set.to_dyn dirs) + ] -let pp { files } = - Pp.enumerate (Path.Build.Set.to_list files) ~f:(fun target -> - Pp.text (Dpath.describe_target target)) +let pp { files; dirs } = + Pp.enumerate + (Path.Build.Set.to_list files @ Path.Build.Set.to_list dirs) + ~f:(fun target -> Pp.text (Dpath.describe_path (Path.build target))) -let exists { files } ~file = Path.Build.Set.exists files ~f:file +let exists { files; dirs } ~f = + Path.Build.Set.exists files ~f || Path.Build.Set.exists dirs ~f -let to_list_map { files } ~file = Path.Build.Set.to_list_map files ~f:file +let to_list_map { files; dirs } ~file ~dir = + ( Path.Build.Set.to_list_map files ~f:file + , Path.Build.Set.to_list_map dirs ~f:dir ) -let fold { files } ~init ~file = Path.Build.Set.fold files ~init ~f:file +let iter { files; dirs } ~file ~dir = + Path.Build.Set.iter files ~f:file; + Path.Build.Set.iter dirs ~f:dir -let iter { files } ~file = Path.Build.Set.iter files ~f:file +let map { files; dirs } ~f = f ~files ~dirs -let files t = t.files +let fold { files; dirs } ~init ~file ~dir = + let init = Path.Build.Set.fold files ~init ~f:file in + Path.Build.Set.fold dirs ~init ~f:dir module Validation_result = struct type t = @@ -54,8 +83,7 @@ let validate t = | false -> ( let parent_dir = Path.Build.parent_exn (head_exn t) in match - exists t ~file:(fun target -> - Path.Build.(parent_exn target <> parent_dir)) + exists t ~f:(fun path -> Path.Build.(parent_exn path <> parent_dir)) with | true -> Inconsistent_parent_dir | false -> Valid { parent_dir }) diff --git a/src/dune_engine/targets.mli b/src/dune_engine/targets.mli index 460b73d50e04..4cbed1089ad4 100644 --- a/src/dune_engine/targets.mli +++ b/src/dune_engine/targets.mli @@ -1,9 +1,10 @@ open! Stdune open! Import -(* CR-someday amokhov: Add directory targets. *) +(** A set of targets of a build rule. -(** A set of file targets of a build rule. *) + A rule can produce a set of files whose names are known upfront, as well as + a set of "opaque" directories whose contents is initially unknown. *) type t (** The empty set of targets. Note that rules are not allowed to have the empty @@ -26,6 +27,9 @@ module Files : sig val create : Path.Build.Set.t -> t end +(** A set of file and directory targets. *) +val create : files:Path.Build.Set.t -> dirs:Path.Build.Set.t -> t + module Validation_result : sig type t = | Valid of { parent_dir : Path.Build.t } @@ -37,20 +41,32 @@ end same parent dir. *) val validate : t -> Validation_result.t -(** The "head" target, i.e. the lexicographically first target file if [t] is - non-empty. *) +(** The "head" target if [t] is non-empty. If [t] contains at least one file, + then it's the lexicographically first target file. Otherwise, it's the + lexicographically first target directory. *) val head : t -> Path.Build.t option (** Like [head] but raises a code error if the set of targets is empty. *) val head_exn : t -> Path.Build.t -val files : t -> Path.Build.Set.t +val to_list_map : + t + -> file:(Path.Build.t -> 'a) + -> dir:(Path.Build.t -> 'b) + -> 'a list * 'b list -val to_list_map : t -> file:(Path.Build.t -> 'a) -> 'a list +val iter : + t -> file:(Path.Build.t -> unit) -> dir:(Path.Build.t -> unit) -> unit -val fold : t -> init:'a -> file:(Path.Build.t -> 'a -> 'a) -> 'a +val map : t -> f:(files:Path.Build.Set.t -> dirs:Path.Build.Set.t -> 'a) -> 'a -val iter : t -> file:(Path.Build.t -> unit) -> unit +(** File targets are traversed before directory targets. *) +val fold : + t + -> init:'a + -> file:(Path.Build.t -> 'a -> 'a) + -> dir:(Path.Build.t -> 'a -> 'a) + -> 'a val to_dyn : t -> Dyn.t diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index d73ad9b39dfe..9b19b015864c 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -152,8 +152,8 @@ end = struct >>> Action_builder.if_file_exists f ~then_:(Action_builder.path f) ~else_:(Action_builder.return ())) in - Action_builder.with_targets - ~targets:(Targets.Files.create file_targets) + let targets = Targets.Files.create file_targets in + Action_builder.with_targets ~targets (let+ () = deps >>= Action_builder.path_set and+ () = deps_if_exist >>= action_builder_path_set_if_exist and+ res = b in @@ -516,8 +516,11 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir let deps_builder, expander = Dep_conf_eval.named ~expander deps_written_by_user in + let untagged_targets_written_by_user = + Targets_spec.untag targets_written_by_user + in let expander = - match (targets_written_by_user : _ Targets_spec.t) with + match (untagged_targets_written_by_user : _ Targets_spec.t) with | Infer -> expander | Static { targets; multiplicity } -> Expander.add_bindings_full expander @@ -532,7 +535,8 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir (Value.L.paths (List.map targets ~f:Path.build))))) in let expander = - Expander.set_expanding_what expander (User_action targets_written_by_user) + Expander.set_expanding_what expander + (User_action untagged_targets_written_by_user) in let+! { Action_builder.With_targets.build; targets } = Action_expander.run (expand t) ~expander @@ -541,17 +545,23 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir match (targets_written_by_user : _ Targets_spec.t) with | Infer -> targets | Static { targets = targets_written_by_user; multiplicity = _ } -> - Targets.combine targets - (Targets.Files.create (Path.Build.Set.of_list targets_written_by_user)) + let files, dirs = + List.partition_map targets_written_by_user ~f:(fun (path, tag) -> + if Path.Build.(parent_exn path <> targets_dir) then + User_error.raise ~loc + [ Pp.text + "This action has targets in a different directory than the \ + current one, this is not allowed by dune at the moment:" + ; Targets.pp targets + ]; + match tag with + | None -> Left path + | Star -> Right path) + in + let files = Path.Build.Set.of_list files in + let dirs = Path.Build.Set.of_list dirs in + Targets.combine targets (Targets.create ~files ~dirs) in - Targets.iter targets ~file:(fun target -> - if Path.Build.( <> ) (Path.Build.parent_exn target) targets_dir then - User_error.raise ~loc - [ Pp.text - "This action has targets in a different directory than the \ - current one, this is not allowed by dune at the moment:" - ; Targets.pp targets - ]); let build = let+ () = deps_builder and+ action = build in diff --git a/src/dune_rules/action_unexpanded.mli b/src/dune_rules/action_unexpanded.mli index 27a9e030c85f..f08ba70f8d94 100644 --- a/src/dune_rules/action_unexpanded.mli +++ b/src/dune_rules/action_unexpanded.mli @@ -31,7 +31,7 @@ val expand : -> loc:Loc.t -> deps:Dep_conf.t Bindings.t -> targets_dir:Path.Build.t - -> targets:Path.Build.t Targets_spec.t + -> targets:(Path.Build.t * Targets_spec.Tag.t) Targets_spec.t -> expander:Expander.t -> Action.t Action_builder.With_targets.t Memo.Build.t diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 795a8a3abe48..85973c7129ce 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -143,8 +143,12 @@ end = struct Memo.Build.return (Coq_stanza.Extraction.ml_target_fnames s) | Menhir.T menhir -> Memo.Build.return (Menhir_rules.targets menhir) | Rule rule -> - Simple_rules.user_rule sctx rule ~dir ~expander - >>| Targets.to_list_map ~file:Path.Build.basename + let+ targets = Simple_rules.user_rule sctx rule ~dir ~expander in + (* CR-someday amokhov: Do not ignore directory targets. *) + let file_target_names, _ignored_dir_targets = + Targets.to_list_map targets ~file:Path.Build.basename ~dir:ignore + in + file_target_names | Copy_files def -> let+ ps = Simple_rules.copy_files sctx def ~src_dir ~dir ~expander diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index c1b29edae3b0..a6fa910f12ee 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -1626,10 +1626,23 @@ module Rule = struct ; package = None } + let directory_targets_extension = + let syntax = + Dune_lang.Syntax.create ~name:"directory-targets" + ~desc:"experimental support for directory targets" + [ ((0, 1), `Since (3, 0)) ] + in + Dune_project.Extension.register syntax (return ((), [])) Dyn.Encoder.unit + let long_form = let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty in + let* project = Dune_project.get_exn () in + let disallow_directory_targets = + Option.is_none + (Dune_project.find_extension_args project directory_targets_extension) + in String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) (let+ loc = loc and+ action = field "action" (located Action_dune_lang.decode) @@ -1659,6 +1672,13 @@ module Rule = struct field_o "alias" (Dune_lang.Syntax.since Stanza.syntax (2, 0) >>> Alias.Name.decode) in + if + disallow_directory_targets && Targets_spec.has_target_directory targets + then + User_error.raise ~loc + [ Pp.text + "Directory targets require the 'directory-targets' extension" + ]; { targets; deps; action; mode; locks; loc; enabled_if; alias; package }) let decode = diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 0e63482fd6f0..8e3f08499833 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -23,22 +23,23 @@ let check_filename = User_error.raise ~loc:error_loc [ Pp.textf "%s does not denote a file in the current directory" s ] in - fun ~error_loc ~dir fn -> - match fn with + fun ~error_loc ~dir -> function | Value.String ("." | "..") -> User_error.raise ~loc:error_loc [ Pp.text "'.' and '..' are not valid filenames" ] | String s -> + let s, tag = + match String.drop_suffix s ~suffix:"/*" with + | None -> (s, Targets_spec.Tag.None) + | Some s -> (s, Star) + in if Filename.dirname s <> Filename.current_dir_name then not_in_dir ~error_loc s; - Path.Build.relative ~error_loc dir s - | Path p -> - if - Option.compare Path.compare (Path.parent p) (Some (Path.build dir)) - <> Eq - then - not_in_dir ~error_loc (Path.to_string p); - Path.as_in_build_dir_exn p + (Path.Build.relative ~error_loc dir s, tag) + | Path p -> ( + match Option.equal Path.equal (Path.parent p) (Some (Path.build dir)) with + | true -> (Path.as_in_build_dir_exn p, Targets_spec.Tag.None) + | false -> not_in_dir ~error_loc (Path.to_string p)) | Dir p -> not_in_dir ~error_loc (Path.to_string p) type rule_kind = @@ -51,7 +52,7 @@ let rule_kind ~(rule : Rule.t) match rule.alias with | None -> No_alias | Some alias -> ( - match action.targets |> Targets.head with + match Targets.head action.targets with | None -> Alias_only alias | Some target -> Alias_with_targets (alias, target)) @@ -101,14 +102,17 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = ~expander ~deps:rule.deps ~targets ~targets_dir:dir in match rule_kind ~rule ~action with - | No_alias -> add_user_rule sctx ~dir ~rule ~action ~expander + | No_alias -> + let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in + targets | Alias_with_targets (alias, alias_target) -> let* () = let alias = Alias.make alias ~dir in Rules.Produce.Alias.add_deps alias (Action_builder.path (Path.build alias_target)) in - add_user_rule sctx ~dir ~rule ~action ~expander + let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in + targets | Alias_only name -> let alias = Alias.make ~dir name in let* locks = interpret_locks ~expander rule.locks in diff --git a/src/dune_rules/targets_spec.ml b/src/dune_rules/targets_spec.ml index d1b2299f3e08..4e2ec40a43af 100644 --- a/src/dune_rules/targets_spec.ml +++ b/src/dune_rules/targets_spec.ml @@ -23,6 +23,14 @@ module Multiplicity = struct | Multiple, One -> error "targets" "target" end +(* CR-someday amokhov: Add more interesting tags, for example, to allow the user + to specify file patterns like "*.ml" for directory targets. *) +module Tag = struct + type t = + | None + | Star +end + module Static = struct type 'path t = { targets : 'path list @@ -56,3 +64,17 @@ let field = let open Dune_lang.Decoder in fields_mutually_exclusive ~default:Infer [ ("targets", decode_static); ("target", decode_one_static) ] + +let has_target_directory = function + | Infer -> false + | Static { targets; _ } -> + List.exists targets ~f:(fun target -> + match String_with_vars.last_text_part target with + | None -> false + | Some part -> Option.is_some (String.drop_suffix ~suffix:"/*" part)) + +let untag = function + | Infer -> Infer + | Static { targets; multiplicity } -> + let targets = List.map targets ~f:fst in + Static { targets; multiplicity } diff --git a/src/dune_rules/targets_spec.mli b/src/dune_rules/targets_spec.mli index 5ed5cc258e4b..563fa634476a 100644 --- a/src/dune_rules/targets_spec.mli +++ b/src/dune_rules/targets_spec.mli @@ -11,19 +11,32 @@ module Multiplicity : sig val check_variable_matches_field : loc:Loc.t -> field:t -> variable:t -> unit end +(** Tags are used to distinguish file and directory targets. Specifically, a + directory target is specified by adding "/*" at the end. *) +module Tag : sig + type t = + | None + | Star (** Ends with "/*", i.e. "output/*" *) +end + module Static : sig type 'path t = - { targets : 'path list + { targets : 'path list (** Here ['path] may be tagged with [Tag.t]. *) ; multiplicity : Multiplicity.t } end (** Static targets are listed by the user while [Infer] denotes that dune must discover all the targets. In the [Static] case, dune still implicitly adds - the list of inferred targets *) + the list of inferred targets. *) type 'a t = | Static of 'a Static.t | Infer (** [target] or [targets] field with the correct multiplicity. *) val field : String_with_vars.t t Dune_lang.Decoder.fields_parser + +(** Contains a directory target. *) +val has_target_directory : String_with_vars.t t -> bool + +val untag : ('a * Tag.t) t -> 'a t diff --git a/test/blackbox-tests/test-cases/directory-targets.t/run.t b/test/blackbox-tests/test-cases/directory-targets.t/run.t new file mode 100644 index 000000000000..7cf741ac57f6 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets.t/run.t @@ -0,0 +1,317 @@ +Tests for directory targets. + + $ cat > dune-project < (lang dune 3.0) + > EOF + +Directory targets require an extension. + + $ cat > dune < (rule + > (targets output/*) + > (action (bash "true"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (targets output/*) + 3 | (action (bash "true"))) + Error: Directory targets require the 'directory-targets' extension + [1] + + $ cat > dune-project < (lang dune 3.0) + > (using directory-targets 0.1) + > EOF + +Directory targets are not allowed for non-sandboxed rules. + + $ dune build output/x + File "dune", line 1, characters 0-52: + 1 | (rule + 2 | (targets output/*) + 3 | (action (bash "true"))) + Error: Rules with directory targets must be sandboxed + [1] + +Ensure directory targets are produced. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "true"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-78: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets output/*) + 4 | (action (bash "true"))) + Error: Rule failed to produce directory "output" + [1] + +Error message when the matching directory target doesn't contain a requested path. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir output"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-86: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets output/*) + 4 | (action (bash "mkdir output"))) + Error: This rule defines a directory target "output" that matches the + requested path "output/x" but the rule's action didn't produce it + [1] + +Build directory target from the command line. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + + $ dune build output/x + $ cat _build/default/output/x + x + $ cat _build/default/output/y + y + +Requesting the directory target directly works too. + + $ cat > dune < (rule + > (deps src_x (sandbox always)) + > (targets output/*) + > (action (bash "mkdir output; cat src_x > output/x; echo y > output/y"))) + > EOF + + $ rm -rf _build + $ echo x > src_x + $ dune build output + $ cat _build/default/output/x + x + $ cat _build/default/output/y + y + +Rebuilding works correctly. + + $ echo new-x > src_x + $ dune build output + $ cat _build/default/output/x + new-x + +Hints for directory targets. + + $ dune build outputs + Error: Don't know how to build outputs + Hint: did you mean output? + [1] + +Print rules. + + $ dune rules output + ((deps + ((File (In_build_dir _build/default/src_x)) + (Sandbox_config ((disallow none))) + (Sandbox_config ()))) + (targets ((In_build_dir _build/default/output/*))) + (context default) + (action + (chdir + _build/default + (bash "mkdir output; cat src_x > output/x; echo y > output/y")))) + + $ dune rules -m output | tr '\t' ' ' | head -n -1 + _build/default/output: _build/default/src_x + mkdir -p _build/default; \ + mkdir -p _build/default; \ + cd _build/default; \ + bash -e -u -o pipefail -c \ + 'mkdir output; cat src_x > output/x; echo y > output/y' + +Error when requesting a missing subdirectory of a directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + +Error message when depending on a file that isn't produced by the matching +directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir -p output/subdir; echo a > output/a; echo b > output/subdir/b"))) + > (rule + > (deps output/subdir/c) + > (target main) + > (action (bash "cat output/subdir/c > main"))) + > EOF + + $ dune build main + File "dune", line 1, characters 0-141: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets output/*) + 4 | (action (bash "mkdir -p output/subdir; echo a > output/a; echo b > output/subdir/b"))) + Error: This rule defines a directory target "output" that matches the + requested path "output/subdir/c" but the rule's action didn't produce it + -> required by _build/default/main + [1] + +Depend on a file from a directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir -p output/subdir; echo a > output/a; echo b > output/subdir/b"))) + > (rule + > (deps output/subdir/b) + > (target main) + > (action (bash "cat output/subdir/b > main; echo 2 >> main"))) + > EOF + + $ dune build main + $ cat _build/default/main + b + 2 + $ cat _build/default/output/a + a + $ cat _build/default/output/subdir/b + b + +Interaction of globs and directory targets. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output/*) + > (action (bash "mkdir -p output/subdir; echo a > output/a; echo b > output/b; echo c > output/subdir/c"))) + > (rule + > (deps (glob_files output/*)) + > (target level1) + > (action (bash "echo %{deps}; ls output > level1"))) + > (rule + > (deps (glob_files output/subdir/*)) + > (target level2) + > (action (bash "echo %{deps}; ls output/subdir > level2"))) + > EOF + +Note that %{deps} currently expands only to the statically known paths, which is +just the "output" directory and doesn't include the contained generated files. + +# CR-someday amokhov: Improve this so that %{deps} includes generated files. + + $ dune build level1 + bash level1 + output + + $ cat _build/default/level1 + a + b + subdir + +Again, %{deps} currently expands to "output/subdir" instead of "output/subdir/c" + + $ dune build level2 + bash level2 + output/subdir + $ cat _build/default/level2 + c + +Depending on a directory target directly (rather than on individual files) works +too. Note that this can be achieved in two ways: + +(1) By depending on the recursively computed digest the directory's contents; + +(2) By depending on the mtime of the directory. + +Currently Dune implements (2) but we'd like to switch to (1) because it supports +the early cutoff optimisation and is also more reliable. + +The [src_c] dependency is unused in the rule's action but we use it to force the +rule to rerun when needed. + + $ cat > dune < (rule + > (deps src_a src_b src_c (sandbox always)) + > (targets output/*) + > (action (bash "echo running; mkdir -p output/subdir; cat src_a > output/a; cat src_b > output/subdir/b"))) + > (rule + > (deps output) + > (target contents) + > (action (bash "echo running; echo 'a:' > contents; cat output/a >> contents; echo 'b:' >> contents; cat output/subdir/b >> contents"))) + > EOF + + $ echo a > src_a + $ echo b > src_b + $ echo c > src_c + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + b + +We wait for the file system's clock to advance to make sure the directory's +mtime changes when the rule reruns. We can delete this when switching to (1). + + $ dune_cmd wait-for-fs-clock-to-advance + $ echo new-b > src_b + + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + new-b + +There is no early cutoff on directory targets at the moment. Ideally, we should +skip the second action since the produced directory has the same contents. + + $ echo new-cc > src_c + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + new-b + +There is no shared cache support for directory targets at the moment. Note that +we rerun both actions: the first one because there is no shared cache support +and the second one because of the lack of early cutoff. + + $ rm _build/default/output/a + $ dune build contents + bash output + running + bash contents + running