diff --git a/CHANGES.md b/CHANGES.md
index 14ed93b2973..a322404144e 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -11,6 +11,20 @@ unreleased
- [coq] Add `coq.pp` stanza to help with pre-processing of grammar
files (#2054, @ejgallego, review by @rgrinberg)
+- Add a new more generic form for the *promote* mode: `(promote
+ (until-clean) (into
))` (#2068, @diml)
+
+- Allow to promote only a subset of the targets via `(promote (only
+ ))`. For instance: `(promote (only *.mli))` (#2068, @diml)
+
+- Improve the behavior when a strict subset of the targets of a rule
+ is already in the source tree for projects using the dune language < 1.10
+ (#2068, fixes #2061, @diml)
+
+- With lang dune >= 1.10, rules in standard mode are no longer allowed
+ to produce targets that are present in the source tree. This has
+ been a warning for long enough (#2068, @diml)
+
1.9.1 (11/04/2019)
------------------
diff --git a/bin/common.ml b/bin/common.ml
index 1e248d7a81a..3f031c19a07 100644
--- a/bin/common.ml
+++ b/bin/common.ml
@@ -194,11 +194,11 @@ let term =
~doc:"Instead of terminating build after completion, wait continuously
for file changes.")
and+ root,
- only_packages,
- ignore_promoted_rules,
- config_file,
- profile,
- default_target =
+ only_packages,
+ ignore_promoted_rules,
+ config_file,
+ profile,
+ default_target =
let default_target_default =
match Wp.t with
| Dune -> "@@default"
@@ -230,7 +230,8 @@ let term =
Arg.(value
& flag
& info ["ignore-promoted-rules"] ~docs
- ~doc:"Ignore rules with (mode promote)")
+ ~doc:"Ignore rules with (mode promote),
+ except ones with (only ...)")
and+ (config_file_opt, config_file) =
Term.ret @@
let+ config_file =
diff --git a/doc/dune-files.rst b/doc/dune-files.rst
index cf9f4e8f990..06b6458292a 100644
--- a/doc/dune-files.rst
+++ b/doc/dune-files.rst
@@ -450,27 +450,40 @@ field. The following modes are available:
of fallback rules is to generate default configuration files that
may be generated by a configure script.
-- ``promote``, in this mode, the files in the source tree will be
- ignored. Once the rule has been executed, the targets will be copied
- back to the source tree
-
-- ``promote-until-clean`` is the same as ``promote`` except than
- ``dune clean`` will remove the promoted files from the source
- tree
-
-- ``(promote-into )`` (resp. ``(promote-until-clean-into
- )``) is the same as ``promote`` (resp. ``promote-until-clean``)
- except that the files are promoted in ```` instead of the
- current directory. This feature is available since Dune 1.8.
+- ``promote`` or ``(promote )``, in this mode, the files
+ in the source tree will be ignored. Once the rule has been executed,
+ the targets will be copied back to the source tree
+
+ The following options are available:
+ - ``(until-clean)`` means that ``dune clean`` will remove the
+ promoted files from the source tree
+ - ``(into )`` means that the files are promoted in ````
+ instead of the current directory. This feature is available since
+ Dune 1.8
+ - ``(only )`` means that only a subset of the targets
+ should be promoted. The argument is a predicate in a syntax
+ similar to the argument of :ref:`(dirs ...) `. This
+ feature is available since dune 1.10
+
+- ``promote-until-clean`` is the same as ``(promote (until-clean))``
+- ``(promote-into )`` is the same as ``(promote (into ))``
+- ``(promote-until-clean-into )`` is the same as ``(promote
+ (until-clean) (into ))``
+
+The ``(promote )`` form is only available since Dune
+1.10. Before Dune 1.10, you need to use one of the ``promote-...``
+forms. The ``promote-...`` forms should disappear in Dune 2.0, so
+using the more generic ``(promote )`` form should be prefered
+in new projects.
There are two use cases for promote rules. The first one is when the
generated code is easier to review than the generator, so it's easier
to commit the generated code and review it. The second is to cut down
dependencies during releases: by passing ``--ignore-promoted-rules``
-to dune, rules will ``(mode promote)`` will be ignored and the
-source files will be used instead. The
-``-p/--for-release-of-packages`` flag implies
-``--ignore-promote-rules``.
+to dune, rules will ``(mode promote)`` will be ignored and the source
+files will be used instead. The ``-p/--for-release-of-packages`` flag
+implies ``--ignore-promote-rules``. However, rules that promotes only
+a subset of their targets via ``(only ...)`` are never ignored.
inferred rules
~~~~~~~~~~~~~~
diff --git a/src/build_system.ml b/src/build_system.ml
index 10f26ad1ef8..5c337381976 100644
--- a/src/build_system.ml
+++ b/src/build_system.ml
@@ -70,10 +70,10 @@ end
let files_in_source_tree_to_delete () =
Promoted_to_delete.load ()
-let rule_loc ~file_tree ~loc ~dir =
- match loc with
- | Some loc -> loc
- | None ->
+let rule_loc ~file_tree ~info ~dir =
+ match (info : Rule.Info.t) with
+ | From_dune_file loc -> loc
+ | _ ->
let dir = Path.drop_optional_build_context dir in
let file =
match
@@ -104,7 +104,7 @@ module Internal_rule = struct
; context : Context.t option
; build : (unit, Action.t) Build.t
; mode : Dune_file.Rule.Mode.t
- ; loc : Loc.t option
+ ; info : Rule.Info.t
; dir : Path.t
; env : Env.t option
; sandbox : bool
@@ -131,12 +131,13 @@ module Internal_rule = struct
let equal a b = Id.equal a.id b.id
let hash t = Id.hash t.id
- let loc ~file_tree ~dir t = rule_loc ~file_tree ~dir ~loc:t.loc
-
let to_sexp t : Sexp.t =
Sexp.Encoder.record
[ "id", Id.to_sexp t.id
- ; "loc", Sexp.Encoder.option Loc.to_sexp t.loc
+ ; "loc", Sexp.Encoder.option Loc.to_sexp
+ (match t.info with
+ | From_dune_file loc -> Some loc
+ | _ -> None)
]
let lib_deps t =
@@ -155,7 +156,7 @@ module Internal_rule = struct
; context = None
; build = Build.return (Action.Progn [])
; mode = Standard
- ; loc = None
+ ; info = Internal
; dir = Path.root
; env = None
; sandbox = false
@@ -616,47 +617,29 @@ let get_dir_status t ~dir =
(Dir_status.Rules_collector.create_pending ~info:(Path.to_sexp dir) ())
end)
-(* [copy_source] is [true] for rules copying files from the source directory *)
-let add_spec t fn rule ~copy_source =
+let add_spec t fn rule =
match Path.Table.find t.files fn with
| None ->
Path.Table.add t.files fn rule
| Some rule' ->
- match copy_source, rule'.mode with
- | true, (Standard | Not_a_rule_stanza) ->
- Errors.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn)
- ~file_tree:t.file_tree)
- "File %s is both generated by a rule and present in the source tree.\n\
- As a result, the rule is currently ignored, however this will become an error \
- in the future.\n\
- %t"
- (String.maybe_quoted (Path.basename fn))
- (fun ppf ->
- match rule'.mode with
- | Not_a_rule_stanza ->
- Format.fprintf ppf "Delete file %s to get rid of this warning."
- (Path.to_string_maybe_quoted (Path.drop_optional_build_context fn))
- | Standard ->
- Format.fprintf ppf
- "To keep the current behavior and get rid of this warning, add a field \
- (fallback) to the rule'."
- | _ -> assert false);
- Path.Table.add t.files fn rule
- | _ ->
- let string_of_loc = function
- | None -> ""
- | Some { Loc.start; _ } ->
- start.pos_fname ^ ":" ^ string_of_int start.pos_lnum
- in
- die "Multiple rules generated for %s:\n\
- - %s\n\
- - %s"
- (Path.to_string_maybe_quoted fn)
- (if copy_source then
- ""
- else
- string_of_loc rule'.loc)
- (string_of_loc rule.loc)
+ let describe (rule : Internal_rule.t) =
+ match rule.info with
+ | From_dune_file { start; _ } ->
+ start.pos_fname ^ ":" ^ string_of_int start.pos_lnum
+ | Internal -> ""
+ | Source_file_copy -> "file present in source tree"
+ in
+ die "Multiple rules generated for %s:\n\
+ - %s\n\
+ - %s%s"
+ (Path.to_string_maybe_quoted fn)
+ (describe rule')
+ (describe rule)
+ (match rule.info, rule'.info with
+ | Source_file_copy, _ | _, Source_file_copy ->
+ "\nHint: rm -f " ^ Path.to_string_maybe_quoted
+ (Path.drop_optional_build_context fn)
+ | _ -> "")
(* This contains the targets of the actions that are being executed. On exit, we
need to delete them as they might contain garbage *)
@@ -668,7 +651,7 @@ let () =
pending_targets := Path.Set.empty;
Path.Set.iter fns ~f:Path.unlink_no_err)
-let compute_targets_digest_after_rule_execution ~loc targets =
+let compute_targets_digest_after_rule_execution ~info targets =
let good, bad =
List.partition_map targets ~f:(fun fn ->
match Utils.Cached_digest.refresh fn with
@@ -678,7 +661,10 @@ let compute_targets_digest_after_rule_execution ~loc targets =
match bad with
| [] -> Digest.string (Marshal.to_string good [])
| missing ->
- Errors.fail_opt loc
+ Errors.fail_opt
+ (match (info : Rule.Info.t) with
+ | From_dune_file loc -> Some loc
+ | _ -> None)
"rule failed to generate the following targets:\n%s"
(string_of_paths (Path.Set.of_list missing))
@@ -763,7 +749,70 @@ let handle_add_rule_effects f =
List.iter (Appendable_list.to_list l) ~f:(Thunk_with_backtrace.run));
res
-let rec compile_rule t ?(copy_source=false) pre_rule =
+let fix_up_legacy_fallback_rules t ~file_tree_dir ~dir rules =
+ (* Fix up non promote/fallback rules that have targets in the
+ source tree if we are in a dune < 1.10 project *)
+ match file_tree_dir with
+ | None -> rules
+ | Some ftdir ->
+ let dune_version =
+ Dune_project.dune_version (File_tree.Dir.project ftdir)
+ in
+ if Wp.t = Dune && dune_version >= (1, 10) then
+ rules
+ else begin
+ let source_files =
+ File_tree.Dir.files ftdir
+ |> Path.Set.of_string_set ~f:(Path.relative dir)
+ in
+ List.map rules ~f:(fun (rule : Pre_rule.t) ->
+ match rule.mode with
+ | Promote _ | Fallback | Ignore_source_files -> rule
+ | Standard ->
+ let inter = Path.Set.inter rule.targets source_files in
+ if Path.Set.is_empty inter then
+ rule
+ else begin
+ let mode, behavior =
+ if Path.Set.equal inter rule.targets then
+ (Dune_file.Rule.Mode.Fallback,
+ "acting as if the rule didn't exist")
+ else
+ (Dune_file.Rule.Mode.Promote
+ { lifetime = Unlimited
+ ; into = None
+ ; only =
+ Some
+ (Predicate_lang.of_pred
+ (fun s ->
+ Path.Set.mem inter (Path.relative dir s)))
+ },
+ "overwriting the source files with the generated one")
+ in
+ Errors.warn
+ (rule_loc ~info:rule.info ~dir ~file_tree:t.file_tree)
+ "The following files are both generated by a rule and are \
+ present in\nthe source tree:@\n@[%a@,@[%a@]@]"
+ (Fmt.list (Fmt.prefix (Fmt.string "- ") Path.pp))
+ (Path.Set.to_list inter
+ |> List.map ~f:Path.drop_optional_build_context)
+ Fmt.text
+ (sprintf "Because %s, I am closing my eyes on this and \
+ I am %s. However, you should really delete \
+ these files from your source tree. I will no \
+ longer accept this once you upgrade your \
+ project to dune >= 1.10."
+ (match Wp.t with
+ | Jbuilder -> "you are using the jbuilder binary"
+ | Dune ->
+ "your project was written for dune " ^
+ Syntax.Version.to_string dune_version)
+ behavior);
+ { rule with mode }
+ end)
+ end
+
+let rec compile_rule t pre_rule =
let { Pre_rule.
context
; env
@@ -772,7 +821,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
; sandbox
; mode
; locks
- ; loc
+ ; info
; dir
} =
pre_rule
@@ -790,13 +839,13 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
; sandbox
; locks
; mode
- ; loc
+ ; info
; dir
; transitive_rev_deps = Internal_rule.Id.Set.singleton id
; rev_deps = []
}
in
- Path.Set.iter targets ~f:(fun fn -> add_spec t fn rule ~copy_source)
+ Path.Set.iter targets ~f:(fun fn -> add_spec t fn rule)
and static_deps t build =
Fiber.Once.create (fun () ->
@@ -811,14 +860,8 @@ and setup_copy_rules t ~ctx_dir ~non_target_source_files =
Path.Set.iter non_target_source_files ~f:(fun path ->
let ctx_path = Path.append ctx_dir path in
let build = Build.copy ~src:path ~dst:ctx_path in
- (* We temporarily allow overrides while setting up copy rules from
- the source directory so that artifact that are already present
- in the source directory are not re-computed.
-
- This allows to keep generated files in tarballs. Maybe we
- should allow it on a case-by-case basis though. *)
- compile_rule t (Pre_rule.make build ~context:None ~env:None)
- ~copy_source:true)
+ compile_rule t (Pre_rule.make build ~context:None ~env:None
+ ~info:Source_file_copy))
and load_dir t ~dir = ignore (load_dir_and_get_targets t ~dir : Path.Set.t)
and targets_of t ~dir = load_dir_and_get_targets t ~dir
@@ -865,10 +908,13 @@ and load_dir_and_get_targets t ~dir =
and load_dir_step2_exn t ~dir ~collector =
let context_name, sub_dir = Path.extract_build_context_exn dir in
+ let is_install = context_name = "install" in
+ (* This condition is [true] because of [get_dir_status] *)
+ assert (is_install || String.Map.mem t.contexts context_name);
(* Load all the rules *)
let extra_subdirs_to_keep =
- if context_name = "install" then
+ if is_install then
These String.Set.empty
else
let gen_rules = String.Map.find_exn (Fdecl.get t.gen_rules) context_name in
@@ -898,12 +944,12 @@ and load_dir_step2_exn t ~dir ~collector =
| Some dir ->
String.Map.add aliases "default"
({ deps = Path.Set.empty
- ; dyn_deps =
- (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir
- >>^ fun (_ : bool) ->
- Path.Set.empty)
- ; actions = []
- } : Dir_status.Alias.immutable)
+ ; dyn_deps =
+ (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir
+ >>^ fun (_ : bool) ->
+ Path.Set.empty)
+ ; actions = []
+ } : Dir_status.Alias.immutable)
in
String.Map.foldi aliases ~init:([], Path.Set.empty)
~f:(fun name { Dir_status.Alias.deps; dyn_deps; actions } (rules, alias_stamp_files) ->
@@ -917,7 +963,8 @@ and load_dir_step2_exn t ~dir ~collector =
~suffix:("-" ^ Digest.to_string stamp)
in
let rule =
- Pre_rule.make ~locks ~context:(Some context) ~env ?loc
+ Pre_rule.make ~locks ~context:(Some context) ~env
+ ~info:(Rule.Info.of_loc_opt loc)
(Build.progn [ action; Build.create_file path ])
in
(rule :: rules, Path.Set.add action_stamp_files path))
@@ -945,14 +992,33 @@ and load_dir_step2_exn t ~dir ~collector =
in
Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files);
- (* Compute the set of targets and the set of source files that must not be copied *)
+ let file_tree_dir =
+ if is_install then
+ None
+ else
+ File_tree.find_dir t.file_tree sub_dir
+ in
+
+ let rules =
+ fix_up_legacy_fallback_rules t ~file_tree_dir ~dir rules
+ in
+
+ (* Compute the set of targets and the set of source files that must
+ not be copied *)
let user_rule_targets, source_files_to_ignore =
List.fold_left rules ~init:(Path.Set.empty, Path.Set.empty)
~f:(fun (acc_targets, acc_ignored) { Pre_rule.targets; mode; _ } ->
(Path.Set.union targets acc_targets,
match mode with
- | Promote _ | Ignore_source_files ->
+ | Promote { only = None; _ } | Ignore_source_files ->
Path.Set.union targets acc_ignored
+ | Promote { only = Some pred; _ } ->
+ let to_ignore =
+ Path.Set.filter targets ~f:(fun target ->
+ Predicate_lang.exec pred (Path.reach target ~from:dir)
+ ~standard:Predicate_lang.true_)
+ in
+ Path.Set.union to_ignore acc_ignored
| _ ->
acc_ignored))
in
@@ -960,16 +1026,13 @@ and load_dir_step2_exn t ~dir ~collector =
Path.Set.map source_files_to_ignore ~f:Path.drop_build_context_exn in
(* Take into account the source files *)
let targets, to_copy, subdirs_to_keep =
- match context_name with
- | "install" ->
+ if is_install then
(user_rule_targets,
None,
String.Set.empty)
- | ctx_name ->
- (* This condition is [true] because of [get_dir_status] *)
- assert (String.Map.mem t.contexts ctx_name);
+ else
let files, subdirs =
- match File_tree.find_dir t.file_tree sub_dir with
+ match file_tree_dir with
| None -> (Path.Set.empty, String.Set.empty)
| Some dir ->
(File_tree.Dir.file_paths dir,
@@ -1001,8 +1064,7 @@ and load_dir_step2_exn t ~dir ~collector =
| Some (_, to_copy) ->
List.filter rules ~f:(fun (rule : Pre_rule.t) ->
match rule.mode with
- | Standard | Promote _
- | Not_a_rule_stanza | Ignore_source_files -> true
+ | Standard | Promote _ | Ignore_source_files -> true
| Fallback ->
let source_files_for_targtes =
(* All targets are in [dir] and we know it correspond to a
@@ -1027,7 +1089,7 @@ and load_dir_step2_exn t ~dir ~collector =
Errors.fail
(rule_loc
~file_tree:t.file_tree
- ~loc:rule.loc
+ ~info:rule.info
~dir:(Path.drop_optional_build_context dir))
"\
Some of the targets of this fallback rule are present in the source tree,
@@ -1055,12 +1117,12 @@ The following targets are not:
assert (Path.equal x dir));
(* Compile the rules and cleanup stale artifacts *)
- List.iter rules ~f:(compile_rule t ~copy_source:false);
+ List.iter rules ~f:(compile_rule t);
Option.iter to_copy ~f:(fun (ctx_dir, source_files) ->
setup_copy_rules t ~ctx_dir ~non_target_source_files:source_files);
remove_old_artifacts t ~dir ~subdirs_to_keep;
- List.iter alias_rules ~f:(compile_rule t ~copy_source:false);
+ List.iter alias_rules ~f:(compile_rule t);
remove_old_artifacts t ~dir:alias_dir ~subdirs_to_keep;
targets
@@ -1184,7 +1246,10 @@ let () =
| Some input -> Some input
| None ->
Memo.Stack_frame.as_instance_of frame ~of_:evaluate_action_and_dynamic_deps_def)
- |> Option.bind ~f:(fun rule -> rule.Internal_rule.loc))
+ |> Option.bind ~f:(fun rule ->
+ match rule.Internal_rule.info with
+ | From_dune_file loc -> Some loc
+ | _ -> None))
let evaluate_rule (rule : Internal_rule.t) =
let* static_deps = Fiber.Once.get rule.static_deps in
@@ -1237,7 +1302,7 @@ let () =
; id = _
; static_deps = _
; build = _
- ; loc
+ ; info
; transitive_rev_deps = _
; rev_deps = _
} = rule
@@ -1319,7 +1384,7 @@ let () =
(* All went well, these targets are no longer pending *)
pending_targets := Path.Set.diff !pending_targets targets;
let targets_digest =
- compute_targets_digest_after_rule_execution ~loc targets_as_list
+ compute_targets_digest_after_rule_execution ~info targets_as_list
in
Trace.set head_target { rule_digest; targets_digest }
end else
@@ -1327,26 +1392,35 @@ let () =
end >>| fun () ->
begin
match mode with
- | Standard | Fallback | Not_a_rule_stanza | Ignore_source_files -> ()
- | Promote (lifetime, into) ->
+ | Standard | Fallback | Ignore_source_files -> ()
+ | Promote { lifetime; into; only } ->
Path.Set.iter targets ~f:(fun path ->
- let in_source_tree = Path.drop_build_context_exn path in
- let in_source_tree =
- match into with
- | None -> in_source_tree
- | Some { loc; dir } ->
- Path.relative
- (Path.relative (Path.parent_exn in_source_tree) dir
- ~error_loc:loc)
- (Path.basename in_source_tree)
+ let consider_for_promotion =
+ match only with
+ | None -> true
+ | Some pred ->
+ Predicate_lang.exec pred (Path.reach path ~from:dir)
+ ~standard:Predicate_lang.true_
in
- if not (Path.exists in_source_tree) ||
- (Utils.Cached_digest.file path <>
- Utils.Cached_digest.file in_source_tree) then begin
- if lifetime = Until_clean then
- Promoted_to_delete.add in_source_tree;
- Scheduler.ignore_for_watch in_source_tree;
- Io.copy_file ~src:path ~dst:in_source_tree ()
+ if consider_for_promotion then begin
+ let in_source_tree = Path.drop_build_context_exn path in
+ let in_source_tree =
+ match into with
+ | None -> in_source_tree
+ | Some { loc; dir } ->
+ Path.relative
+ (Path.relative (Path.parent_exn in_source_tree) dir
+ ~error_loc:loc)
+ (Path.basename in_source_tree)
+ in
+ if not (Path.exists in_source_tree) ||
+ (Utils.Cached_digest.file path <>
+ Utils.Cached_digest.file in_source_tree) then begin
+ if lifetime = Until_clean then
+ Promoted_to_delete.add in_source_tree;
+ Scheduler.ignore_for_watch in_source_tree;
+ Io.copy_file ~src:path ~dst:in_source_tree ()
+ end
end)
end;
t.hook Rule_completed
diff --git a/src/dune_file.ml b/src/dune_file.ml
index e81f33d3881..1a4a89eb0d5 100644
--- a/src/dune_file.ml
+++ b/src/dune_file.ml
@@ -1487,43 +1487,72 @@ module Rule = struct
module Mode = struct
- module Promotion_lifetime = struct
- type t =
- | Unlimited
- | Until_clean
- end
+ module Promote = struct
+ module Lifetime = struct
+ type t =
+ | Unlimited
+ | Until_clean
+ end
- module Into = struct
- type t =
- { loc : Loc.t
- ; dir : string
- }
+ module Into = struct
+ type t =
+ { loc : Loc.t
+ ; dir : string
+ }
+
+ let decode =
+ let+ (loc, dir) = located relative_file in
+ { loc
+ ; dir
+ }
+ end
- let decode =
- let+ (loc, dir) = located relative_file in
- { loc
- ; dir
+ type t =
+ { lifetime : Lifetime.t
+ ; into : Into.t option
+ ; only : Predicate_lang.t option
}
end
type t =
| Standard
| Fallback
- | Promote of Promotion_lifetime.t * Into.t option
- | Not_a_rule_stanza
+ | Promote of Promote.t
| Ignore_source_files
let decode =
let promote_into lifetime =
let+ () = Syntax.since Stanza.syntax (1, 8)
- and+ into = Into.decode in
- Promote (lifetime, Some into)
+ and+ into = Promote.Into.decode in
+ Promote { lifetime; into = Some into; only = None }
in
sum
[ "standard" , return Standard
; "fallback" , return Fallback
- ; "promote" , return (Promote (Unlimited, None))
- ; "promote-until-clean", return (Promote (Until_clean, None))
+ ; "promote" ,
+ fields
+ (let+ until_clean =
+ field_b "until-clean"
+ ~check:(Syntax.since Stanza.syntax (1, 10))
+ and+ into =
+ field_o "into"
+ (Syntax.since Stanza.syntax (1, 10) >>= fun () ->
+ Promote.Into.decode)
+ and+ only =
+ field_o "only"
+ (Syntax.since Stanza.syntax (1, 10) >>= fun () ->
+ Predicate_lang.decode)
+ in
+ Promote
+ { lifetime = if until_clean then Until_clean else Unlimited
+ ; into
+ ; only
+ })
+ ; "promote-until-clean",
+ return (Promote { lifetime = Until_clean
+ ; into = None
+ ; only = None
+ })
; "promote-into" , promote_into Unlimited
; "promote-until-clean-into", promote_into Until_clean
]
diff --git a/src/dune_file.mli b/src/dune_file.mli
index 3bb86eda124..dacd694c8d1 100644
--- a/src/dune_file.mli
+++ b/src/dune_file.mli
@@ -297,17 +297,25 @@ module Rule : sig
end
module Mode : sig
- module Promotion_lifetime : sig
- type t =
- | Unlimited
- (** The promoted file will be deleted by [dune clean] *)
- | Until_clean
- end
+ module Promote : sig
+ module Lifetime : sig
+ type t =
+ | Unlimited
+ (** The promoted file will be deleted by [dune clean] *)
+ | Until_clean
+ end
+
+ module Into : sig
+ type t =
+ { loc : Loc.t
+ ; dir : string
+ }
+ end
- module Into : sig
type t =
- { loc : Loc.t
- ; dir : string
+ { lifetime : Lifetime.t
+ ; into : Into.t option
+ ; only : Predicate_lang.t option
}
end
@@ -315,17 +323,14 @@ module Rule : sig
| Standard
(** Only use this rule if the source files don't exist. *)
| Fallback
- (** Silently promote the targets to the source tree. If the argument is
- [Some { dir ; _ }], promote them into [dir] rather than the current
- directory. *)
- | Promote of Promotion_lifetime.t * Into.t option
- (** Same as [Standard] however this is not a rule stanza, so it
- is not possible to add a [(fallback)] field to the rule. *)
- | Not_a_rule_stanza
+ (** Silently promote the targets to the source tree. *)
+ | Promote of Promote.t
(** Just ignore the source files entirely. This is for cases
where the targets are promoted only in a specific context,
such as for .install files. *)
| Ignore_source_files
+
+ val decode : t Dune_lang.Decoder.t
end
type t =
diff --git a/src/dune_load.ml b/src/dune_load.ml
index 8e71c05eafb..b1b7479526b 100644
--- a/src/dune_load.ml
+++ b/src/dune_load.ml
@@ -15,8 +15,8 @@ module Dune_file = struct
let stanzas =
if ignore_promoted_rules then
List.filter stanzas ~f:(function
- | Rule { mode = Promote _; _ }
- | Dune_file.Menhir.T { mode = Promote _; _ } -> false
+ | Rule { mode = Promote { only = None; _ }; _ }
+ | Dune_file.Menhir.T { mode = Promote { only = None; _ }; _ } -> false
| _ -> true)
else
stanzas
diff --git a/src/install_rules.ml b/src/install_rules.ml
index df35ec4655a..a9f9b12f1ee 100644
--- a/src/install_rules.ml
+++ b/src/install_rules.ml
@@ -330,7 +330,7 @@ let install_file sctx (package : Local_package.t) entries =
|> Path.Set.of_list);
Super_context.add_rule sctx ~dir:pkg_build_dir
~mode:(if promote_install_file ctx then
- Promote (Until_clean, None)
+ Promote { lifetime = Until_clean; into = None; only = None }
else
(* We must ignore the source file since it might be
copied to the source tree by another context. *)
diff --git a/src/merlin.ml b/src/merlin.ml
index 91ece4781ce..09d137369ef 100644
--- a/src/merlin.ml
+++ b/src/merlin.ml
@@ -187,7 +187,12 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
Build.create_file (Path.relative dir ".merlin-exists"));
Path.Set.singleton merlin_file
|> Build_system.Alias.add_deps (Alias.check ~dir);
- SC.add_rule sctx ~dir ~mode:(Promote (Until_clean, None)) (
+ SC.add_rule sctx ~dir
+ ~mode:(Promote
+ { lifetime = Until_clean
+ ; into = None
+ ; only = None
+ }) (
flags
>>^ (fun flags ->
let (src_dirs, obj_dirs) =
@@ -196,9 +201,9 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
( Path.Set.add src_dirs (
Lib.orig_src_dir lib
|> Path.drop_optional_build_context)
- ,
- Path.Set.add obj_dirs (Lib.public_cmi_dir lib)
- ))
+ ,
+ Path.Set.add obj_dirs (Lib.public_cmi_dir lib)
+ ))
in
let src_dirs =
Path.Set.union src_dirs (Path.Set.of_list more_src_dirs)
diff --git a/src/predicate_lang.ml b/src/predicate_lang.ml
index 0f9a11b5481..de3170fee27 100644
--- a/src/predicate_lang.ml
+++ b/src/predicate_lang.ml
@@ -90,26 +90,28 @@ let decode : t Dune_lang.Decoder.t =
let empty = Ast.Union []
-let rec mem t ~standard ~elem =
+let rec exec t ~standard elem =
match (t : _ Ast.t) with
- | Compl t -> not (mem t ~standard ~elem)
+ | Compl t -> not (exec t ~standard elem)
| Element f -> f elem
- | Union xs -> List.exists ~f:(mem ~standard ~elem) xs
- | Inter xs -> List.for_all ~f:(mem ~standard ~elem) xs
- | Standard -> mem standard ~standard ~elem
+ | Union xs -> List.exists ~f:(fun t -> exec t ~standard elem) xs
+ | Inter xs -> List.for_all ~f:(fun t -> exec t ~standard elem) xs
+ | Standard -> exec standard ~standard elem
let filter (t : t) ~standard elems =
match t with
| Inter []
| Union [] -> []
| _ ->
- (List.filter elems ~f:(fun elem -> mem t ~standard ~elem))
+ (List.filter elems ~f:(fun elem -> exec t ~standard elem))
let union t = Ast.Union t
let of_glob g = Ast.Element (Glob.test g)
let of_pred p = Ast.Element p
+let true_ = of_pred (fun _ -> true)
+let false_ = of_pred (fun _ -> false)
let of_string_set s = Ast.Element (String.Set.mem s)
diff --git a/src/predicate_lang.mli b/src/predicate_lang.mli
index 7b4ec4bb11d..bdf1f29354e 100644
--- a/src/predicate_lang.mli
+++ b/src/predicate_lang.mli
@@ -11,6 +11,13 @@ val decode : t Stanza.Decoder.t
val empty : t
+(** Always return [true] *)
+val true_ : t
+
+(** Always return [false] *)
+val false_ : t
+
+val exec : t -> standard:t -> string -> bool
val filter : t -> standard:t -> string list -> string list
val of_glob : Glob.t -> t
diff --git a/src/rule.ml b/src/rule.ml
index e9907ce1413..2d1a7561d20 100644
--- a/src/rule.ml
+++ b/src/rule.ml
@@ -1,6 +1,17 @@
open! Stdune
open Import
+module Info = struct
+ type t =
+ | From_dune_file of Loc.t
+ | Internal
+ | Source_file_copy
+
+ let of_loc_opt = function
+ | None -> Internal
+ | Some loc -> From_dune_file loc
+end
+
type t =
{ context : Context.t option
; env : Env.t option
@@ -9,30 +20,30 @@ type t =
; sandbox : bool
; mode : Dune_file.Rule.Mode.t
; locks : Path.t list
- ; loc : Loc.t option
+ ; info : Info.t
; dir : Path.t
}
-let make ?(sandbox=false) ?(mode=Dune_file.Rule.Mode.Not_a_rule_stanza)
- ~context ~env ?(locks=[]) ?loc build =
+let make ?(sandbox=false) ?(mode=Dune_file.Rule.Mode.Standard)
+ ~context ~env ?(locks=[]) ?(info=Info.Internal) build =
let targets = Build.targets build in
let dir =
match Path.Set.choose targets with
| None -> begin
- match loc with
- | Some loc -> Errors.fail loc "Rule has no targets specified"
- | None -> Exn.code_error "Build_interpret.Rule.make: no targets" []
+ match info with
+ | From_dune_file loc -> Errors.fail loc "Rule has no targets specified"
+ | _ -> Exn.code_error "Build_interpret.Rule.make: no targets" []
end
| Some x ->
let dir = Path.parent_exn x in
if Path.Set.exists targets ~f:(fun path -> Path.parent_exn path <> dir)
then begin
- match loc with
- | None ->
+ match info with
+ | Internal | Source_file_copy ->
Exn.code_error "rule has targets in different directories"
[ "targets", Path.Set.to_sexp targets
]
- | Some loc ->
+ | From_dune_file loc ->
Errors.fail loc
"Rule has targets in different directories.\nTargets:\n%s"
(String.concat ~sep:"\n"
@@ -49,6 +60,6 @@ let make ?(sandbox=false) ?(mode=Dune_file.Rule.Mode.Not_a_rule_stanza)
; sandbox
; mode
; locks
- ; loc
+ ; info
; dir
}
diff --git a/src/rule.mli b/src/rule.mli
index 817d5589c5b..dce1b7b064c 100644
--- a/src/rule.mli
+++ b/src/rule.mli
@@ -3,6 +3,15 @@
open! Stdune
open! Import
+module Info : sig
+ type t =
+ | From_dune_file of Loc.t
+ | Internal
+ | Source_file_copy
+
+ val of_loc_opt : Loc.t option -> t
+end
+
type t =
{ context : Context.t option
; env : Env.t option
@@ -11,7 +20,7 @@ type t =
; sandbox : bool
; mode : Dune_file.Rule.Mode.t
; locks : Path.t list
- ; loc : Loc.t option
+ ; info : Info.t
; (** Directory where all the targets are produced *)
dir : Path.t
}
@@ -22,6 +31,6 @@ val make
-> context:Context.t option
-> env:Env.t option
-> ?locks:Path.t list
- -> ?loc:Loc.t
+ -> ?info:Info.t
-> (unit, Action.t) Build.t
-> t
diff --git a/src/stanza.ml b/src/stanza.ml
index aba99b997f0..5a0a3386c0e 100644
--- a/src/stanza.ml
+++ b/src/stanza.ml
@@ -9,7 +9,7 @@ end
let syntax =
Syntax.create ~name:"dune" ~desc:"the dune language"
[ (0, 0) (* Jbuild syntax *)
- ; (1, 9)
+ ; (1, 10)
]
module File_kind = struct
diff --git a/src/super_context.ml b/src/super_context.ml
index aaa188a6805..6edc5b3f743 100644
--- a/src/super_context.ml
+++ b/src/super_context.ml
@@ -167,14 +167,16 @@ let add_rule t ?sandbox ?mode ?locks ?loc ~dir build =
let build = Build.O.(>>>) build t.chdir in
let env = Env.external_ t ~dir in
Build_system.add_rule
- (Rule.make ?sandbox ?mode ?locks ?loc
+ (Rule.make ?sandbox ?mode ?locks
+ ~info:(Rule.Info.of_loc_opt loc)
~context:(Some t.context) ~env:(Some env) build)
let add_rule_get_targets t ?sandbox ?mode ?locks ?loc ~dir build =
let build = Build.O.(>>>) build t.chdir in
let env = Env.external_ t ~dir in
let rule =
- Rule.make ?sandbox ?mode ?locks ?loc
+ Rule.make ?sandbox ?mode ?locks
+ ~info:(Rule.Info.of_loc_opt loc)
~context:(Some t.context) ~env:(Some env) build
in
Build_system.add_rule rule;
diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc
index 4c4cd5bae97..f0395a01d9d 100644
--- a/test/blackbox-tests/dune.inc
+++ b/test/blackbox-tests/dune.inc
@@ -603,6 +603,14 @@
test-cases/github2033
(progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+(alias
+ (name github2061)
+ (deps (package dune) (source_tree test-cases/github2061))
+ (action
+ (chdir
+ test-cases/github2061
+ (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
(alias
(name github24)
(deps (package dune) (source_tree test-cases/github24))
@@ -1462,6 +1470,7 @@
(alias github1946)
(alias github20)
(alias github2033)
+ (alias github2061)
(alias github24)
(alias github25)
(alias github534)
@@ -1627,6 +1636,7 @@
(alias github1946)
(alias github20)
(alias github2033)
+ (alias github2061)
(alias github24)
(alias github25)
(alias github534)
diff --git a/test/blackbox-tests/test-cases/dune-init/run.t b/test/blackbox-tests/test-cases/dune-init/run.t
index ad6a030003e..277aa01807c 100644
--- a/test/blackbox-tests/test-cases/dune-init/run.t
+++ b/test/blackbox-tests/test-cases/dune-init/run.t
@@ -10,7 +10,7 @@ Can build the public library
$ cd _test_lib_dir && touch test_lib.opam && dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
| (name test_lib)
$ cat ./_test_lib_dir/dune
@@ -62,7 +62,7 @@ Can build an executable
$ cd _test_bin_dir && touch test_bin.opam && dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
| (name test_bin)
@@ -143,7 +143,7 @@ Can build the combo project
$ cd _test_lib_exe_dir && touch test_bin.opam && dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
| (name test_bin)
@@ -177,7 +177,7 @@ Can build the multiple library project
$ cd _test_lib && touch test_lib1.opam && dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
| (name test_lib1)
diff --git a/test/blackbox-tests/test-cases/dune-package/run.t b/test/blackbox-tests/test-cases/dune-package/run.t
index 931d126c075..97098a08bf3 100644
--- a/test/blackbox-tests/test-cases/dune-package/run.t
+++ b/test/blackbox-tests/test-cases/dune-package/run.t
@@ -1,6 +1,6 @@
$ dune build
$ cat _build/install/default/lib/a/dune-package
- (lang dune 1.9)
+ (lang dune 1.10)
(name a)
(library
(name a)
diff --git a/test/blackbox-tests/test-cases/dune-project-edition/run.t b/test/blackbox-tests/test-cases/dune-project-edition/run.t
index 7dec689439d..ada9b19035d 100644
--- a/test/blackbox-tests/test-cases/dune-project-edition/run.t
+++ b/test/blackbox-tests/test-cases/dune-project-edition/run.t
@@ -4,10 +4,10 @@
$ echo '(alias (name runtest) (action (progn)))' > src/dune
$ dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
$ cat dune-project
- (lang dune 1.9)
+ (lang dune 1.10)
Test that using menhir automatically update the dune-project file
@@ -15,5 +15,5 @@ Test that using menhir automatically update the dune-project file
$ dune build
Info: appending this line to dune-project: (using menhir 2.0)
$ cat dune-project
- (lang dune 1.9)
+ (lang dune 1.10)
(using menhir 2.0)
diff --git a/test/blackbox-tests/test-cases/github1529/run.t b/test/blackbox-tests/test-cases/github1529/run.t
index 80391f717a1..6001ecc3779 100644
--- a/test/blackbox-tests/test-cases/github1529/run.t
+++ b/test/blackbox-tests/test-cases/github1529/run.t
@@ -3,6 +3,6 @@ file is present.
$ dune build
Info: creating file dune-project with this contents:
- | (lang dune 1.9)
+ | (lang dune 1.10)
Info: appending this line to dune-project: (using menhir 2.0)
diff --git a/test/blackbox-tests/test-cases/github1549/run.t b/test/blackbox-tests/test-cases/github1549/run.t
index 5eda7c79de1..7eeab3c9375 100644
--- a/test/blackbox-tests/test-cases/github1549/run.t
+++ b/test/blackbox-tests/test-cases/github1549/run.t
@@ -4,7 +4,7 @@ Reproduction case for #1549: too many parentheses in installed .dune files
Entering directory 'backend'
$ cat backend/_build/install/default/lib/dune_inline_tests/dune-package
- (lang dune 1.9)
+ (lang dune 1.10)
(name dune_inline_tests)
(library
(name dune_inline_tests)
diff --git a/test/blackbox-tests/test-cases/github2061/a b/test/blackbox-tests/test-cases/github2061/a
new file mode 100644
index 00000000000..11b531f9db4
--- /dev/null
+++ b/test/blackbox-tests/test-cases/github2061/a
@@ -0,0 +1 @@
+SOURCE
diff --git a/test/blackbox-tests/test-cases/github2061/dune b/test/blackbox-tests/test-cases/github2061/dune
new file mode 100644
index 00000000000..55487147488
--- /dev/null
+++ b/test/blackbox-tests/test-cases/github2061/dune
@@ -0,0 +1,4 @@
+(rule
+ (progn
+ (with-stdout-to a (echo "GENERATED"))
+ (with-stdout-to b (echo "GENERATED"))))
diff --git a/test/blackbox-tests/test-cases/github2061/run.t b/test/blackbox-tests/test-cases/github2061/run.t
new file mode 100644
index 00000000000..11382d14ecd
--- /dev/null
+++ b/test/blackbox-tests/test-cases/github2061/run.t
@@ -0,0 +1,53 @@
+Reproduction case for #2061. Make sure dune behaves sensibly when a rule
+in standard mode produces multiple files and only a strict subset of them is in
+the source tree.
+
+Dune < 1.10
+-----------
+
+ $ echo '(lang dune 1.9)' > dune-project
+
+ $ dune build a
+ File "dune", line 1, characters 0-95:
+ 1 | (rule
+ 2 | (progn
+ 3 | (with-stdout-to a (echo "GENERATED"))
+ 4 | (with-stdout-to b (echo "GENERATED"))))
+ Warning: The following files are both generated by a rule and are present in
+ the source tree:
+ - a
+ Because your project was written for dune 1.9, I am closing my eyes on this
+ and I am overwriting the source files with the generated one. However, you
+ should really delete these files from your source tree. I will no longer
+ accept this once you upgrade your project to dune >= 1.10.
+ $ cat _build/default/a
+ GENERATED
+
+Building b shouldn't erase a:
+
+ $ dune build b
+ File "dune", line 1, characters 0-95:
+ 1 | (rule
+ 2 | (progn
+ 3 | (with-stdout-to a (echo "GENERATED"))
+ 4 | (with-stdout-to b (echo "GENERATED"))))
+ Warning: The following files are both generated by a rule and are present in
+ the source tree:
+ - a
+ Because your project was written for dune 1.9, I am closing my eyes on this
+ and I am overwriting the source files with the generated one. However, you
+ should really delete these files from your source tree. I will no longer
+ accept this once you upgrade your project to dune >= 1.10.
+ $ cat _build/default/a
+ GENERATED
+
+Dune >= 1.10
+------------
+
+ $ echo '(lang dune 1.10)' > dune-project
+ $ dune build a
+ Multiple rules generated for _build/default/a:
+ - dune:1
+ - file present in source tree
+ Hint: rm -f a
+ [1]
diff --git a/test/blackbox-tests/test-cases/inline_tests/run.t b/test/blackbox-tests/test-cases/inline_tests/run.t
index 974192cba1d..41010198003 100644
--- a/test/blackbox-tests/test-cases/inline_tests/run.t
+++ b/test/blackbox-tests/test-cases/inline_tests/run.t
@@ -25,7 +25,7 @@
backend_mbc1
$ dune runtest dune-file
- (lang dune 1.9)
+ (lang dune 1.10)
(name foo)
(library
(name foo)
diff --git a/test/blackbox-tests/test-cases/promote/dune b/test/blackbox-tests/test-cases/promote/dune
index a84298072dc..5c4f670ca51 100644
--- a/test/blackbox-tests/test-cases/promote/dune
+++ b/test/blackbox-tests/test-cases/promote/dune
@@ -14,3 +14,11 @@
(targets promoted)
(action (with-stdout-to promoted (echo "Hello, world!")))
(mode (promote-into subdir)))
+
+(rule
+ (targets only1 only2)
+ (action
+ (progn
+ (with-stdout-to only1 (echo "0"))
+ (with-stdout-to only2 (echo "0"))))
+ (mode (promote (only *1))))
diff --git a/test/blackbox-tests/test-cases/promote/dune-project b/test/blackbox-tests/test-cases/promote/dune-project
index bfe19a20268..42c0c167431 100644
--- a/test/blackbox-tests/test-cases/promote/dune-project
+++ b/test/blackbox-tests/test-cases/promote/dune-project
@@ -1 +1 @@
-(lang dune 1.8)
+(lang dune 1.10)
diff --git a/test/blackbox-tests/test-cases/promote/run.t b/test/blackbox-tests/test-cases/promote/run.t
index 46060f3fdb3..3eea19e8c17 100644
--- a/test/blackbox-tests/test-cases/promote/run.t
+++ b/test/blackbox-tests/test-cases/promote/run.t
@@ -84,3 +84,12 @@ Tests for promote-into
$ dune build promoted
$ cat subdir/promoted
Hello, world!
+
+Test for (promote (only ...))
+-----------------------------
+
+Only "only1" should be promoted in the source tree:
+
+ $ dune build only2
+ $ ls -1 only*
+ only1
diff --git a/test/blackbox-tests/test-cases/variants/run.t b/test/blackbox-tests/test-cases/variants/run.t
index 34063c17084..4b73da7b0bf 100644
--- a/test/blackbox-tests/test-cases/variants/run.t
+++ b/test/blackbox-tests/test-cases/variants/run.t
@@ -42,7 +42,7 @@ Check that variant data is installed in the dune package file.
$ dune build --root dune-package
Entering directory 'dune-package'
$ cat dune-package/_build/install/default/lib/a/dune-package
- (lang dune 1.9)
+ (lang dune 1.10)
(name a)
(library
(name a)
diff --git a/test/blackbox-tests/test-cases/vlib-default-impl/run.t b/test/blackbox-tests/test-cases/vlib-default-impl/run.t
index debc745d148..a428b9f3215 100644
--- a/test/blackbox-tests/test-cases/vlib-default-impl/run.t
+++ b/test/blackbox-tests/test-cases/vlib-default-impl/run.t
@@ -34,7 +34,7 @@ Check that default implementation data is installed in the dune package file.
$ dune build --root dune-package
Entering directory 'dune-package'
$ cat dune-package/_build/install/default/lib/a/dune-package
- (lang dune 1.9)
+ (lang dune 1.10)
(name a)
(library
(name a)
diff --git a/test/blackbox-tests/test-cases/vlib/run.t b/test/blackbox-tests/test-cases/vlib/run.t
index e5d7e1dac8d..f200948a6f3 100644
--- a/test/blackbox-tests/test-cases/vlib/run.t
+++ b/test/blackbox-tests/test-cases/vlib/run.t
@@ -305,7 +305,7 @@ Implement external virtual libraries with private modules
Include variants and implementation information in dune-package
$ dune build --root dune-package-info
Entering directory 'dune-package-info'
- (lang dune 1.9)
+ (lang dune 1.10)
(name foo)
(library
(name foo.impl)