diff --git a/bin/fmt.ml b/bin/fmt.ml index 3400ea2a655..a756406cd58 100644 --- a/bin/fmt.ml +++ b/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 ;; diff --git a/bin/rpc/rpc_common.ml b/bin/rpc/rpc_common.ml index 9ee8f9205d6..273ceebeb6c 100644 --- a/bin/rpc/rpc_common.ml +++ b/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 diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index a264d769c01..201bbf0fe39 100644 --- a/bin/rpc/rpc_common.mli +++ b/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 diff --git a/doc/changes/12064.md b/doc/changes/12064.md new file mode 100644 index 00000000000..533f89e990a --- /dev/null +++ b/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) diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.ml b/otherlibs/dune-rpc/private/dune_rpc_private.ml index d1e4cc9144f..6ca140d5223 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.ml +++ b/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; diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.mli b/otherlibs/dune-rpc/private/dune_rpc_private.mli index f6eb99ce562..9c991e4fde0 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.mli +++ b/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 diff --git a/otherlibs/dune-rpc/private/procedures.ml b/otherlibs/dune-rpc/private/procedures.ml index 7a89e9ae7ba..b1b5fce69df 100644 --- a/otherlibs/dune-rpc/private/procedures.ml +++ b/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 diff --git a/otherlibs/dune-rpc/private/procedures.mli b/otherlibs/dune-rpc/private/procedures.mli index 00089ff0730..77dddbaabad 100644 --- a/otherlibs/dune-rpc/private/procedures.mli +++ b/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 diff --git a/otherlibs/dune-rpc/private/public.ml b/otherlibs/dune-rpc/private/public.ml index 262c277ad3d..d27e8b39cc6 100644 --- a/otherlibs/dune-rpc/private/public.ml +++ b/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 diff --git a/src/dune_rpc_impl/decl.mli b/src/dune_rpc_impl/decl.mli index db4d4eddbc8..f4ac536bc82 100644 --- a/src/dune_rpc_impl/decl.mli +++ b/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 diff --git a/src/dune_rpc_impl/dune b/src/dune_rpc_impl/dune index dc88b77bc81..c2de9d2ead9 100644 --- a/src/dune_rpc_impl/dune +++ b/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")) diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 7951d2d22ce..eda6d490388 100644 --- a/src/dune_rpc_impl/server.ml +++ b/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 diff --git a/src/dune_rpc_impl/server.mli b/src/dune_rpc_impl/server.mli index 2b38d5bb59c..60201e47604 100644 --- a/src/dune_rpc_impl/server.mli +++ b/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 diff --git a/test/blackbox-tests/test-cases/watching/dune b/test/blackbox-tests/test-cases/watching/dune index 8238d1afbc1..dee67dc09f9 100644 --- a/test/blackbox-tests/test-cases/watching/dune +++ b/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 diff --git a/test/blackbox-tests/test-cases/watching/fmt-test.t b/test/blackbox-tests/test-cases/watching/fmt-test.t new file mode 100644 index 00000000000..fb46686daf5 --- /dev/null +++ b/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.