Expose the promote mode (#437)

CHANGES.md

@@ -70,6 +70,18 @@
 - Use /Fo instead of -o when invoking the Microsoft C compiler to eliminate
   deprecation warning when compiling C++ sources (#354)
 
+- Add a mode field to `rule` stanzas:
+  + `(mode standard)` is the default
+  + `(mode fallback)` replaces `(fallback)`
+  + `(mode promote)` means that targets are copied to the source tree
+  after the rule has completed
+  + `(mode promote-until-clean)` is the same as `(mode promote)` except
+  that `jbuilder clean` deletes the files copied to the source tree.
+  (#437)
+
+- Add a flag `--ignore-promoted-rules` to make jbuilder ignore rules
+  with `(mode promote)`. `-p` implies `--ignore-promoted-rules` (#437)
+
 - Display a warning for invalid lines in jbuild-ignore (#389)
 
 1.0+beta16 (05/11/2017)

bin/main.ml

@@ -10,23 +10,24 @@ let (>>=) = Future.(>>=)
 let (>>|) = Future.(>>|)
 
 type common =
-  { concurrency      : int
+  { concurrency           : int
-  ; debug_dep_path   : bool
+  ; debug_dep_path        : bool
-  ; debug_findlib    : bool
+  ; debug_findlib         : bool
-  ; debug_backtraces : bool
+  ; debug_backtraces      : bool
-  ; dev_mode         : bool
+  ; dev_mode              : bool
-  ; verbose          : bool
+  ; verbose               : bool
-  ; workspace_file   : string option
+  ; workspace_file        : string option
-  ; root             : string
+  ; root                  : string
-  ; target_prefix    : string
+  ; target_prefix         : string
-  ; only_packages    : String_set.t option
+  ; only_packages         : String_set.t option
-  ; capture_outputs  : bool
+  ; capture_outputs       : bool
-  ; x                : string option
+  ; x                     : string option
-  ; diff_command     : string option
+  ; diff_command          : string option
-  ; auto_promote     : bool
+  ; auto_promote          : bool
-  ; force            : bool
+  ; force                 : bool
+  ; ignore_promoted_rules : bool
   ; (* Original arguments for the external-lib-deps hint *)
-    orig_args        : string list
+    orig_args             : string list
   }
 
 let prefix_target common s = common.target_prefix ^ s
@@ -82,6 +83,7 @@ module Main = struct
       ?only_packages:common.only_packages
       ?filter_out_optional_stanzas_with_missing_deps
       ?x:common.x
+      ~ignore_promoted_rules:common.ignore_promoted_rules
       ()
 end
 
@@ -176,7 +178,10 @@ let common =
         diff_command
         auto_promote
         force
-        (root, only_packages, orig)
+        (root,
+         only_packages,
+         ignore_promoted_rules,
+         orig)
         x
     =
     let root, to_cwd =
@@ -205,6 +210,7 @@ let common =
     ; diff_command
     ; auto_promote
     ; force
+    ; ignore_promoted_rules
     ; only_packages =
         Option.map only_packages
           ~f:(fun s -> String_set.of_list (String.split s ~on:','))
@@ -309,6 +315,12 @@ let common =
              ~doc:"Force actions associated to aliases to be re-executed even
                    if their dependencies haven't changed.")
   in
+  let ignore_promoted_rules =
+    Arg.(value
+         & flag
+         & info ["ignore-promoted-rules"] ~docs
+             ~doc:"Ignore rules with (mode promote)")
+  in
   let for_release = "for-release-of-packages" in
   let frop =
     Arg.(value
@@ -320,32 +332,40 @@ let common =
                     packages as well as getting reproducible builds.|})
   in
   let root_and_only_packages =
-    let merge root only_packages release =
+    let merge root only_packages ignore_promoted_rules release =
       let fail opt =
         `Error (true,
                 sprintf
                   "Cannot use -p/--%s and %s simultaneously"
                   for_release opt)
       in
-      match release, root, only_packages with
+      match release, root, only_packages, ignore_promoted_rules with
-      | Some _, Some _, _ -> fail "--root"
+      | Some _, Some _, _, _ -> fail "--root"
-      | Some _, _, Some _ -> fail "--only-packages"
+      | Some _, _, Some _, _ -> fail "--only-packages"
-      | Some pkgs, None, None ->
+      | Some _, _, _, true   -> fail "--ignore-promoted-rules"
+      | Some pkgs, None, None, false ->
         `Ok (Some ".",
              Some pkgs,
+             true,
              ["-p"; pkgs]
             )
-      | None, _, _ ->
+      | None, _, _, _ ->
         `Ok (root,
              only_packages,
+             ignore_promoted_rules,
              List.concat
                [ dump_opt "--root" root
                ; dump_opt "--only-packages" only_packages
+               ; if ignore_promoted_rules then
+                   ["--ignore-promoted-rules"]
+                 else
+                   []
                ])
     in
     Term.(ret (const merge
                $ root
                $ only_packages
+               $ ignore_promoted_rules
                $ frop))
   in
   let x =

doc/jbuild.rst

@@ -294,12 +294,10 @@ See the `User actions`_ section for more details.
 - ``(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
+- ``(mode <mode>)`` to specify how to handle the targets, see `mode`_
-  rule means that if the targets are already present in the source
+  for details
-  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
+- ``(fallback)`` is deprecated and is the same as ``(mode fallback)``
-  rules is to generate default configuration files that may be
-  generated by a configure script.
 
 - ``(locks (<lock-names>))`` specify that the action must be run while
   holding the following locks. See the `Locks`_ section for more details.
@@ -308,6 +306,41 @@ 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.
 
+modes
+~~~~~
+
+By default, the target of a rule must not exist in the source tree and
+Jbuilder will error out when this is the case.
+
+However, it is possible to change this behavior using the ``mode``
+field. The following modes are available:
+
+- ``standard``, this is the standard mode
+
+- ``fallback``, in this mode, when 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.
+
+- ``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
+  ``jbuilder clean`` will remove the promoted files from the source
+  tree
+
+
+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 jbuilder, 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``.
+
 inferred rules
 ~~~~~~~~~~~~~~
 
@@ -359,6 +392,14 @@ ocamllex
        (deps    (<name>.mll))
        (action  (chdir ${ROOT} (run ${bin:ocamllex} -q -o ${<})))))
 
+To use a different rule mode, use the long form:
+
+.. code:: scheme
+
+    (ocamllex
+      ((modules (<names>))
+       (mode    <mode>)))
+
 ocamlyacc
 ---------
 
@@ -371,6 +412,14 @@ ocamlyacc
        (deps    (<name>.mly))
        (action  (chdir ${ROOT} (run ${bin:ocamlyacc} ${<})))))
 
+To use a different rule mode, use the long form:
+
+.. code:: scheme
+
+    (ocamlyacc
+      ((modules (<names>))
+       (mode    <mode>)))
+
 menhir
 ------
 

src/jbuild.ml

@@ -738,6 +738,16 @@ module Rule = struct
       | Promote_but_delete_on_clean
       | Not_a_rule_stanza
       | Ignore_source_files
+
+    let t =
+      enum
+        [ "standard"          , Standard
+        ; "fallback"          , Fallback
+        ; "promote"           , Promote
+        ; "promote-unil-clean", Promote_but_delete_on_clean
+        ]
+
+    let field = field "mode" t ~default:Standard
   end
 
   type t =
@@ -765,19 +775,51 @@ module Rule = struct
          field "deps"    (list Dep_conf.t) ~default:[] >>= fun deps ->
          field "action"  Action.Unexpanded.t           >>= fun action ->
          field "locks"   (list String_with_vars.t) ~default:[] >>= fun locks ->
-         field_b "fallback" >>= fun fallback ->
+         map_validate
+           (field_b "fallback" >>= fun fallback ->
+            field_o "mode" Mode.t >>= fun mode ->
+            return (fallback, mode))
+           ~f:(function
+             | true, Some _ ->
+               Error "Cannot use both (fallback) and (mode ...) at the same time.\n\
+                      (fallback) is the same as (mode fallback), \
+                      please use the latter in new code."
+             | false, Some mode -> Ok mode
+             | true, None -> Ok Fallback
+             | false, None -> Ok Standard)
+         >>= fun mode ->
          return { targets = Static targets
                 ; deps
                 ; action
-                ; mode = if fallback then Fallback else Standard
+                ; mode
                 ; locks
                 ; loc = Loc.none
                 })
         sexp
 
-  let ocamllex_v1 loc names =
+  type lex_or_yacc =
+    { modules : string list
+    ; mode    : Mode.t
+    }
+
+  let ocamllex_v1 sexp =
+    match sexp with
+    | List (_, List (_, _) :: _) ->
+      record
+        (field "modules" (list string) >>= fun modules ->
+         Mode.field >>= fun mode ->
+         return { modules; mode })
+        sexp
+    | _ ->
+      { modules = list string sexp
+      ; mode    = Standard
+      }
+
+  let ocamlyacc_v1 = ocamllex_v1
+
+  let ocamllex_to_rule loc { modules; mode } =
     let module S = String_with_vars in
-    List.map names ~f:(fun name ->
+    List.map modules ~f:(fun name ->
       let src = name ^ ".mll" in
       let dst = name ^ ".ml"  in
       { targets = Static [dst]
@@ -791,14 +833,14 @@ module Rule = struct
                   ; S.virt_var __POS__ "@"
                   ; S.virt_var __POS__"<"
                   ]))
-      ; mode = Not_a_rule_stanza
+      ; mode
       ; locks = []
       ; loc
       })
 
-  let ocamlyacc_v1 loc names =
+  let ocamlyacc_to_rule loc { modules; mode } =
     let module S = String_with_vars in
-    List.map names ~f:(fun name ->
+    List.map modules ~f:(fun name ->
       let src = name ^ ".mly" in
       { targets = Static [name ^ ".ml"; name ^ ".mli"]
       ; deps    = [File (S.virt_text __POS__ src)]
@@ -807,7 +849,7 @@ module Rule = struct
             (S.virt_var __POS__ "ROOT",
              Run (S.virt_text __POS__ "ocamlyacc",
                   [S.virt_var __POS__ "<"]))
-      ; mode = Not_a_rule_stanza
+      ; mode
       ; locks = []
       ; loc
       })
@@ -818,6 +860,7 @@ module Menhir = struct
     { merge_into : string option
     ; flags      : String_with_vars.t list
     ; modules    : string list
+    ; mode       : Rule.Mode.t
     }
 
   let v1 =
@@ -825,10 +868,12 @@ module Menhir = struct
       (field_o "merge_into" string >>= fun merge_into ->
        field "flags" (list String_with_vars.t) ~default:[] >>= fun flags ->
        field "modules" (list string) >>= fun modules ->
+       Rule.Mode.field >>= fun mode ->
        return
          { merge_into
          ; flags
          ; modules
+         ; mode
          }
       )
 
@@ -847,7 +892,7 @@ module Menhir = struct
               (S.virt_var __POS__ "ROOT",
                Run (S.virt_text __POS__ "menhir",
                     t.flags @ [S.virt_var __POS__ "<"]))
-        ; mode = Not_a_rule_stanza
+        ; mode  = t.mode
         ; locks = []
        ; loc
        })
@@ -867,7 +912,7 @@ module Menhir = struct
                      ; t.flags
                      ; [ S.virt_var __POS__ "^" ]
                      ]))
-       ; mode = Not_a_rule_stanza
+       ; mode  = t.mode
        ; locks = []
        ; loc
        }]
@@ -962,9 +1007,12 @@ module Stanzas = struct
       ; cstr "executable"  (Executables.v1_single pkgs @> nil) execs
       ; cstr "executables" (Executables.v1_multi  pkgs @> nil) execs
       ; cstr_loc "rule"      (Rule.v1     @> nil) (fun loc x -> [Rule { x with loc }])
-      ; cstr_loc "ocamllex"  (list string @> nil) (fun loc x -> rules (Rule.ocamllex_v1  loc x))
+      ; cstr_loc "ocamllex" (Rule.ocamllex_v1 @> nil)
-      ; cstr_loc "ocamlyacc" (list string @> nil) (fun loc x -> rules (Rule.ocamlyacc_v1 loc x))
+          (fun loc x -> rules (Rule.ocamllex_to_rule loc x))
-      ; cstr_loc "menhir"    (Menhir.v1   @> nil) (fun loc x -> rules (Menhir.v1_to_rule loc x))
+      ; cstr_loc "ocamlyacc" (Rule.ocamlyacc_v1 @> nil)
+          (fun loc x -> rules (Rule.ocamlyacc_to_rule loc 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])
       ; cstr "copy_files" (Copy_files.v1 @> nil)

src/jbuild_load.ml

@@ -1,6 +1,14 @@
 open Import
 open Jbuild
 
+let filter_stanzas ~ignore_promoted_rules stanzas =
+  if ignore_promoted_rules then
+    List.filter stanzas ~f:(function
+      | Stanza.Rule { mode = Promote; _ } -> false
+      | _ -> true)
+  else
+    stanzas
+
 module Jbuilds = struct
   type script =
     { dir   : Path.t
@@ -11,7 +19,10 @@ module Jbuilds = struct
     | Literal of (Path.t * Scope.t * Stanza.t list)
     | Script of script
 
-  type t = one list
+  type t =
+    { jbuilds               : one list
+    ; ignore_promoted_rules : bool
+    }
 
   let generated_jbuilds_dir = Path.(relative root) "_build/.jbuilds"
 
@@ -89,7 +100,7 @@ end
         plugin plugin_contents);
     extract_requires ~fname:plugin plugin_contents
 
-  let eval jbuilds ~(context : Context.t) =
+  let eval { jbuilds; ignore_promoted_rules } ~(context : Context.t) =
     let open Future in
     List.map jbuilds ~f:(function
       | Literal x -> return x
@@ -146,7 +157,9 @@ end
                Did you forgot to call [Jbuild_plugin.V*.send]?"
             (Path.to_string file);
         let sexps = Sexp.load ~fname:(Path.to_string generated_jbuild) ~mode:Many in
-        return (dir, scope, Stanzas.parse scope sexps ~file:generated_jbuild))
+        return (dir, scope,
+                Stanzas.parse scope sexps ~file:generated_jbuild
+                |> filter_stanzas ~ignore_promoted_rules))
     |> Future.all
 end
 
@@ -157,15 +170,17 @@ type conf =
   ; scopes    : Scope.t list
   }
 
-let load ~dir ~scope =
+let load ~dir ~scope ~ignore_promoted_rules =
   let file = Path.relative dir "jbuild" in
   match Sexp.load_many_or_ocaml_script (Path.to_string file) with
   | Sexps sexps ->
-    Jbuilds.Literal (dir, scope, Stanzas.parse scope sexps ~file)
+    Jbuilds.Literal (dir, scope,
+                     Stanzas.parse scope sexps ~file
+                     |> filter_stanzas ~ignore_promoted_rules)
   | Ocaml_script ->
     Script { dir; scope }
 
-let load ?extra_ignored_subtrees () =
+let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
   let ftree = File_tree.load Path.root ?extra_ignored_subtrees in
   let packages =
     File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs ->
@@ -221,7 +236,7 @@ let load ?extra_ignored_subtrees () =
       let scope = Path.Map.find_default path scopes ~default:scope in
       let jbuilds =
         if String_set.mem "jbuild" files then
-          let jbuild = load ~dir:path ~scope in
+          let jbuild = load ~dir:path ~scope ~ignore_promoted_rules in
           jbuild :: jbuilds
         else
           jbuilds
@@ -233,7 +248,7 @@ let load ?extra_ignored_subtrees () =
   in
   let jbuilds = walk (File_tree.root ftree) [] Scope.empty in
   { file_tree = ftree
-  ; jbuilds
+  ; jbuilds = { jbuilds; ignore_promoted_rules }
   ; packages
   ; scopes = Path.Map.values scopes
   }

src/jbuild_load.mli

@@ -14,4 +14,8 @@ type conf =
   ; scopes    : Scope.t list
   }
 
-val load : ?extra_ignored_subtrees:Path.Set.t -> unit -> conf
+val load
+  :  ?extra_ignored_subtrees:Path.Set.t
+  -> ?ignore_promoted_rules:bool
+  -> unit
+  -> conf

src/main.ml

@@ -22,8 +22,9 @@ let setup ?(log=Log.no_log)
       ?only_packages
       ?extra_ignored_subtrees
       ?x
+      ?ignore_promoted_rules
       () =
-  let conf = Jbuild_load.load ?extra_ignored_subtrees () in
+  let conf = Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules () in
   Option.iter only_packages ~f:(fun set ->
     String_set.iter set ~f:(fun pkg ->
       if not (String_map.mem pkg conf.packages) then

src/main.mli

@@ -22,6 +22,7 @@ val setup
   -> ?workspace_file:string
   -> ?only_packages:String_set.t
   -> ?x:string
+  -> ?ignore_promoted_rules:bool
   -> unit
   -> setup Future.t
 val external_lib_deps