Accept correction files produced by ppx_driver

doc/jbuild.rst

@@ -1017,9 +1017,10 @@ The following constructions are available:
 - ``(promote <files-to-promote>)`` copy generated files to the source
   tree. See `Promotion`_ for more details
 - ``(promote-if <files-to-promote>)`` is the same as ``(promote
-  <files-to-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
+  <files-to-promote>)`` except that a form ``(<a> as <b>)`` is ignored
+  when ``<a>`` doesn't exists. Additionally, ``<a>`` won't be copied
+  if ``<b>`` 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:

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

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

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 =