diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 4e290394..88cf9d55 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -1017,9 +1017,10 @@ The following constructions are available: - ``(promote )`` copy generated files to the source tree. See `Promotion`_ for more details - ``(promote-if )`` is the same as ``(promote - )`` except that it does nothing when the files to - copy don't exist. This can be used with command that only produce a - correction when differences are found + )`` except that a form ``( as )`` is ignored + when ```` doesn't exists. Additionally, ```` won't be copied + if ```` doesn't already exist. This can be used with command that + only produce a correction when differences are found As mentioned ``copy#`` inserts a line directive at the beginning of the destination file. More precisely, it inserts the following line: diff --git a/src/action.ml b/src/action.ml index 10e49a8b..5ca8b94e 100644 --- a/src/action.ml +++ b/src/action.ml @@ -137,7 +137,8 @@ struct let remove_tree path = Remove_tree path let mkdir path = Mkdir path let digest_files files = Digest_files files - let promote mode files = Promote { mode; files } + let promote files = Promote { mode = Always; files } + let promote_if files = Promote { mode = If_corrected_file_exists; files } end module Make_mapper @@ -758,10 +759,12 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to = if promote_mode = Copy then Future.Scheduler.at_exit_after_waiting_for_commands (fun () -> List.iter not_ok ~f:(fun { Promote. src; dst } -> - Format.eprintf "Promoting %s to %s.@." - (Path.to_string_maybe_quoted src) - (Path.to_string_maybe_quoted dst); - Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst))); + if mode = Always || Path.exists dst then begin + Format.eprintf "Promoting %s to %s.@." + (Path.to_string_maybe_quoted src) + (Path.to_string_maybe_quoted dst); + Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst) + end)); Future.all_unit (List.map not_ok ~f:(fun { Promote. src; dst } -> Diff.print dst src)) end diff --git a/src/action_intf.ml b/src/action_intf.ml index 9dab6e06..9b093d78 100644 --- a/src/action_intf.ml +++ b/src/action_intf.ml @@ -76,5 +76,6 @@ module type Helpers = sig val remove_tree : path -> t val mkdir : path -> t val digest_files : path list -> t - val promote : Promote_mode.t -> promote_file list -> t + val promote : promote_file list -> t + val promote_if : promote_file list -> t end diff --git a/src/super_context.ml b/src/super_context.ml index 90c3a2f3..2e1f1989 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -1,6 +1,7 @@ open Import open Jbuild +module A = Action module Pset = Path.Set module Dir_with_jbuild = struct @@ -901,6 +902,24 @@ module PP = struct mli) in { m with impl ; intf } + let uses_ppx_driver ~pps = + match Option.map ~f:Pp.to_string (List.last pps) with + | Some "ppx_driver.runner" -> true + | Some _ | None -> false + + let promote_correction ~uses_ppx_driver fn build = + if not uses_ppx_driver then + build + else + Build.progn + [ build + ; Build.return + (A.promote_if + [{ src = Path.extend_basename fn ~suffix:".ppx-corrected" + ; dst = Path.drop_build_context fn + }]) + ] + let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir ~dep_kind ~lint ~lib_name ~scope = let alias = Alias.lint ~dir in @@ -909,7 +928,8 @@ module PP = struct (Alias.add_build (aliases sctx) alias build ~stamp:(List [ Atom "lint" ; Sexp.To_sexp.(option string) lib_name - ; Atom fn])) + ; Atom fn + ])) in match Preprocess_map.find source.name lint with | No_preprocessing -> () @@ -938,15 +958,19 @@ module PP = struct ; Dep src_path ] in + let uses_ppx_driver = uses_ppx_driver ~pps in let args = (* This hack is needed until -null is standard: https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35 *) - match Option.map ~f:Pp.to_string (List.last pps) with - | Some "ppx_driver.runner" -> args @ [A "-null"] - | Some _ | None -> args + if uses_ppx_driver then + args @ [ A "-null"; A "-diff-cmd"; A "-" ] + else + args in add_alias src.name - (Build.run ~context:sctx.context (Ok ppx_exe) args) + (promote_correction ~uses_ppx_driver + (Option.value_exn (Module.file ~dir source kind)) + (Build.run ~context:sctx.context (Ok ppx_exe) args)) ) (* Generate rules to build the .pp files and return a new module map where all filenames @@ -959,51 +983,54 @@ module PP = struct in let lint_module = lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope in String_map.map modules ~f:(fun (m : Module.t) -> - match Preprocess_map.find m.name preprocess with - | No_preprocessing -> - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - ast - | Action action -> - let ast = - pped_module m ~dir ~f:(fun _kind src dst -> - add_rule sctx - (preprocessor_deps - >>> - Build.path src - >>^ (fun _ -> [src]) - >>> - Action.run sctx - (Redirect - (Stdout, - target_var, - Chdir (root_var, - action))) - ~dir - ~dep_kind - ~targets:(Static [dst]) - ~scope)) - |> setup_reason_rules sctx ~dir in - lint_module ~ast ~source:m; - ast - | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - pped_module ast ~dir ~f:(fun kind src dst -> + match Preprocess_map.find m.name preprocess with + | No_preprocessing -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + ast + | Action action -> + let ast = + pped_module m ~dir ~f:(fun _kind src dst -> add_rule sctx (preprocessor_deps >>> - Build.run ~context:sctx.context - (Ok ppx_exe) - [ As flags - ; A "--dump-ast" - ; As (cookie_library_name lib_name) - ; A "-o"; Target dst - ; Ml_kind.ppx_driver_flag kind; Dep src - ])) + Build.path src + >>^ (fun _ -> [src]) + >>> + Action.run sctx + (Redirect + (Stdout, + target_var, + Chdir (root_var, + action))) + ~dir + ~dep_kind + ~targets:(Static [dst]) + ~scope)) + |> setup_reason_rules sctx ~dir in + lint_module ~ast ~source:m; + ast + | Pps { pps; flags } -> + let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + let uses_ppx_driver = uses_ppx_driver ~pps in + pped_module ast ~dir ~f:(fun kind src dst -> + add_rule sctx + (promote_correction ~uses_ppx_driver + (Option.value_exn (Module.file m ~dir kind)) + (preprocessor_deps + >>> + Build.run ~context:sctx.context + (Ok ppx_exe) + [ As flags + ; A "--dump-ast" + ; As (cookie_library_name lib_name) + ; As (if uses_ppx_driver then ["-diff-cmd"; "-"] else []) + ; A "-o"; Target dst + ; Ml_kind.ppx_driver_flag kind; Dep src + ]))) ) - end let expand_and_eval_set t ~scope ~dir set ~standard =