ocaml · emillon · Nov 8, 2022 · Oct 5, 2022 · Nov 7, 2022 · Nov 7, 2022
diff --git a/CHANGES.md b/CHANGES.md
@@ -49,6 +49,11 @@ Unreleased
 - Allow `:standard` in the `(modules)` field of the `coq.pp` stanza (#6229,
   fixes #2414, @Alizter)
 
+- Extend the promotion CLI to a `dune promotion` group: `dune promote` is moved
+  to `dune promotion apply` (the former still works) and the new `dune promotion
+  diff` command can be used to just display the promotion without applying it.
+  (#6160, fixes #5368, @emillon)
+
 3.5.0 (2022-10-19)
 ------------------
 

diff --git a/bin/import.ml b/bin/import.ml
@@ -195,8 +195,12 @@ let restore_cwd_and_execve (common : Common.t) prog argv env =
 
 (* Adapted from
    https://github.com/ocaml/opam/blob/fbbe93c3f67034da62d28c8666ec6b05e0a9b17c/src/client/opamArg.ml#L759 *)
-let command_alias cmd term name =
-  let orig = Cmd.name cmd in
+let command_alias ?orig_name cmd term name =
+  let orig =
+    match orig_name with
+    | Some s -> s
+    | None -> Cmd.name cmd
+  in
   let doc = Printf.sprintf "An alias for $(b,%s)." orig in
   let man =
     [ `S "DESCRIPTION"

diff --git a/bin/main.ml b/bin/main.ml
@@ -16,7 +16,7 @@ let all : _ Cmdliner.Cmd.t list =
     ; Subst.command
     ; Print_rules.command
     ; Utop.command
-    ; Promote.command
+    ; Promotion.promote
     ; Printenv.command
     ; Help.command
     ; Format_dune_file.command
@@ -30,7 +30,13 @@ let all : _ Cmdliner.Cmd.t list =
     ]
   in
   let groups =
-    [ Ocaml_cmd.group; Coq.group; Rpc.group; Internal.group; Init.group ]
+    [ Ocaml_cmd.group
+    ; Coq.group
+    ; Rpc.group
+    ; Internal.group
+    ; Init.group
+    ; Promotion.group
+    ]
   in
   terms @ groups
 

diff --git a/bin/promote.ml b/bin/promote.ml
diff --git a/bin/promote.mli b/bin/promote.mli
diff --git a/bin/promotion.ml b/bin/promotion.ml
@@ -0,0 +1,74 @@
+open Stdune
+open Import
+
+let files_to_promote ~common files : Diff_promotion.files_to_promote =
+  match files with
+  | [] -> All
+  | _ ->
+    let files =
+      List.map files ~f:(fun fn ->
+          Path.Source.of_string (Common.prefix_target common fn))
+    in
+    let on_missing fn =
+      User_warning.emit
+        [ Pp.textf "Nothing to promote for %s."
+            (Path.Source.to_string_maybe_quoted fn)
+        ]
+    in
+    These (files, on_missing)
+
+module Apply = struct
+  let info =
+    let doc = "Promote files from the last run" in
+    let man =
+      [ `S Cmdliner.Manpage.s_description
+      ; `P
+          {|Considering all actions of the form $(b,(diff a b)) that failed
+           in the last run of dune, $(b,dune promotion apply) 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,dune promote) to promote the generated file.
+         |}
+      ; `Blocks Common.help_secs
+      ]
+    in
+    Cmd.info ~doc ~man "apply"
+
+  let term =
+    let+ common = Common.term
+    and+ files =
+      Arg.(value & pos_all Cmdliner.Arg.file [] & info [] ~docv:"FILE")
+    in
+    let _config = Common.init common in
+    let files_to_promote = files_to_promote ~common files in
+    Diff_promotion.promote_files_registered_in_last_run files_to_promote
+
+  let command = Cmd.v info term
+end
+
+module Diff = struct
+  let info = Cmd.info ~doc:"List promotions to be applied" "diff"
+
+  let term =
+    let+ common = Common.term
+    and+ files =
+      Arg.(value & pos_all Cmdliner.Arg.file [] & info [] ~docv:"FILE")
+    in
+    let config = Common.init common in
+    let files_to_promote = files_to_promote ~common files in
+    Scheduler.go ~common ~config (fun () ->
+        Diff_promotion.display files_to_promote)
+
+  let command = Cmd.v info term
+end
+
+let info =
+  Cmd.info ~doc:"Control how changes are propagated back to source code."
+    "promotion"
+
+let group = Cmd.group info [ Apply.command; Diff.command ]
+
+let promote =
+  command_alias ~orig_name:"promotion apply" Apply.command Apply.term "promote"
diff --git a/bin/promotion.mli b/bin/promotion.mli
@@ -0,0 +1,5 @@
+open Import
+
+val group : unit Cmd.t

+val promote : unit Cmd.t
diff --git a/doc/concepts.rst b/doc/concepts.rst
@@ -1077,7 +1077,8 @@ repository. You can use the following workflow to update your test:
 - Update the code of your test.
 - Run ``dune runtest``. The diff action will fail and a diff will
   be printed.
-- Check the diff to make sure it's what you expect.
+- Check the diff to make sure it's what you expect. This diff can be displayed
+  again by running ``dune promotion diff``.
 - Run ``dune promote``. This will copy the generated ``data.out``
   file to ``data.expected`` directly in the source tree.
 

diff --git a/doc/dune.inc b/doc/dune.inc
@@ -1,4 +1,13 @@
 
+(rule
+ (with-stdout-to dune-promote.1
+  (run dune promote --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-promote.1))
+
 (rule
  (with-stdout-to dune-test.1
   (run dune test --help=groff)))
@@ -171,13 +180,13 @@
  (files   dune-printenv.1))
 
 (rule
- (with-stdout-to dune-promote.1
-  (run dune promote --help=groff)))
+ (with-stdout-to dune-promotion.1
+  (run dune promotion --help=groff)))
 
 (install
  (section man)
  (package dune)
- (files   dune-promote.1))
+ (files   dune-promotion.1))
 
 (rule
  (with-stdout-to dune-rpc.1

diff --git a/src/dune_engine/diff_promotion.ml b/src/dune_engine/diff_promotion.ml
@@ -25,6 +25,13 @@ module File = struct
     ; dst : Path.Source.t
     }
 
+  let compare { src; staging; dst } t =
+    let open Ordering.O in
+    let= () = Path.Build.compare src t.src in
+    let= () = Option.compare Path.Build.compare staging t.staging in
+    let= () = Path.Source.compare dst t.dst in
+    Eq
+
   let in_staging_area source = Path.Build.append_source staging_area source
 
   let to_dyn { src; staging; dst } =
@@ -57,15 +64,14 @@ module File = struct
   let do_promote ~correction_file ~dst =
     Path.Source.unlink_no_err dst;
     let chmod = Path.Permissions.add Path.Permissions.write in
-    Io.copy_file ~chmod
-      ~src:(Path.build correction_file)
-      ~dst:(Path.source dst) ()
-
-  let promote { src; staging; dst } =
-    let correction_file = Option.value staging ~default:src in
-    let correction_exists =
-      Path.Untracked.exists (Path.build correction_file)
-    in
+    Io.copy_file ~chmod ~src:correction_file ~dst:(Path.source dst) ()
+
+  let correction_file { src; staging; _ } =
+    Path.build (Option.value staging ~default:src)
+
+  let promote ({ src; staging; dst } as file) =
+    let correction_file = correction_file file in
+    let correction_exists = Path.Untracked.exists correction_file in
     Console.print
       [ Pp.box ~indent:2
           (if correction_exists then
@@ -179,3 +185,34 @@ let promote_files_registered_in_last_run files_to_promote =
   let db = load_db () in
   let db = do_promote db files_to_promote in
   dump_db db
+
+let diff_for_file (file : File.t) =
+  let msg = User_message.Annots.empty in
+  let original = Path.source file.dst in
+  let correction = File.correction_file file in
+  Print_diff.get msg original correction
+
+let filter_db files_to_promote db =
+  match files_to_promote with
+  | All -> db
+  | These (files, on_missing) ->
+    List.filter_map files ~f:(fun file ->
+        let r =
+          List.find db ~f:(fun (f : File.t) -> Path.Source.equal f.dst file)
+        in
+        if Option.is_none r then on_missing file;
+        r)
+
+let display files_to_promote =
+  let open Fiber.O in
+  let files = load_db () |> filter_db files_to_promote in
+  let module FileMap = Map.Make (File) in
+  let+ diff_opts =
+    Fiber.parallel_map files ~f:(fun file ->
+        let+ diff_opt = diff_for_file file in
+        match diff_opt with
+        | Ok diff -> Some (file, diff)
+        | Error _ -> None)
+  in
+  diff_opts |> List.filter_opt |> FileMap.of_list_exn
+  |> FileMap.iter ~f:Print_diff.Diff.print
diff --git a/src/dune_engine/diff_promotion.mli b/src/dune_engine/diff_promotion.mli
@@ -44,3 +44,5 @@ type files_to_promote =
   | These of Path.Source.t list * (Path.Source.t -> unit)
 
 val promote_files_registered_in_last_run : files_to_promote -> unit
+
+val display : files_to_promote -> unit Fiber.t
Original file line number	Diff line number	Diff line change
Expand Up		@@ -44,3 +44,5 @@ type files_to_promote =
		\| These of Path.Source.t list * (Path.Source.t -> unit)

		val promote_files_registered_in_last_run : files_to_promote -> unit

		val display : files_to_promote -> unit Fiber.t
Copy link Member rgrinberg Nov 6, 2022 Choose a reason for hiding this comment The reason will be displayed to describe this comment to others. Learn more. Not entirely related to this PR, but we should change the API away from the ugly callback.