Replace promote actions by diff actions + promote command (#421)

* Remove (promote ...) and (promote-if ...)
* Remove `--promote ...`
* Add (diff ...) and (diff? ...)
* Add `jbuilder promote` and `--auto-promote`
* Fix #423

Makefile

@@ -23,6 +23,11 @@ reinstall: uninstall reinstall
 test:
 	$(BIN) runtest --dev
 
+promote:
+	$(BIN) promote
+
+accept-corrections: promote
+
 all-supported-ocaml-versions:
 	$(BIN) build --dev @install @runtest --workspace jbuild-workspace.dev --root .
 
@@ -34,13 +39,8 @@ doc:
 	cd doc && sphinx-build . _build
 
 update-jbuilds: $(BIN)
-	$(BIN) build --dev @jbuild --promote copy
+	$(BIN) build --dev @doc/runtest --auto-promote
-
-accept-corrections:
-	for i in `find . -name \*.corrected`; do \
-	  cp $$i $${i%.corrected}; \
-	done
 
 .DEFAULT_GOAL := default
 .PHONY: default install uninstall reinstall clean test doc
-.PHONY: accept-corrections
+.PHONY: promote accept-corrections

bin/main.ml

@@ -23,7 +23,7 @@ type common =
   ; capture_outputs  : bool
   ; x                : string option
   ; diff_command     : string option
-  ; promote_mode     : Clflags.Promote_mode.t
+  ; auto_promote     : bool
   ; (* Original arguments for the external-lib-deps hint *)
     orig_args        : string list
   }
@@ -42,7 +42,7 @@ let set_common c ~targets =
     Sys.chdir c.root;
   Clflags.workspace_root := Sys.getcwd ();
   Clflags.diff_command := c.diff_command;
-  Clflags.promote_mode := c.promote_mode;
+  Clflags.auto_promote := c.auto_promote;
   Clflags.external_lib_deps_hint :=
     List.concat
       [ ["jbuilder"; "external-lib-deps"; "--missing"]
@@ -161,7 +161,8 @@ let common =
         no_buffer
         workspace_file
         diff_command
-        (root, only_packages, promote_mode, orig)
+        auto_promote
+        (root, only_packages, orig)
         x
     =
     let root, to_cwd =
@@ -188,7 +189,7 @@ let common =
     ; orig_args
     ; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
     ; diff_command
-    ; promote_mode
+    ; auto_promote
     ; only_packages =
         Option.map only_packages
           ~f:(fun s -> String_set.of_list (String.split s ~on:','))
@@ -279,23 +280,12 @@ let common =
                     targets given on the command line. It is only intended
                     for scripts.|})
   in
-  let promote =
+  let auto_promote =
-    let mode =
-      Arg.(conv
-             (Arg.parser_of_kind_of_string ~kind:"promotion mode"
-                Clflags.Promote_mode.of_string,
-              fun ppf mode ->
-                Format.pp_print_string ppf
-                  (Clflags.Promote_mode.to_string mode)))
-    in
     Arg.(value
-         & opt (some mode) None
+         & flag
-         & info ["promote"] ~docs
+         & info ["auto-promote"] ~docs
-             ~doc:"How to interpret promote actions. $(b,copy) means to print
+             ~doc:"Automatically promote files. This is similar to running
-                   a diff and copy the generated files to the source tree when
+                   $(b,jbuilder promote) after the build.")
-                   they differ. $(b,copy) is the default. $(b,check) means to
-                   only print a diff without copying files. $(b,ignore) means
-                   to ignore promote action altogether.")
   in
   let for_release = "for-release-of-packages" in
   let frop =
@@ -308,38 +298,32 @@ let common =
                     packages as well as getting reproducible builds.|})
   in
   let root_and_only_packages =
-    let merge root only_packages promote release =
+    let merge root only_packages release =
       let fail opt =
         `Error (true,
                 sprintf
                   "Cannot use -p/--%s and %s simultaneously"
                   for_release opt)
       in
-      match release, root, only_packages, promote with
+      match release, root, only_packages with
-      | Some _, Some _, _, _ -> fail "--root"
+      | Some _, Some _, _ -> fail "--root"
-      | Some _, _, Some _, _ -> fail "--only-packages"
+      | Some _, _, Some _ -> fail "--only-packages"
-      | Some _, _, _, Some _ -> fail "--promote"
+      | Some pkgs, None, None ->
-      | Some pkgs, None, None, None ->
         `Ok (Some ".",
              Some pkgs,
-             Clflags.Promote_mode.Ignore,
              ["-p"; pkgs]
             )
-      | None, _, _, _ ->
+      | None, _, _ ->
         `Ok (root,
              only_packages,
-             Option.value promote ~default:Clflags.Promote_mode.Copy,
              List.concat
                [ dump_opt "--root" root
                ; dump_opt "--only-packages" only_packages
-               ; dump_opt "--promote"
-                   (Option.map promote ~f:Clflags.Promote_mode.to_string)
                ])
     in
     Term.(ret (const merge
                $ root
                $ only_packages
-               $ promote
                $ frop))
   in
   let x =
@@ -364,6 +348,7 @@ let common =
         $ no_buffer
         $ workspace_file
         $ diff_command
+        $ auto_promote
         $ root_and_only_packages
         $ x
        )
@@ -1088,6 +1073,28 @@ let utop =
           $ Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")))
   , Term.info "utop" ~doc ~man )
 
+let promote =
+  let doc = "Promote files from the last run" in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|Considering all actions of the form $(b,(diff a b)) that failed
+           in the last run of jbuilder, $(b,jbuilder promote) does the following:
+
+           If $(b,a) is present in the source tree but $(b,b) isn't, $(b,b) is
+           copied over to $(b,a) in the source tree. The idea behind this is that
+           you might use $(b,(diff file.expected file.generated)) and then call
+           $(b,jbuilder promote) to promote the generated file.
+         |}
+    ; `Blocks help_secs
+    ] in
+  let go common =
+    set_common common ~targets:[];
+    Action.Promotion.promote_files_registered_in_last_run ()
+  in
+  ( Term.(const go
+          $ common)
+  , Term.info "promote" ~doc ~man )
+
 let all =
   [ installed_libraries
   ; external_lib_deps
@@ -1100,6 +1107,7 @@ let all =
   ; subst
   ; rules
   ; utop
+  ; promote
   ]
 
 let default =

doc/jbuild

@@ -16,5 +16,5 @@
   (run bash ${path:update-jbuild.sh} ${bin:jbuilder})))
 
 (alias
- ((name jbuild)
+ ((name runtest)
-  (action (promote (jbuild.inc.gen as jbuild.inc)))))
+  (action (diff jbuild.inc jbuild.inc.gen))))

doc/jbuild.inc

@@ -53,6 +53,15 @@
  ((section man)
   (files (jbuilder-installed-libraries.1))))
 
+(rule
+ ((targets (jbuilder-promote.1))
+  (action  (with-stdout-to ${@}
+            (run ${bin:jbuilder} promote --help=groff)))))
+
+(install
+ ((section man)
+  (files (jbuilder-promote.1))))
+
 (rule
  ((targets (jbuilder-rules.1))
   (action  (with-stdout-to ${@}

doc/jbuild.rst

@@ -555,15 +555,15 @@ For instance:
     (rule (with-stdout-to jbuild.inc.gen (run ./gen-jbuild.exe)))
 
     (alias
-     ((name   jbuild)
+     ((name   runtest)
-      (action (promote (jbuild.inc.gen as jbuild.inc)))))
+      (action (diff jbuild.inc jbuild.inc.gen))))
 
 With this jbuild file, running jbuilder as follow will replace the
 ``jbuild.inc`` file in the source tree by the generated one:
 
 .. code:: shell
 
-    $ jbuilder build @jbuild
+    $ jbuilder build @runtest --auto-promote
 
 Common items
 ============
@@ -1014,13 +1014,12 @@ The following constructions are available:
   and ``cmd`` on Windows
 - ``(bash <cmd>)`` to execute a command using ``/bin/bash``. This is obviously
   not very portable
-- ``(promote <files-to-promote>)`` copy generated files to the source
+- ``(diff <file1> <file2>)`` is similar to ``(run diff <file1>
-  tree. See `Promotion`_ for more details
+  <file2>)`` but is better and allows promotion.  See `Diffing and
-- ``(promote-if <files-to-promote>)`` is the same as ``(promote
+  promotion`_ for more details
-  <files-to-promote>)`` except that a form ``(<a> as <b>)`` is ignored
+- ``(diff? <file1> <file2>)`` is the same as ``(diff <file1>
-  when ``<a>`` doesn't exists. Additionally, ``<a>`` won't be copied
+  <file2>)`` except that it is ignored when ``<file1>`` or ``<file2>``
-  if ``<b>`` doesn't already exist. This can be used with command that
+  doesn't exists
-  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:
@@ -1138,37 +1137,69 @@ is global to all build contexts, simply use an absolute filename:
 
 .. _ocaml-syntax:
 
+Diffing and promotion
+---------------------
+
+``(diff <file1> <file2>)`` is very similar to ``(run diff <file1>
+<file2>)``. In particular it behaves in the same way:
+
+- when ``<file1>`` and ``<file2>`` are equal, it doesn't nothing
+- when they are not, the differences are shown and the action fails
+
+However, it is different for the following reason:
+
+- the exact command used to diff files can be configured via the
+  ``--diff-command`` command line argument. Note that it is only
+  called when the files are not byte equals
+
+- by default, it will use ``patdiff`` if it is installed. ``patdiff``
+  is a better diffing program. You can install it via opam with:
+
+  .. code:: sh
+
+     $ opam install patdiff
+
+- since ``(diff a b)`` is a builtin action, Jbuilder knowns that ``a``
+  and ``b`` are needed and so you don't need to specify them
+  explicitly as dependencies
+
+- you can use ``(diff? a b)`` after a command that might or might not
+  produce ``b``. For cases where commands optionally produce a
+  *corrected* file
+
+- it allows promotion. See below
+
 Promotion
----------
+~~~~~~~~~
 
-The ``(promote (<file1> as <file2>) (<file3> as <file4>) ...)`` and
+Whenever an action ``(diff <file1> <file2>)`` or ``(diff?  <file1>
-``(promote-if (<file1> as <file2>) (<file3> as <file4>) ...)`` actions
+<file2>)`` fails because the two files are different, jbuilder allows
-can be used to copy generated files to the source tree.
+you to promote ``<file2>`` as ``<file1>`` if ``<file1>`` is a source
+file and ``<file2>`` is a generated file.
 
-This method is used when one wants to commit a generated file that is
+More precisely, let's consider the following jbuild file:
-independent of the systems where it is generated. Typically this can
-be used to:
 
-- cut dependencies and/or speed up the build in release mode: we use
+.. code:: scheme
-  the file in the source tree rather than re-generate it
-- support bootstrap cycles
-- simplify the review when the generated code is easier to review than
-  the generator
 
-How jbuilder interprets promotions can be controlled using the
+   (rule
-``--promote`` command line argument. The following behaviors are
+    (with-stdout-to data.out (run ./test.exe)))
-available:
 
-- ``--promote copy``: when the two files given in a ``(<a> as <b>)``
+   (alias
-  form are different, jbuilder prints a diff and copies ``<a>`` to
+    ((name   runtest)
-  ``<b>`` directly in the source
+     (action (diff data.expected data.out))))
-   tree. This is the default
-- ``--promote check``: Jbuilder just checks that the two files are
-  equal and print a diff when there are not
-- ``--promote ignore``: ``promote`` actions are simply ignored
 
-Note that ``-p/--for-release-of-packages`` implies ``--promote
+Where ``data.expected`` is a file committed in the source
-ignore``.
+repository. You can use the following workflow to update your test:
+
+- update the code of your test
+- run ``jbuilder runtest``. The diff action will fail and a diff will
+  be printed
+- check the diff to make sure it is what you expect
+- run ``jbuilder promote``. This will copy the generated ``data.out``
+  file to ``data.expected`` directly in the source tree
+
+You can also use ``jbuilder runtest --auto-promote`` which will
+automatically do the promotion.
 
 OCaml syntax
 ============

src/action.ml

@@ -12,8 +12,6 @@ module Outputs = struct
     | Outputs -> "outputs"
 end
 
-module Promote_mode = Action_intf.Promote_mode
-
 module type Sexpable = sig
   type t
   val t : t Sexp.Of_sexp.t
@@ -31,14 +29,6 @@ module Make_ast
 struct
   include Ast
 
-  let promoted_file sexp =
-    match sexp with
-    | List (_, [src; Atom (_, "as"); dst]) ->
-      { Promote. src = Path.t src; dst = Path.t dst }
-    | _ ->
-      of_sexp_error sexp
-        "(<file1> as <file2>) expected"
-
   let rec t sexp =
     let path = Path.t and string = String.t in
     sum
@@ -69,16 +59,13 @@ struct
       ; cstr "system" (string @> nil) (fun cmd -> System cmd)
       ; cstr "bash"   (string @> nil) (fun cmd -> Bash   cmd)
       ; cstr "write-file" (path @> string @> nil) (fun fn s -> Write_file (fn, s))
-      ; cstr_rest "promote" nil promoted_file
+      ; cstr "diff" (path @> path @> nil)
-          (fun files -> Promote { mode = Always; files })
+          (fun file1 file2 -> Diff { optional = false; file1; file2 })
-      ; cstr_rest "promote-if" nil promoted_file
+      ; cstr "diff?" (path @> path @> nil)
-          (fun files -> Promote { mode = If_corrected_file_exists; files })
+          (fun file1 file2 -> Diff { optional = true ; file1; file2 })
       ]
       sexp
 
-  let sexp_of_promoted_file (file : Promote.file) =
-    Sexp.List [Path.sexp_of_t file.src; Atom "as"; Path.sexp_of_t file.dst]
-
   let rec sexp_of_t : _ -> Sexp.t =
     let path = Path.sexp_of_t and string = String.sexp_of_t in
     function
@@ -110,10 +97,10 @@ struct
     | Remove_tree x -> List [Atom "remove-tree"; path x]
     | Mkdir x       -> List [Atom "mkdir"; path x]
     | Digest_files paths -> List [Atom "digest-files"; List (List.map paths ~f:path)]
-    | Promote { mode = Always; files } ->
+    | Diff { optional = false; file1; file2 } ->
-      List (Atom "promote" :: List.map files ~f:sexp_of_promoted_file)
+      List [Atom "diff"; path file1; path file2]
-    | Promote { mode = If_corrected_file_exists; files } ->
+    | Diff { optional = true; file1; file2 } ->
-      List (Atom "promote-if" :: List.map files ~f:sexp_of_promoted_file)
+      List [Atom "diff?"; path file1; path file2]
 
   let run prog args = Run (prog, args)
   let chdir path t = Chdir (path, t)
@@ -137,8 +124,7 @@ struct
   let remove_tree path = Remove_tree path
   let mkdir path = Mkdir path
   let digest_files files = Digest_files files
-  let promote files = Promote { mode = Always; files }
+  let diff ?(optional=false) file1 file2 = Diff { optional; file1; file2 }
-  let promote_if files = Promote { mode = If_corrected_file_exists; files }
 end
 
 module Make_mapper
@@ -172,12 +158,8 @@ module Make_mapper
     | Remove_tree x -> Remove_tree (f_path x)
     | Mkdir x -> Mkdir (f_path x)
     | Digest_files x -> Digest_files (List.map x ~f:f_path)
-    | Promote p ->
+    | Diff { optional; file1; file2 } ->
-      let files =
+      Diff { optional; file1 = f_path file1; file2 = f_path file2 }
-        List.map p.files ~f:(fun { Src.Promote. src; dst } ->
-          { Dst.Promote.src = f_path src; dst = f_path dst })
-      in
-      Promote { mode = p.mode; files }
 end
 
 module Prog = struct
@@ -424,15 +406,11 @@ module Unexpanded = struct
         end
       | Digest_files x ->
         Digest_files (List.map x ~f:(E.path ~dir ~f))
-      | Promote p ->
+      | Diff { optional; file1; file2 } ->
-        let files =
+        Diff { optional
-          List.map p.files ~f:(fun { Promote.src; dst } ->
+             ; file1 = E.path ~dir ~f file1
-            { Unresolved.Promote.
+             ; file2 = E.path ~dir ~f file2
-              src = E.path ~dir ~f src
+             }
-            ; dst = Path.drop_build_context (E.path ~dir ~f dst)
-            })
-        in
-        Promote { mode = p.mode; files }
   end
 
   module E = struct
@@ -534,15 +512,11 @@ module Unexpanded = struct
       Mkdir res
     | Digest_files x ->
       Digest_files (List.map x ~f:(E.path ~dir ~f))
-    | Promote p ->
+    | Diff { optional; file1; file2 } ->
-      let files =
+      Diff { optional
-        List.map p.files ~f:(fun { Promote.src; dst } ->
+           ; file1 = E.path ~dir ~f file1
-          { Partial.Promote.
+           ; file2 = E.path ~dir ~f file2
-            src = E.path ~dir ~f src
+           }
-          ; dst = E.path ~dir ~f dst
-          })
-      in
-      Promote { mode = p.mode; files }
 end
 
 let fold_one_step t ~init:acc ~f =
@@ -565,7 +539,7 @@ let fold_one_step t ~init:acc ~f =
   | Remove_tree _
   | Mkdir _
   | Digest_files _
-  | Promote _ -> acc
+  | Diff _ -> acc
 
 include Make_mapper(Ast)(Ast)
 
@@ -597,6 +571,89 @@ let get_std_output : _ -> Future.std_output_to = function
   | None          -> Terminal
   | Some (fn, oc) -> Opened_file { filename = fn; tail = false; desc = Channel oc }
 
+module Promotion = struct
+  module File = struct
+    type t =
+      { src : Path.t
+      ; dst : Path.t
+      }
+
+    let t = function
+      | Sexp.Ast.List (_, [src; Atom (_, "as"); dst]) ->
+        { src = Path.t src
+        ; dst = Path.t dst
+        }
+      | sexp ->
+        Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected"
+
+    let sexp_of_t { src; dst } =
+      Sexp.List [Path.sexp_of_t src; Atom "as"; Path.sexp_of_t dst]
+
+    let db : t list ref = ref []
+
+    let register t = db := t :: !db
+
+    let 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)
+  end
+
+  let db_file = "_build/.to-promote"
+
+  let dump_db db =
+    if Sys.file_exists "_build" then begin
+      match db with
+      | [] -> if Sys.file_exists db_file then Sys.remove db_file
+      | l ->
+        Io.write_file db_file
+          (String.concat ~sep:""
+             (List.map l ~f:(fun x -> Sexp.to_string (File.sexp_of_t x) ^ "\n")))
+    end
+
+  let load_db () =
+    if Sys.file_exists db_file then
+      Sexp.load ~fname:db_file ~mode:Many
+      |> List.map ~f:File.t
+    else
+      []
+
+  let group_by_targets db =
+    List.map db ~f:(fun { File. src; dst } ->
+      (dst, src))
+    |> Path.Map.of_alist_multi
+    (* Sort the list of possible sources for deterministic behavior *)
+    |> Path.Map.map ~f:(List.sort ~cmp:Path.compare)
+
+  let do_promote db =
+    let by_targets = group_by_targets db  in
+    Path.Map.iter by_targets ~f:(fun ~key:dst ~data:srcs ->
+      match srcs with
+      | [] -> assert false
+      | src :: others ->
+        File.promote { src; dst };
+        List.iter others ~f:(fun path ->
+          Format.eprintf " -> ignored %s.@."
+            (Path.to_string_maybe_quoted path)))
+
+  let finalize () =
+    let db =
+      if !Clflags.auto_promote then
+        (do_promote !File.db; [])
+      else
+        !File.db
+    in
+    dump_db db
+
+  let promote_files_registered_in_last_run () =
+    let db = load_db () in
+    do_promote db;
+    dump_db []
+end
+
 type exec_context =
   { context : Context.t option
   ; purpose : Future.purpose
@@ -688,7 +745,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
   | Copy_and_add_line_directive (src, dst) ->
     Io.with_file_in (Path.to_string src) ~f:(fun ic ->
       Io.with_file_out (Path.to_string dst) ~f:(fun oc ->
-        let fn = Path.drop_build_context src in
+        let fn = Path.drop_optional_build_context src in
         let directive =
           if List.mem (Path.extension fn) ~set:[".c"; ".cpp"; ".h"] then
             "line"
@@ -736,37 +793,24 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
         (Marshal.to_string data [])
     in
     exec_echo stdout_to s
-  | Promote { mode; files } ->
+  | Diff { optional; file1; file2 } ->
-    let promote_mode = !Clflags.promote_mode in
+    if (optional && not (Path.exists file1 && Path.exists file2)) ||
-    if promote_mode = Ignore then
+       Io.read_file (Path.to_string file1) = Io.read_file (Path.to_string file2) then
       return ()
     else begin
-      let files =
+      let is_copied_from_source_tree file =
-        match mode with
+        match Path.drop_build_context file with
-        | Always -> files
+        | None -> false
-        | If_corrected_file_exists ->
+        | Some file -> Path.exists file
-          List.filter files ~f:(fun file -> Path.exists file.Promote.src)
       in
-      let not_ok =
+      if is_copied_from_source_tree file1 &&
-        List.filter files ~f:(fun { Promote. src; dst } ->
+         not (is_copied_from_source_tree file2) then begin
-          let src_contents = Io.read_file (Path.to_string src) in
+        Promotion.File.register
-          let dst_contents = Io.read_file (Path.to_string dst) in
+          { src = file2
-          src_contents <> dst_contents)
+          ; dst = Option.value_exn (Path.drop_build_context file1)
-      in
+          }
-      match not_ok with
+      end;
-      | [] -> return ()
+      Print_diff.print file1 file2
-      | _ ->
-        if promote_mode = Copy then
-          Future.Scheduler.at_exit_after_waiting_for_commands (fun () ->
-            List.iter not_ok ~f:(fun { Promote. src; 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
 
 and redirect outputs fn t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
@@ -832,13 +876,6 @@ module Infer = struct
   end
   open Outcome
 
-  let infer_promote mode files ~init ~f =
-    if mode = Promote_mode.If_corrected_file_exists ||
-       !Clflags.promote_mode = Ignore then
-      init
-    else
-      List.fold_left files ~init ~f
-
   let ( +@ ) acc fn = { acc with targets = S.add fn acc.targets }
   let ( +< ) acc fn = { acc with deps    = S.add fn acc.deps    }
 
@@ -858,8 +895,8 @@ module Infer = struct
     | Ignore (_, t) -> infer acc t
     | Progn l -> List.fold_left l ~init:acc ~f:infer
     | Digest_files l -> List.fold_left l ~init:acc ~f:(+<)
-    | Promote { mode; files } ->
+    | Diff { optional; file1; file2 } ->
-      infer_promote mode files ~init:acc ~f:(fun acc file -> acc +< file.Promote.src)
+      if optional then acc else acc +< file1 +< file2
     | Echo _
     | System _
     | Bash _
@@ -901,9 +938,8 @@ module Infer = struct
     | Ignore (_, t) -> partial acc t
     | Progn l -> List.fold_left l ~init:acc ~f:partial
     | Digest_files l -> List.fold_left l ~init:acc ~f:(+<?)
-    | Promote { mode; files } ->
+    | Diff { optional; file1; file2 } ->
-      infer_promote mode files ~init:acc ~f:(fun acc file ->
+      if optional then acc else acc +<? file1 +<? file2
-        acc +<? file.Unexpanded.Partial.Promote.src)
     | Echo _
     | System _
     | Bash _
@@ -931,9 +967,8 @@ module Infer = struct
     | Ignore (_, t) -> partial_with_all_targets acc t
     | Progn l -> List.fold_left l ~init:acc ~f:partial_with_all_targets
     | Digest_files l -> List.fold_left l ~init:acc ~f:(+<?)
-    | Promote { mode; files } ->
+    | Diff { optional; file1; file2 } ->
-      infer_promote mode files ~init:acc ~f:(fun acc file ->
+      if optional then acc else acc +<? file1 +<? file2
-        acc +<? file.Unexpanded.Partial.Promote.src)
     | Echo _
     | System _
     | Bash _

src/action.mli

@@ -14,8 +14,6 @@ end
 
 module Outputs : module type of struct include Action_intf.Outputs end
 
-module Promote_mode = Action_intf.Promote_mode
-
 (** result of the lookup of a program, the path to it or information about the
     failure and possibly a hint how to fix it *)
 module Prog : sig
@@ -38,11 +36,10 @@ include Action_intf.Ast
   with type string  := string
 
 include Action_intf.Helpers
-  with type program      := Prog.t
+  with type program := Prog.t
-  with type path         := Path.t
+  with type path    := Path.t
-  with type string       := string
+  with type string  := string
-  with type promote_file := Promote.file
+  with type t       := t
-  with type t            := t
 
 val t : t Sexp.Of_sexp.t
 val sexp_of_t : t Sexp.To_sexp.t
@@ -130,3 +127,21 @@ module Infer : sig
   (** If [all_targets] is [true] and a target cannot be determined statically, fail *)
   val partial : all_targets:bool -> Unexpanded.Partial.t -> Outcome.t
 end
+
+module Promotion : sig
+  module File : sig
+    type t =
+      { src : Path.t
+      ; dst : Path.t
+      }
+
+    (** Register a file to promote *)
+    val register : t -> unit
+  end
+
+  (** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of
+      registered files to [_build/.to-promote]. *)
+  val finalize : unit -> unit
+
+  val promote_files_registered_in_last_run : unit -> unit
+end

src/action_intf.ml

@@ -5,23 +5,18 @@ module Outputs = struct
     | Outputs (** Both Stdout and Stderr *)
 end
 
-module Promote_mode = struct
-  type t =
-    | If_corrected_file_exists
-    | Always
-end
-
 module type Ast = sig
   type program
   type path
   type string
 
-  module Promote : sig
+  module Diff : sig
     type file = { src : path; dst : path }
 
     type t =
-      { mode  : Promote_mode.t
+      { optional : bool
-      ; files : file list
+      ; file1    : path
+      ; file2    : path
       }
   end
 
@@ -44,7 +39,7 @@ module type Ast = sig
     | Remove_tree    of path
     | Mkdir          of path
     | Digest_files   of path list
-    | Promote        of Promote.t
+    | Diff           of Diff.t
 end
 
 module type Helpers = sig
@@ -52,7 +47,6 @@ module type Helpers = sig
   type path
   type string
   type t
-  type promote_file
 
   val run : program -> string list -> t
   val chdir : path -> t -> t
@@ -76,6 +70,5 @@ module type Helpers = sig
   val remove_tree : path -> t
   val mkdir : path -> t
   val digest_files : path list -> t
-  val promote : promote_file list -> t
+  val diff : ?optional:bool -> Path.t -> Path.t -> t
-  val promote_if : promote_file list -> t
 end

src/alias.ml

@@ -51,7 +51,7 @@ let is_standard = function
   | _ -> false
 
 let dep_rec ~loc ~file_tree t =
-  let path = Path.parent   (Fq_name.path t.name) |> Path.drop_build_context in
+  let path = Path.parent   (Fq_name.path t.name) |> Path.drop_optional_build_context in
   let name = Path.basename (Fq_name.path t.name) in
   match File_tree.find_dir file_tree path with
   | None -> Build.fail { fail = fun () ->

src/build_system.ml

@@ -87,7 +87,7 @@ module Internal_rule = struct
     | None ->
       Loc.in_file
         (Path.to_string
-           (Path.drop_build_context (Path.relative dir "jbuild")))
+           (Path.drop_optional_build_context (Path.relative dir "jbuild")))
 end
 
 module File_kind = struct
@@ -339,7 +339,7 @@ let add_spec t fn spec ~copy_source =
            | 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))
+               (Path.to_string_maybe_quoted (Path.drop_optional_build_context fn))
            | No ->
              Format.fprintf ppf
                "To keep the current behavior and get rid of this warning, add a field \
@@ -663,7 +663,7 @@ let create ~contexts ~file_tree ~rules =
          Pset.elements set
          |> List.map ~f:(fun p -> sprintf "- %s"
                                     (Path.to_string_maybe_quoted
-                                       (Path.drop_build_context p)))
+                                       (Path.drop_optional_build_context p)))
          |> String.concat ~sep:"\n"
        in
        Loc.fail (Internal_rule.loc rule ~dir:(Path.parent (Pset.choose leftover_targets)))
@@ -684,6 +684,7 @@ The following targets are not:
    ));
 
   at_exit (fun () -> dump_trace t);
+  Future.Scheduler.at_exit_after_waiting_for_commands Action.Promotion.finalize;
   t
 
 let remove_old_artifacts t =

src/clflags.ml

@@ -11,21 +11,4 @@ let external_lib_deps_hint = ref []
 let capture_outputs = ref true
 let debug_backtraces = ref false
 let diff_command = ref None
-module Promote_mode = struct
+let auto_promote = ref false
-  type t =
-    | Ignore
-    | Check
-    | Copy
-
-  let to_string = function
-    | Ignore -> "ignore"
-    | Check -> "check"
-    | Copy -> "copy"
-
-  let of_string = function
-    | "ignore" -> Some Ignore
-    | "check" -> Some Check
-    | "copy" -> Some Copy
-    | _ -> None
-end
-let promote_mode = ref Promote_mode.Copy

src/clflags.mli

@@ -39,15 +39,5 @@ val debug_backtraces : bool ref
 (** Command to use to diff things *)
 val diff_command : string option ref
 
-module Promote_mode : sig
+(** Automatically promote files *)
-  type t =
+val auto_promote : bool ref
-    | Ignore (** We ignore 'promote' stanzas and actions *)
-    | Check  (** Just check for equality *)
-    | Copy   (** If the correction is different,
-                 copy the file to the source tree *)
-
-  val to_string : t -> string
-  val of_string : string -> t option
-end
-
-val promote_mode : Promote_mode.t ref

src/diff.ml

@@ -1,43 +0,0 @@
-open Import
-
-let ( >>= ) = Future.( >>= )
-
-let print file1 file2 =
-  let loc = Loc.in_file (Path.to_string file1) in
-  let fallback () =
-    die "%aFiles \"%s\" and \"%s\" differ." Loc.print loc
-      (Path.to_string file1) (Path.to_string file2)
-  in
-  let normal_diff () =
-    match Bin.which "diff" with
-    | None -> fallback ()
-    | Some prog ->
-      Format.eprintf "%a@?" Loc.print loc;
-      Future.run Strict (Path.to_string prog)
-        ["-u"; Path.to_string file1; Path.to_string file2]
-      >>= fun () ->
-      die "diff reported no differences on \"%s\" and \"%s\""
-        (Path.to_string file1) (Path.to_string file2)
-  in
-  match !Clflags.diff_command with
-  | Some cmd ->
-    let sh, arg = Utils.system_shell_exn ~needed_to:"print diffs" in
-    let q fn = Filename.quote (Path.to_string fn) in
-    let cmd = sprintf "%s %s %s" cmd (q file1) (q file2) in
-    Future.run Strict (Path.to_string sh) [arg; cmd]
-    >>= fun () ->
-    die "command reported no differences: %s" cmd
-  | None ->
-    match Bin.which "patdiff" with
-    | None -> normal_diff ()
-    | Some prog ->
-      Future.run Strict (Path.to_string prog)
-        [ "-keep-whitespace"
-        ; "-location-style"; "omake"
-        ; "-unrefined"
-        ; Path.to_string file1
-        ; Path.to_string file2
-        ]
-      >>= fun () ->
-      (* Use "diff" if "patdiff" reported no differences *)
-      normal_diff ()

src/main.ml

@@ -150,7 +150,7 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
        - external library %S is required in %s\n\
        This cannot work.\n"
       package
-      (Utils.jbuild_name_in ~dir:(Path.drop_build_context defined_locally_in))
+      (Utils.jbuild_name_in ~dir:(Path.drop_optional_build_context defined_locally_in))
       required_by
       required_by
       (Utils.jbuild_name_in ~dir:required_locally_in);

src/merlin.ml

@@ -44,7 +44,7 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
             function
             | Lib.Internal (path, _) ->
               let spath =
-                Path.drop_build_context path
+                Path.drop_optional_build_context path
                 |> Path.reach ~from:remaindir
               in
               let bpath = Path.reach path ~from:remaindir in

src/path.ml

@@ -378,6 +378,9 @@ let extract_build_context_dir t =
     None
 
 let drop_build_context t =
+  Option.map (extract_build_context t) ~f:snd
+
+let drop_optional_build_context t =
   match extract_build_context t with
   | None -> t
   | Some (_, t) -> t

src/path.mli

@@ -98,7 +98,10 @@ val extract_build_context : t -> (string * t) option
 val extract_build_context_dir : t -> (t * t) option
 
 (** Drop the "_build/blah" prefix *)
-val drop_build_context : t -> t
+val drop_build_context : t -> t option
+
+(** Drop the "_build/blah" prefix if present, return [t] otherwise *)
+val drop_optional_build_context : t -> t
 
 val is_in_build_dir : t -> bool
 

src/print_diff.ml

@@ -0,0 +1,58 @@
+open Import
+
+let ( >>= ) = Future.( >>= )
+
+let print path1 path2 =
+  let dir, file1, file2 =
+    match
+      Path.extract_build_context_dir path1,
+      Path.extract_build_context_dir path2
+    with
+    | Some (dir1, f1), Some (dir2, f2) when dir1 = dir2 ->
+      (Path.to_string dir1, Path.to_string f1, Path.to_string f2)
+    | _ ->
+      (".", Path.to_string path1, Path.to_string path2)
+  in
+  let loc = Loc.in_file file1 in
+  let fallback () =
+    die "%aFiles %s and %s differ." Loc.print loc
+      (Path.to_string_maybe_quoted path1)
+      (Path.to_string_maybe_quoted path2)
+  in
+  let normal_diff () =
+    match Bin.which "diff" with
+    | None -> fallback ()
+    | Some prog ->
+      Format.eprintf "%a@?" Loc.print loc;
+      Future.run ~dir Strict (Path.to_string prog)
+        ["-u"; file1; file2]
+      >>= fun () ->
+      fallback ()
+  in
+  match !Clflags.diff_command with
+  | Some cmd ->
+    let sh, arg = Utils.system_shell_exn ~needed_to:"print diffs" in
+    let cmd =
+      sprintf "%s %s %s" cmd (quote_for_shell file1) (quote_for_shell file2)
+    in
+    Future.run ~dir Strict (Path.to_string sh) [arg; cmd]
+    >>= fun () ->
+    die "command reported no differences: %s"
+      (if dir = "." then
+         cmd
+       else
+         sprintf "cd %s && %s" (quote_for_shell dir) cmd)
+  | None ->
+    match Bin.which "patdiff" with
+    | None -> normal_diff ()
+    | Some prog ->
+      Future.run ~dir Strict (Path.to_string prog)
+        [ "-keep-whitespace"
+        ; "-location-style"; "omake"
+        ; "-unrefined"
+        ; file1
+        ; file2
+        ]
+      >>= fun () ->
+      (* Use "diff" if "patdiff" reported no differences *)
+      normal_diff ()

src/super_context.ml

@@ -924,10 +924,9 @@ module PP = struct
       Build.progn
         [ build
         ; Build.return
-            (A.promote_if
+            (A.diff ~optional:true
-               [{ src = Path.extend_basename fn ~suffix:".ppx-corrected"
+               (Path.extend_basename fn ~suffix:".ppx-corrected")
-                ; dst = Path.drop_build_context fn
+               fn)
-                }])
         ]
 
   let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir

test/blackbox-tests/jbuild

@@ -11,21 +11,30 @@
   (deps   ((files_recursively_in test-cases/redirections)))
   (action
    (chdir test-cases/redirections
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/misc)))
   (action
    (chdir test-cases/misc
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/github20)))
   (action
    (chdir test-cases/github20
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest-js)
@@ -34,21 +43,29 @@
    (chdir test-cases/js_of_ocaml
     (setenv JBUILDER ${bin:jbuilder}
      (setenv NODE ${bin:node}
-      (run ${exe:cram.exe} run.t)))))))
+      (progn
+       (run ${exe:cram.exe} run.t)
+       (diff? run.t run.t.corrected))))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/github24)))
   (action
    (chdir test-cases/github24
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/menhir)))
   (action
    (chdir test-cases/menhir
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
@@ -56,123 +73,177 @@
   (action
    (chdir test-cases/github25/root
     (setenv OCAMLPATH ../findlib-packages
-     (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t)))))))
+     (setenv JBUILDER ${bin:jbuilder}
+      (progn
+       (run ${exe:cram.exe} run.t)
+       (diff? run.t run.t.corrected))))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/lib-available)))
   (action
    (chdir test-cases/lib-available
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/copy_files)))
   (action
    (chdir test-cases/copy_files
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/aliases)))
   (action
    (chdir test-cases/aliases
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/force-test)))
   (action
    (chdir test-cases/force-test
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/meta-gen)))
   (action
    (chdir test-cases/meta-gen
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/exec-cmd)))
   (action
    (chdir test-cases/exec-cmd
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/ocaml-syntax)))
   (action
      (chdir test-cases/ocaml-syntax
-  (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+      (setenv JBUILDER ${bin:jbuilder}
+       (progn
+        (run ${exe:cram.exe} run.t)
+        (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/gen-opam-install-file)))
   (action
      (chdir test-cases/gen-opam-install-file
-  (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+      (setenv JBUILDER ${bin:jbuilder}
+       (progn
+        (run ${exe:cram.exe} run.t)
+        (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/reason)))
   (action
    (chdir test-cases/reason
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/odoc)))
   (action
    (chdir test-cases/odoc
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/select)))
   (action
    (chdir test-cases/select
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/multiple-private-libs)))
   (action
    (chdir test-cases/multiple-private-libs
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/ppx-rewriter)))
   (action
    (chdir test-cases/ppx-rewriter
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} -ocamlv ${ocaml_version} -skip-versions 4.02.3 run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/utop)))
   (action
    (chdir test-cases/utop
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/c-stubs)))
   (action
    (chdir test-cases/c-stubs
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/cross-compilation)))
   (action
    (chdir test-cases/cross-compilation
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))
 
 (alias
  ((name runtest)
   (deps ((files_recursively_in test-cases/promote)))
   (action
    (chdir test-cases/promote
-    (setenv JBUILDER ${bin:jbuilder} (run ${exe:cram.exe} run.t))))))
+    (setenv JBUILDER ${bin:jbuilder}
+     (progn
+      (run ${exe:cram.exe} run.t)
+      (diff? run.t run.t.corrected)))))))

test/blackbox-tests/test-cases/promote/jbuild

@@ -4,4 +4,4 @@
 
 (alias
  ((name blah)
-  (action (promote (x.gen as x)))))
+  (action (diff x x.gen))))

test/blackbox-tests/test-cases/promote/run.t

@@ -1,21 +1,27 @@
   $ echo titi > x
 
-  $ $JBUILDER build --root . -j1 --diff-command false @blah --promote check
+  $ $JBUILDER build --root . -j1 --diff-command false @blah 2>&1 | sed 's/.*false.*/DIFF/'
             sh (internal) (exit 1)
-  /usr/bin/sh -c 'false '\''x'\'' '\''_build/default/x.gen'\'''
+  DIFF
-  [1]
   $ cat x
   titi
 
-  $ $JBUILDER build --root . -j1 --diff-command false @blah --promote ignore
+  $ $JBUILDER promote --root .
+  Promoting _build/default/x.gen to x.
   $ cat x
-  titi
+  toto
 
   $ $JBUILDER build --root . -j1 --diff-command false @blah
+  $ cat x
+  toto
+
+  $ echo titi > x
+  $ $JBUILDER build --root . -j1 --diff-command false @blah --auto-promote 2>&1 | sed 's/.*false.*/DIFF/'
             sh (internal) (exit 1)
-  /usr/bin/sh -c 'false '\''x'\'' '\''_build/default/x.gen'\'''
+  DIFF
   Promoting _build/default/x.gen to x.
-  [1]
   $ cat x
   toto
   $ $JBUILDER build --root . -j1 --diff-command false @blah
+  $ cat x
+  toto

test/common/test_common.ml

@@ -1,43 +1,4 @@
-open StdLabels
+open! StdLabels
-
-module Print_diff = struct
-  let patdiff_cmd ~use_color =
-    let args =
-      List.concat [
-        ["-keep-whitespace"];
-        ["-location-style omake"];
-        (if use_color then ["-unrefined"] else ["-ascii"]);
-      ]
-    in
-    String.concat ~sep:" " ("patdiff" :: args)
-
-  let print ?diff_command ?(use_color=false) ~file1 ~file2 () =
-    let exec cmd =
-      let cmd =
-        Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) (Filename.quote file2)
-      in
-      match Sys.command cmd with
-      | 0 -> true
-      | 1 -> false
-      | n -> Printf.eprintf "%S exited with code %d\n" cmd n; exit 2
-    in
-    match diff_command with
-    | Some s -> ignore (exec s : bool)
-    | None ->
-      let has_patdiff =
-        let dev_null = if Sys.win32 then "nul" else "/dev/null" in
-        Printf.ksprintf Sys.command "patdiff -version > %s 2> %s"
-          dev_null dev_null = 0
-      in
-      if has_patdiff then begin
-        if exec (patdiff_cmd ~use_color) then begin
-          (* Use "diff" if "patdiff" reported no differences *)
-          Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1;
-          ignore (exec "diff -u" : bool);
-        end
-      end else
-        ignore (exec "diff -u" : bool)
-end
 
 let read_file file =
   let ic = open_in_bin file in
@@ -58,33 +19,11 @@ let run_expect_test file ~f =
 
   let expected = f file_contents lexbuf in
 
-  (* Temporary hack, if we are in the default context, put the .corrected in the source
-     tree: *)
-  let concat a b =
-    match b with
-    | ".." -> Filename.dirname a
-    | "."  -> a
-    | _    -> Filename.concat a b
-  in
-  let rec loop path after =
-    let basename = Filename.basename path in
-    if basename = "_build" then
-      match after with
-      | "default" :: after ->
-        List.fold_left after ~init:(Filename.dirname path) ~f:concat
-      | _ ->
-        List.fold_left after ~init:path ~f:concat
-    else
-      loop (Filename.dirname path) (basename :: after)
-  in
-  let file = loop (Filename.concat (Sys.getcwd ()) file) [] in
   let corrected_file = file ^ ".corrected" in
   if file_contents <> expected then begin
     let oc = open_out_bin corrected_file in
     output_string oc expected;
     close_out oc;
-    Print_diff.print () ~file1:file ~file2:corrected_file;
-    exit 1
   end else begin
     if Sys.file_exists corrected_file then Sys.remove corrected_file;
     exit 0

test/unit-tests/jbuild

@@ -15,32 +15,47 @@
          (glob_files ${SCOPE_ROOT}/src/*.cmi)
          (glob_files ${SCOPE_ROOT}/vendor/re/*.cmi)
          (files_recursively_in findlib-db)))
-  (action (chdir ${SCOPE_ROOT} (run ${exe:expect_test.exe} ${<})))))
+  (action (chdir ${SCOPE_ROOT}
+           (progn
+            (run ${exe:expect_test.exe} ${<})
+            (diff? ${<} ${<}.corrected))))))
 
 (alias
  ((name runtest)
   (deps (filename.mlt
          (glob_files ${SCOPE_ROOT}/src/*.cmi)
          (glob_files ${SCOPE_ROOT}/vendor/re/*.cmi)))
-  (action (chdir ${SCOPE_ROOT} (run ${exe:expect_test.exe} ${<})))))
+  (action (chdir ${SCOPE_ROOT}
+           (progn
+            (run ${exe:expect_test.exe} ${<})
+            (diff? ${<} ${<}.corrected))))))
 
 (alias
  ((name runtest)
   (deps (import_dot_map.mlt
          (glob_files ${SCOPE_ROOT}/src/*.cmi)
          (glob_files ${SCOPE_ROOT}/vendor/re/*.cmi)))
-  (action (chdir ${SCOPE_ROOT} (run ${exe:expect_test.exe} ${<})))))
+  (action (chdir ${SCOPE_ROOT}
+           (progn
+            (run ${exe:expect_test.exe} ${<})
+            (diff? ${<} ${<}.corrected))))))
 
 (alias
  ((name runtest)
   (deps (action.mlt
          (glob_files ${SCOPE_ROOT}/src/*.cmi)
          (glob_files ${SCOPE_ROOT}/vendor/re/*.cmi)))
-  (action (chdir ${SCOPE_ROOT} (run ${exe:expect_test.exe} ${<})))))
+  (action (chdir ${SCOPE_ROOT}
+           (progn
+            (run ${exe:expect_test.exe} ${<})
+            (diff? ${<} ${<}.corrected))))))
 
 (alias
  ((name runtest)
   (deps (path.mlt
          (glob_files ${SCOPE_ROOT}/src/*.cmi)
          (glob_files ${SCOPE_ROOT}/vendor/re/*.cmi)))
-  (action (chdir ${SCOPE_ROOT} (run ${exe:expect_test.exe} ${<})))))
+  (action (chdir ${SCOPE_ROOT}
+           (progn
+            (run ${exe:expect_test.exe} ${<})
+            (diff? ${<} ${<}.corrected))))))