[RPC] Allow formatting while watch server is running

bin/fmt.ml

@@ -26,7 +26,7 @@ let lock_ocamlformat () =
   else Fiber.return ()
 ;;
 
-let run_fmt_command ~(common : Common.t) ~config =
+let run_fmt_command ~common ~config ~preview =
   let open Fiber.O in
   let once () =
     let* () = lock_ocamlformat () in
@@ -40,13 +40,33 @@ let run_fmt_command ~(common : Common.t) ~config =
     | Ok () -> ()
     | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
   in
-  Scheduler.go_with_rpc_server ~common ~config once
+  match Dune_util.Global_lock.lock ~timeout:None with
+  | Ok () -> Scheduler.go_with_rpc_server ~common ~config once
+  | Error lock_held_by ->
+    (* The --preview flag is being ignored by the RPC server, warn the user. *)
+    if preview then Rpc_common.warn_ignore_arguments lock_held_by;
+    let response =
+      Scheduler.go_without_rpc_server ~common ~config (fun () ->
+        Rpc_common.fire_request
+          ~name:"format"
+          ~wait:true
+          Dune_rpc.Procedures.Public.format
+          ())
+    in
+    (match response with
+     | Ok () -> ()
+     | Error error ->
+       User_error.raise
+         [ Pp.paragraphf
+             "Error: %s\n%!"
+             (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error))
+         ])
 ;;
 
 let command =
   let term =
     let+ builder = Common.Builder.term
-    and+ no_promote =
+    and+ preview =
       Arg.(
         value
         & flag
@@ -58,10 +78,10 @@ let command =
                command.")
     in
     let builder =
-      Common.Builder.set_promote builder (if no_promote then Never else Automatically)
+      Common.Builder.set_promote builder (if preview then Never else Automatically)
     in
     let common, config = Common.init builder in
-    run_fmt_command ~common ~config
+    run_fmt_command ~common ~config ~preview
   in
   Cmd.v (Cmd.info "fmt" ~doc ~man ~envs:Common.envs) term
 ;;

bin/rpc/rpc_common.ml

@@ -109,17 +109,20 @@ let wrap_build_outcome_exn ~print_on_success f args () =
       ]
 ;;
 
+let warn_ignore_arguments lock_held_by =
+  User_warning.emit
+    [ Pp.textf
+        "Your build request is being forwarded to a running Dune instance%s. Note that \
+         certain command line arguments may be ignored."
+        (match lock_held_by with
+         | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
+         | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+    ]
+;;
+
 let run_via_rpc ~builder ~common ~config lock_held_by f args =
   if not (Common.Builder.equal builder Common.Builder.default)
-  then
-    User_warning.emit
-      [ Pp.textf
-          "Your build request is being forwarded to a running Dune instance%s. Note that \
-           certain command line arguments may be ignored."
-          (match lock_held_by with
-           | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
-           | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
-      ];
+  then warn_ignore_arguments lock_held_by;
   Scheduler.go_without_rpc_server
     ~common
     ~config

bin/rpc/rpc_common.mli

@@ -39,6 +39,9 @@ val wrap_build_outcome_exn
   -> unit
   -> unit Fiber.t
 
+(** Warn the user that since a RPC server is running, some arguments are ignored. *)
+val warn_ignore_arguments : Dune_util.Global_lock.Lock_held_by.t -> unit
+
 (**  Schedule a fiber to run via RPC, wrapping any errors. *)
 val run_via_rpc
   :  builder:Common.Builder.t

doc/changes/12064.md

@@ -0,0 +1,5 @@
+## Added
+
+- Allow `dune fmt` to properly run while a watch mode server is running.
+  Note that the `--preview` flag is not supported in this mode.
+  (#12064, @ElectreAAS)

otherlibs/dune-rpc/private/dune_rpc_private.ml

@@ -615,6 +615,7 @@ module Client = struct
       Builder.declare_request t Procedures.Public.diagnostics;
       Builder.declare_request t Procedures.Poll.(poll running_jobs);
       Builder.declare_notification t Procedures.Public.shutdown;
+      Builder.declare_request t Procedures.Public.format;
       Builder.declare_request t Procedures.Public.format_dune_file;
       Builder.declare_request t Procedures.Public.promote;
       Builder.declare_request t Procedures.Public.promote_many;

otherlibs/dune-rpc/private/dune_rpc_private.mli

@@ -194,6 +194,7 @@ module Procedures : sig
     val ping : (unit, unit) Decl.Request.t
     val diagnostics : (unit, Diagnostic.t list) Decl.Request.t
     val shutdown : unit Decl.Notification.t
+    val format : (unit, unit) Decl.Request.t
     val format_dune_file : (Path.t * [ `Contents of string ], string) Decl.Request.t
     val promote : (Path.t, unit) Decl.Request.t
 
@@ -242,6 +243,7 @@ module Public : sig
 
     val ping : (unit, unit) t
     val diagnostics : (unit, Diagnostic.t list) t
+    val format : (unit, unit) t
     val format_dune_file : (Path.t * [ `Contents of string ], string) t
     val promote : (Path.t, unit) t
     val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) t

otherlibs/dune-rpc/private/procedures.ml

@@ -35,6 +35,11 @@ module Public = struct
     let decl = Decl.Notification.make ~method_:"shutdown" ~generations:[ v1 ]
   end
 
+  module Format = struct
+    let v1 = Decl.Request.make_current_gen ~req:Conv.unit ~resp:Conv.unit ~version:1
+    let decl = Decl.Request.make ~method_:"format" ~generations:[ v1 ]
+  end
+
   module Format_dune_file = struct
     module V1 = struct
       let req =
@@ -75,6 +80,7 @@ module Public = struct
   let ping = Ping.decl
   let diagnostics = Diagnostics.decl
   let shutdown = Shutdown.decl
+  let format = Format.decl
   let format_dune_file = Format_dune_file.decl
   let promote = Promote.decl
   let promote_many = Promote_many.decl

otherlibs/dune-rpc/private/procedures.mli

@@ -5,9 +5,10 @@ module Public : sig
   val ping : (unit, unit) Decl.Request.t
   val diagnostics : (unit, Diagnostic.t list) Decl.Request.t
   val shutdown : unit Decl.Notification.t
+  val format : (unit, unit) Decl.Request.t
   val format_dune_file : (Path.t * [ `Contents of string ], string) Decl.Request.t
   val promote : (Path.t, unit) Decl.Request.t
-  val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.request
+  val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.Request.t
   val build_dir : (unit, Path.t) Decl.Request.t
 end
 

otherlibs/dune-rpc/private/public.ml

@@ -6,6 +6,7 @@ module Request = struct
 
   let ping = Procedures.Public.ping.decl
   let diagnostics = Procedures.Public.diagnostics.decl
+  let format = Procedures.Public.format.decl
   let format_dune_file = Procedures.Public.format_dune_file.decl
   let promote = Procedures.Public.promote.decl
   let promote_many = Procedures.Public.promote_many.decl

src/dune_rpc_impl/decl.mli

@@ -17,5 +17,5 @@ module Status : sig
   val sexp : (t, Conv.values) Conv.t
 end
 
-val build : (string list, Dune_rpc.Build_outcome_with_diagnostics.t) Decl.Request.t
+val build : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t
 val status : (unit, Status.t) Decl.Request.t

src/dune_rpc_impl/dune

@@ -1,16 +1,17 @@
 (library
  (name dune_rpc_impl)
  (libraries
-  stdune
-  promote
-  unix
-  fiber
   csexp_rpc
-  dune_stats
-  dune_rpc_client
   dune_console
-  dune_util
+  dune_engine
+  dune_lang
+  dune_rpc_client
   dune_rpc_private
   dune_rpc_server
-  dune_engine)
+  dune_stats
+  dune_util
+  fiber
+  promote
+  stdune
+  unix)
  (synopsis "Dune's rpc server + a usable client"))

src/dune_rpc_impl/server.ml

@@ -26,7 +26,7 @@ include struct
 end
 
 module Run = struct
-  module Registry = Dune_rpc_private.Registry
+  module Registry = Dune_rpc.Registry
 
   module Server = Dune_rpc_server.Make (struct
       include Csexp_rpc.Session
@@ -230,9 +230,7 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t =
     t.clients <- Clients.remove_session t.clients session;
     Fiber.return ()
   in
-  let rpc =
-    Handler.create ~on_terminate ~on_init ~version:Dune_rpc_private.Version.latest ()
-  in
+  let rpc = Handler.create ~on_terminate ~on_init ~version:Dune_rpc.Version.latest () in
   let () =
     let module Error = Build_system_error in
     let diff ~last ~(now : Error.Set.t) =
@@ -329,17 +327,35 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t =
   in
   let () = Handler.implement_request rpc Procedures.Public.ping (fun _ -> Fiber.return) in
   let () =
-    let build _session targets =
+    let f _ targets =
       let server = Fdecl.get t in
       let ivar = Fiber.Ivar.create () in
       let targets = List.map targets ~f:server.parse_build_arg in
       let* () = Job_queue.write server.pending_build_jobs (targets, ivar) in
       let+ build_outcome = Fiber.Ivar.read ivar in
       match (build_outcome : Build_outcome.t) with
-      | Success -> Dune_rpc_private.Build_outcome_with_diagnostics.Success
+      | Success -> Dune_rpc.Build_outcome_with_diagnostics.Success
       | Failure -> Failure (get_current_diagnostic_errors ())
     in
-    Handler.implement_request rpc Decl.build build
+    Handler.implement_request rpc Decl.build f
+  in
+  let () =
+    let f _ () =
+      let server = Fdecl.get t in
+      let outcome = Fiber.Ivar.create () in
+      let target =
+        Dune_lang.Dep_conf.Alias_rec (Dune_lang.String_with_vars.make_text Loc.none "fmt")
+      in
+      let* () = Job_queue.write server.pending_build_jobs ([ target ], outcome) in
+      let+ build_outcome = Fiber.Ivar.read outcome in
+      match build_outcome with
+      (* A 'successful' formatting means there is nothing to promote. *)
+      | Success -> ()
+      | Failure ->
+        Promote.Diff_promotion.promote_files_registered_in_last_run
+          Dune_rpc.Files_to_promote.All
+    in
+    Handler.implement_request rpc Procedures.Public.format f
   in
   let () =
     let rec cancel_pending_jobs () =
@@ -391,9 +407,9 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t =
   let () =
     let f _ files =
       Promote.Diff_promotion.promote_files_registered_in_last_run files;
-      Fiber.return Dune_rpc_private.Build_outcome_with_diagnostics.Success
+      Fiber.return Dune_rpc.Build_outcome_with_diagnostics.Success
     in
-    Handler.implement_request rpc Dune_rpc.Procedures.Public.promote_many f
+    Handler.implement_request rpc Procedures.Public.promote_many f
   in
   let () =
     let f _ path =
@@ -402,7 +418,7 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t =
         (These ([ files ], ignore));
       Fiber.return ()
     in
-    Handler.implement_request rpc Dune_rpc_private.Procedures.Public.promote f
+    Handler.implement_request rpc Procedures.Public.promote f
   in
   let () =
     let f _ () = Fiber.return Path.Build.(to_string root) in

src/dune_rpc_impl/server.mli

@@ -10,8 +10,8 @@ val create
   -> handle:(unit Dune_rpc_server.Handler.t -> unit)
        (** register additional requests or notifications *)
   -> Dune_stats.t option
-  -> parse_build_arg:(string -> 'build_arg)
-  -> 'build_arg t
+  -> parse_build_arg:(string -> Dune_lang.Dep_conf.t)
+  -> Dune_lang.Dep_conf.t t
 
 (** This type allows the build request handler to be defined externally to the
     RPC server. The ivar is expected to be filled with the outcome of the build

test/blackbox-tests/test-cases/watching/dune

@@ -1,6 +1,14 @@
+(env
+ (_
+  (binaries ../../utils/ocamlformat.exe)))
+
 (cram
  (deps helpers.sh))
 
+(cram
+ (applies_to fmt-test)
+ (deps %{bin:ocamlformat}))
+
 (cram
  ; see https://github.com/ocaml/dune/pull/4728
  (enabled_if

test/blackbox-tests/test-cases/watching/fmt-test.t

@@ -0,0 +1,30 @@
+  $ . ./helpers.sh
+
+  $ echo '(lang dune 3.20)' > dune-project
+  $ cat > dune << EOF
+  > (executable
+  >  (name foo))
+  > EOF
+
+  $ touch .ocamlformat
+
+  $ echo "let ()=print_int (5+4)" > foo.ml
+
+  $ start_dune
+
+  $ dune rpc ping --wait
+  Server appears to be responding normally
+
+  $ dune fmt
+
+Remove the fake ocamlformat from the dune file to see the real output
+  $ cat foo.ml
+  (* fake ocamlformat output *)
+
+  $ stop_dune
+  fake ocamlformat is running: "--impl" "foo.ml"
+  File "foo.ml", line 1, characters 0-0:
+  Error: Files _build/default/foo.ml and _build/default/.formatted/foo.ml
+  differ.
+  Had 1 error, waiting for filesystem changes...
+  Promoting _build/default/.formatted/foo.ml to foo.ml.