From 27283a95dd31f5911ea722e50d3d5441eb2d0ada Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 15 Jan 2018 14:47:54 +0000 Subject: [PATCH 1/2] Accept correction files produced by ppx_driver --- doc/jbuild.rst | 7 +-- src/action.ml | 6 ++- src/action_intf.ml | 3 +- src/super_context.ml | 120 ++++++++++++++++++++++++++----------------- 4 files changed, 84 insertions(+), 52 deletions(-) diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 4e290394b80..57a82f97832 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 it does nothing when either of the + two files of a ``( as )`` form doesn't 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 10e49a8bd5c..6ea6c9bf97b 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 @@ -744,7 +745,8 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to = match mode with | Always -> files | If_corrected_file_exists -> - List.filter files ~f:(fun file -> Path.exists file.Promote.src) + List.filter files ~f:(fun { Promote. src; dst } -> + Path.exists src && Path.exists dst) in let not_ok = List.filter files ~f:(fun { Promote. src; dst } -> diff --git a/src/action_intf.ml b/src/action_intf.ml index 9dab6e0643c..9b093d78945 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 90c3a2f3e8a..a174e27e85b 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,50 +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 From ae130728a721a2158ab7a5e4cc1436f5ff0c8b1b Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 16 Jan 2018 12:24:05 +0000 Subject: [PATCH 2/2] promote-if still prints a diff when files differ --- doc/jbuild.rst | 8 ++++---- src/action.ml | 13 +++++++------ src/super_context.ml | 5 ++--- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 57a82f97832..88cf9d55324 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -1017,10 +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 either of the - two files of a ``( as )`` form doesn'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 6ea6c9bf97b..5ca8b94e538 100644 --- a/src/action.ml +++ b/src/action.ml @@ -745,8 +745,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to = match mode with | Always -> files | If_corrected_file_exists -> - List.filter files ~f:(fun { Promote. src; dst } -> - Path.exists src && Path.exists dst) + List.filter files ~f:(fun file -> Path.exists file.Promote.src) in let not_ok = List.filter files ~f:(fun { Promote. src; dst } -> @@ -760,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/super_context.ml b/src/super_context.ml index a174e27e85b..2e1f1989897 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -1029,9 +1029,8 @@ module PP = struct ; 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 =