Better behavior when the targets of a rule already exist in the source tree (#218)

Warn when a file is both present in the source tree and generated by
a rule. Before, jbuilder would silently ignore the rule. One now has
to add a field `(fallback)` to custom rules to keep the current
behavior.

CHANGES.md

@@ -29,6 +29,11 @@
   was renamed `per_module` and it is planned to reuse `per_file` for
   another purpose
 
+- Warn when a file is both present in the source tree and generated by
+  a rule. Before, jbuilder would silently ignore the rule. One now has
+  to add a field `(fallback)` to custom rules to keep the current
+  behavior (#218)
+
 1.0+beta11 (21/07/2017)
 -----------------------
 

doc/jbuild.rst

@@ -280,18 +280,27 @@ The syntax is as follows:
 
     (rule
       ((targets (<filenames>))
-       (deps    (<deps-conf list>))
+       (action  <action>)
-       (action  <action>)))
+       <optional-fields>))
 
 ``<filenames>`` is a list of file names. Note that currently Jbuilder only
 support user rules with targets in the current directory.
 
-``<deps-conf list>`` specifies the dependencies of the rule. See the `Dependency
-specification`_ section for more details.
-
 ``<action>`` is the action to run to produce the targets from the dependencies.
 See the `User actions`_ section for more details.
 
+``<optional-fields>`` are:
+
+- ``(deps (<deps-conf list>))`` to specify the dependencies of the
+  rule. See the `Dependency specification`_ section for more details.
+
+- ``(fallback)`` to specify that this is a fallback rule. A fallback
+  rule means that if the targets are already present in the source
+  tree, jbuilder will ignore the rule. It is an error if only a subset
+  of the targets are present in the tree. The common use of fallback
+  rules is to generate default configuration files that may be
+  generated by a configure script.
+
 Note that contrary to makefiles or other build systems, user rules currently
 don't support patterns, such as a rule to produce ``%.y`` from ``%.x`` for any
 given ``%``. This might be supported in the future.

example/sample-projects/with-configure-step/jbuild

@@ -1,7 +1,8 @@
 (jbuild_version 1)
 
 (rule
- ((targets (config))
+ ((fallback)
+  (targets (config))
   (deps    (config.defaults))
   (action  (copy ${<} ${@}))))
 

src/build_interpret.ml

@@ -149,16 +149,21 @@ let targets =
 
 module Rule = struct
   type t =
-    { context : Context.t option
+    { context  : Context.t option
-    ; build   : (unit, Action.t) Build.t
+    ; build    : (unit, Action.t) Build.t
-    ; targets : Target.t list
+    ; targets  : Target.t list
-    ; sandbox : bool
+    ; sandbox  : bool
+    ; fallback : Jbuild.Rule.Fallback.t
+    ; loc      : Loc.t option
     }
 
-  let make ?(sandbox=false) ?context build =
+  let make ?(sandbox=false) ?(fallback=Jbuild.Rule.Fallback.Not_possible)
+        ?context ?loc build =
     { context
     ; build
     ; targets = targets build
     ; sandbox
+    ; fallback
+    ; loc
     }
 end

src/build_interpret.mli

@@ -11,13 +11,21 @@ end
 
 module Rule : sig
   type t =
-    { context : Context.t option
+    { context  : Context.t option
-    ; build   : (unit, Action.t) Build.t
+    ; build    : (unit, Action.t) Build.t
-    ; targets : Target.t list
+    ; targets  : Target.t list
-    ; sandbox : bool
+    ; sandbox  : bool
+    ; fallback : Jbuild.Rule.Fallback.t
+    ; loc      : Loc.t option
     }
 
-  val make : ?sandbox:bool -> ?context:Context.t -> (unit, Action.t) Build.t -> t
+  val make
+    :  ?sandbox:bool
+    -> ?fallback:Jbuild.Rule.Fallback.t
+    -> ?context:Context.t
+    -> ?loc:Loc.t
+    -> (unit, Action.t) Build.t
+    -> t
 end
 
 module Static_deps : sig

src/build_system.ml

@@ -58,17 +58,36 @@ module Internal_rule = struct
       n
   end
 
+  module Fallback_status = struct
+    type t =
+      (* The argument is the set of targets that are already present in the source
+         tree.  *)
+      | Yes of Pset.t
+      | No
+      | Not_possible
+  end
+
   type t =
-    { id             : Id.t
+    { id               : Id.t
-    ; rule_deps      : Pset.t
+    ; rule_deps        : Pset.t
-    ; static_deps    : Pset.t
+    ; static_deps      : Pset.t
-    ; targets        : Pset.t
+    ; targets          : Pset.t
-    ; context        : Context.t option
+    ; context          : Context.t option
-    ; build          : (unit, Action.t) Build.t
+    ; build            : (unit, Action.t) Build.t
-    ; mutable exec   : Exec_status.t
+    ; mutable fallback : Fallback_status.t
+    ; loc              : Loc.t option
+    ; mutable exec     : Exec_status.t
     }
 
   let compare a b = Id.compare a.id b.id
+
+  let loc ~dir t =
+    match t.loc with
+    | Some loc -> loc
+    | None ->
+      Loc.in_file
+        (Path.to_string
+           (Path.drop_build_context (Path.relative dir "jbuild")))
 end
 
 module File_kind = struct
@@ -324,17 +343,50 @@ module Build_exec = struct
     (action, !dyn_deps)
 end
 
-let add_spec t fn spec ~allow_override =
+(* This variable is filled during the creation of the build system. Once the build system
-  if not allow_override && Hashtbl.mem t.files fn then
+   is created, we check that all the fallback rules that got disabled are completely
-    die "multiple rules generated for %s" (Path.to_string fn);
+   disabled, i.e. that all their targets already exist in the source tree. *)
-  Hashtbl.add t.files ~key:fn ~data:spec
+let disabled_fallback_rules = ref []
 
-let create_file_specs t targets rule ~allow_override =
+(* [copy_source] is [true] for rules copying files from the source directory *)
+let add_spec t fn spec ~copy_source =
+  match Hashtbl.find t.files fn with
+  | None ->
+    Hashtbl.add t.files ~key:fn ~data:spec
+  | Some (File_spec.T { rule; _ }) ->
+    match copy_source, rule.fallback with
+    | true, Yes already_present ->
+      if Pset.is_empty already_present then
+        disabled_fallback_rules := rule :: !disabled_fallback_rules;
+      rule.fallback <- Yes (Pset.add fn already_present);
+      Hashtbl.add t.files ~key:fn ~data:spec
+    | true, (No | Not_possible) ->
+      Loc.warn (Internal_rule.loc rule ~dir:(Path.parent fn))
+        "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"
+        (maybe_quoted (Path.basename fn))
+        (fun ppf ->
+           match rule.fallback with
+           | Yes _ -> assert false
+           | Not_possible ->
+             Format.fprintf ppf "Delete file %s to get rid of this warning."
+               (Path.to_string_maybe_quoted (Path.drop_build_context fn))
+           | No ->
+             Format.fprintf ppf
+               "To keep the current behavior and get rid of this warning, add a field \
+                (fallback) to the rule.");
+      Hashtbl.add t.files ~key:fn ~data:spec
+    | false, _ ->
+      die "multiple rules generated for %s" (Path.to_string_maybe_quoted fn)
+
+let create_file_specs t targets rule ~copy_source =
   List.iter targets ~f:(function
     | Target.Normal fn ->
-      add_spec t fn (File_spec.create rule Ignore_contents) ~allow_override
+      add_spec t fn (File_spec.create rule Ignore_contents) ~copy_source
     | Target.Vfile (Vspec.T (fn, kind)) ->
-      add_spec t fn (File_spec.create rule (Sexp_file kind)) ~allow_override)
+      add_spec t fn (File_spec.create rule (Sexp_file kind)) ~copy_source)
 
 module Pre_rule = Build_interpret.Rule
 
@@ -391,8 +443,17 @@ let make_local_parent_dirs t paths ~map_path =
 
 let sandbox_dir = Path.of_string "_build/.sandbox"
 
-let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
+let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule =
-  let { Pre_rule. context; build; targets = target_specs; sandbox } = pre_rule in
+  let { Pre_rule.
+        context
+      ; build
+      ; targets = target_specs
+      ; sandbox
+      ; fallback
+      ; loc
+      } =
+    pre_rule
+  in
   let targets = Target.paths target_specs in
   let { Build_interpret.Static_deps.
         rule_deps
@@ -509,9 +570,14 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
     ; build
     ; context
     ; exec = Not_started { eval_rule; exec_rule }
+    ; fallback = (match fallback with
+      | Yes -> Yes Pset.empty
+      | No -> No
+      | Not_possible -> Not_possible)
+    ; loc
     }
   in
-  create_file_specs t target_specs rule ~allow_override
+  create_file_specs t target_specs rule ~copy_source
 
 let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
   List.iter t.contexts ~f:(fun (ctx : Context.t) ->
@@ -532,7 +598,7 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
            should allow it on a case-by-case basis though.  *)
         compile_rule t (Pre_rule.make build)
           ~all_targets_by_dir
-          ~allow_override:true))
+          ~copy_source:true))
 
 module Trace = struct
   type t = (Path.t, Digest.t) Hashtbl.t
@@ -613,10 +679,45 @@ let create ~contexts ~file_tree ~rules =
     ; timestamps = Hashtbl.create 1024
     ; local_mkdirs = Path.Local.Set.empty
     } in
-  List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
+  List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~copy_source:false);
   setup_copy_rules t ~all_targets_by_dir
     ~all_non_target_source_files:
       (Pset.diff all_source_files all_other_targets);
+
+  (let l = !disabled_fallback_rules in
+   disabled_fallback_rules := [];
+   List.iter l ~f:(fun rule ->
+     let disabled_for =
+       match rule.Internal_rule.fallback with
+       | No | Not_possible -> assert false
+       | Yes paths -> paths
+     in
+     let leftover_targets = Pset.diff rule.targets disabled_for in
+     if not (Pset.is_empty leftover_targets) then begin
+       let list_paths set =
+         Pset.elements set
+         |> List.map ~f:(fun p -> sprintf "- %s"
+                                    (Path.to_string_maybe_quoted
+                                       (Path.drop_build_context p)))
+         |> String.concat ~sep:"\n"
+       in
+       Loc.fail (Internal_rule.loc rule ~dir:(Path.parent (Pset.choose leftover_targets)))
+         "\
+Some of the targets of this fallback rule are present in the source tree,
+and some are not. This is not allowed. Either none of the targets must
+be present in the source tree, either they must all be.
+
+The following targets are present:
+%s
+
+The following targets are not:
+%s
+"
+         (list_paths disabled_for)
+         (list_paths leftover_targets)
+     end
+   ));
+
   at_exit (fun () -> dump_trace t);
   t
 

src/gen_rules.ml

@@ -528,7 +528,7 @@ module Gen(P : Params) = struct
       | Infer -> Infer
       | Static fns -> Static (List.map fns ~f:(Path.relative dir))
     in
-    SC.add_rule sctx
+    SC.add_rule sctx ~fallback:rule.fallback ~loc:rule.loc
       (SC.Deps.interpret sctx ~scope ~dir rule.deps
        >>>
        SC.Action.run

src/import.ml

@@ -191,6 +191,10 @@ module String_map = Map.Make(String)
 module String = struct
   include StringLabels
 
+  let break s ~pos =
+    (sub s ~pos:0 ~len:pos,
+     sub s ~pos ~len:(String.length s - pos))
+
   let is_prefix s ~prefix =
     let len = length s in
     let prefix_len = length prefix in

src/jbuild.ml

@@ -710,28 +710,45 @@ module Rule = struct
       | Infer
   end
 
+  module Fallback = struct
+    type t =
+      | Yes
+      | No
+      | Not_possible
+  end
+
   type t =
-    { targets : Targets.t
+    { targets  : Targets.t
-    ; deps    : Dep_conf.t list
+    ; deps     : Dep_conf.t list
-    ; action  : Action.Unexpanded.t
+    ; action   : Action.Unexpanded.t
+    ; fallback : Fallback.t
+    ; loc      : Loc.t
     }
 
   let v1 sexp =
     match sexp with
     | List (_, (Atom _ :: _)) ->
-      { targets = Infer
+      { targets  = Infer
-      ; deps    = []
+      ; deps     = []
-      ; action  = Action.Unexpanded.t sexp
+      ; action   = Action.Unexpanded.t sexp
+      ; fallback = No
+      ; loc = Loc.none
       }
     | _ ->
       record
         (field "targets" (list file_in_current_dir)    >>= fun targets ->
          field "deps"    (list Dep_conf.t) ~default:[] >>= fun deps ->
          field "action"  Action.Unexpanded.t           >>= fun action ->
-         return { targets = Static targets; deps; action })
+         field_b "fallback" >>= fun fallback ->
+         return { targets = Static targets
+                ; deps
+                ; action
+                ; fallback = if fallback then Yes else No
+                ; loc = Loc.none
+                })
         sexp
 
-  let ocamllex_v1 names =
+  let ocamllex_v1 loc names =
     let module S = String_with_vars in
     List.map names ~f:(fun name ->
       let src = name ^ ".mll" in
@@ -747,9 +764,11 @@ module Rule = struct
                   ; S.virt_var __POS__ "@"
                   ; S.virt_var __POS__"<"
                   ]))
+      ; fallback = Not_possible
+      ; loc
       })
 
-  let ocamlyacc_v1 names =
+  let ocamlyacc_v1 loc names =
     let module S = String_with_vars in
     List.map names ~f:(fun name ->
       let src = name ^ ".mly" in
@@ -760,6 +779,8 @@ module Rule = struct
             (S.virt_var __POS__ "ROOT",
              Run (S.virt_text __POS__ "ocamlyacc",
                   [S.virt_var __POS__ "<"]))
+      ; fallback = Not_possible
+      ; loc
       })
 end
 
@@ -782,7 +803,7 @@ module Menhir = struct
          }
       )
 
-  let v1_to_rule t =
+  let v1_to_rule loc t =
     let module S = String_with_vars in
     let targets n = [n ^ ".ml"; n ^ ".mli"] in
     match t.merge_into with
@@ -797,7 +818,9 @@ module Menhir = struct
               (S.virt_var __POS__ "ROOT",
                Run (S.virt_text __POS__ "menhir",
                     t.flags @ [S.virt_var __POS__ "<"]))
-        })
+       ; fallback = Not_possible
+       ; loc
+       })
     | Some merge_into ->
       let mly m = S.virt_text __POS__ (m ^ ".mly") in
       [{ Rule.
@@ -813,6 +836,8 @@ module Menhir = struct
                    @ t.flags
                    @ (List.map ~f:mly t.modules))
              )
+       ; fallback = Not_possible
+       ; loc
        }]
 end
 
@@ -882,10 +907,10 @@ module Stanza = struct
       [ cstr "library"     (Library.v1 pkgs @> nil)      (fun x -> [Library     x])
       ; cstr "executable"  (Executables.v1_single pkgs @> nil) execs
       ; cstr "executables" (Executables.v1_multi  pkgs @> nil) execs
-      ; cstr "rule"        (Rule.v1 @> nil)              (fun x -> [Rule        x])
+      ; cstr_loc "rule"      (Rule.v1     @> nil) (fun loc x -> [Rule { x with loc }])
-      ; cstr "ocamllex"    (list string @> nil)          (fun x -> rules (Rule.ocamllex_v1  x))
+      ; cstr_loc "ocamllex"  (list string @> nil) (fun loc x -> rules (Rule.ocamllex_v1  loc x))
-      ; cstr "ocamlyacc"   (list string @> nil)          (fun x -> rules (Rule.ocamlyacc_v1 x))
+      ; cstr_loc "ocamlyacc" (list string @> nil) (fun loc x -> rules (Rule.ocamlyacc_v1 loc x))
-      ; cstr "menhir"      (Menhir.v1 @> nil)            (fun x -> rules (Menhir.v1_to_rule x))
+      ; cstr_loc "menhir"    (Menhir.v1   @> nil) (fun loc x -> rules (Menhir.v1_to_rule loc x))
       ; cstr "install"     (Install_conf.v1 pkgs @> nil) (fun x -> [Install     x])
       ; cstr "alias"       (Alias_conf.v1 pkgs @> nil)   (fun x -> [Alias       x])
       (* Just for validation and error messages *)

src/jbuild.mli

@@ -188,10 +188,21 @@ module Rule : sig
       | Infer
   end
 
+  module Fallback : sig
+    type t =
+      | Yes
+      | No
+      | Not_possible
+      (** It is not possible to add a [(fallback)] field to the rule. For instance for
+          [ocamllex], ... *)
+  end
+
   type t =
-    { targets : Targets.t
+    { targets  : Targets.t
-    ; deps    : Dep_conf.t list
+    ; deps     : Dep_conf.t list
-    ; action  : Action.Unexpanded.t
+    ; action   : Action.Unexpanded.t
+    ; fallback : Fallback.t
+    ; loc      : Loc.t
     }
 end
 

src/super_context.ml

@@ -213,9 +213,9 @@ let create
       | _ -> Chdir (context.build_dir, action))
   }
 
-let add_rule t ?sandbox build =
+let add_rule t ?sandbox ?fallback ?loc build =
   let build = Build.O.(>>>) build t.chdir in
-  let rule = Build_interpret.Rule.make ?sandbox ~context:t.context build in
+  let rule = Build_interpret.Rule.make ?sandbox ?fallback ?loc ~context:t.context build in
   t.rules <- rule :: t.rules;
   t.known_targets_by_src_dir_so_far <-
     List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far

src/super_context.mli

@@ -41,8 +41,18 @@ val cxx_flags : t -> string list
 
 val expand_vars : t -> scope:Scope.t -> dir:Path.t -> String_with_vars.t -> string
 
-val add_rule : t -> ?sandbox:bool -> (unit, Action.t) Build.t -> unit
+val add_rule
-val add_rules : t -> ?sandbox:bool -> (unit, Action.t) Build.t list -> unit
+  :  t
+  -> ?sandbox:bool
+  -> ?fallback:Jbuild.Rule.Fallback.t
+  -> ?loc:Loc.t
+  -> (unit, Action.t) Build.t
+  -> unit
+val add_rules
+  :  t
+  -> ?sandbox:bool
+  -> (unit, Action.t) Build.t list
+  -> unit
 val rules : t -> Build_interpret.Rule.t list
 
 val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t