Actually move everything needed for promote_many into dune_rpc_private

* Demonstrate what moving everything into dune_rpc_private means

* Previous commit was just copying, this is really moving things

Signed-off-by: Ambre Austen Suhamy <[email protected]>

Author: ElectreAAS

bin/promotion.ml

@@ -1,7 +1,7 @@
 open Import
 module Diff_promotion = Promote.Diff_promotion
 
-let files_to_promote ~common files : Diff_promotion.files_to_promote =
+let files_to_promote ~common files : Dune_rpc.Files_to_promote.t =
   match files with
   | [] -> All
   | _ ->
@@ -70,7 +70,7 @@ module Apply = struct
         (Rpc_common.fire_request
            ~name:"promote_many"
            ~wait:true
-           Dune_rpc_impl.Decl.promote)
+           Dune_rpc_private.Procedures.Public.promote_many)
         files_to_promote
   ;;
 

bin/rpc/rpc_build.ml

@@ -21,10 +21,8 @@ let term =
     Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
   in
   match response with
-  | Error (error : Dune_rpc_private.Response.Error.t) ->
-    Printf.eprintf
-      "Error: %s\n%!"
-      (Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error))
+  | Error (error : Dune_rpc.Response.Error.t) ->
+    Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error))
   | Ok Success -> print_endline "Success"
   | Ok (Failure _) -> print_endline "Failure"
 ;;

bin/rpc/rpc_build.mli

@@ -7,10 +7,7 @@ open! Import
 val build
   :  wait:bool
   -> Dune_lang.Dep_conf.t list
-  -> ( Dune_rpc_impl.Decl.Build_outcome_with_diagnostics.t
-       , Dune_rpc.Response.Error.t )
-       result
-       Fiber.t
+  -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t
 
 (** dune rpc build command *)
 val cmd : unit Cmdliner.Cmd.t

bin/rpc/rpc_common.ml

@@ -1,6 +1,6 @@
 open Import
 module Client = Dune_rpc_client.Client
-module Rpc_error = Dune_rpc_private.Response.Error
+module Rpc_error = Dune_rpc.Response.Error
 
 let active_server () =
   match Dune_rpc_impl.Where.get () with
@@ -28,7 +28,7 @@ let request_exn client witness n =
   let open Fiber.O in
   let* decl = Client.Versioned.prepare_request client witness in
   match decl with
-  | Error e -> raise (Dune_rpc_private.Version_error.E e)
+  | Error e -> raise (Dune_rpc.Version_error.E e)
   | Ok decl -> Client.request client decl n
 ;;
 
@@ -79,8 +79,7 @@ let fire_request ~name ~wait request arg =
   Dune_rpc_impl.Client.client
     connection
     (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name)))
-    ~f:(fun client ->
-      request_exn client (Dune_rpc_private.Decl.Request.witness request) arg)
+    ~f:(fun client -> request_exn client (Dune_rpc.Decl.Request.witness request) arg)
 ;;
 
 let wrap_build_outcome_exn ~print_on_success f args () =
@@ -89,13 +88,13 @@ let wrap_build_outcome_exn ~print_on_success f args () =
   match response with
   | Error (error : Rpc_error.t) ->
     Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Rpc_error.to_dyn error))
-  | Ok Dune_rpc_impl.Decl.Build_outcome_with_diagnostics.Success ->
+  | Ok Dune_rpc.Build_outcome_with_diagnostics.Success ->
     if print_on_success
     then
       Console.print_user_message
         (User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ])
   | Ok (Failure errors) ->
-    List.iter errors ~f:(fun { Dune_engine.Compound_user_error.main; _ } ->
+    List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } ->
       Console.print_user_message main);
     User_error.raise
       [ (match List.length errors with

bin/rpc/rpc_common.mli

@@ -2,18 +2,18 @@ open Import
 
 (** The current active RPC server, raising an exception if no RPC server is
     currently running. *)
-val active_server_exn : unit -> Dune_rpc_private.Where.t
+val active_server_exn : unit -> Dune_rpc.Where.t
 
 (** Raise an RPC response error. *)
-val raise_rpc_error : Dune_rpc_private.Response.Error.t -> 'a
+val raise_rpc_error : Dune_rpc.Response.Error.t -> 'a
 
 (** Make a request and raise an exception if the preparation for the request
     fails in any way. Returns an [Error] if the response errors. *)
 val request_exn
   :  Dune_rpc_client.Client.t
-  -> ('a, 'b) Dune_rpc_private.Decl.Request.witness
+  -> ('a, 'b) Dune_rpc.Decl.Request.witness
   -> 'a
-  -> ('b, Dune_rpc_private.Response.Error.t) result Fiber.t
+  -> ('b, Dune_rpc.Response.Error.t) result Fiber.t
 
 (** Cmdliner term for a generic RPC client. *)
 val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a
@@ -28,14 +28,12 @@ val fire_request
   -> wait:bool
   -> ('a, 'b) Dune_rpc.Decl.request
   -> 'a
-  -> ('b, Dune_rpc_private.Response.Error.t) result Fiber.t
+  -> ('b, Dune_rpc.Response.Error.t) result Fiber.t
 
 val wrap_build_outcome_exn
   :  print_on_success:bool
   -> ('a
-      -> ( Dune_rpc_impl.Decl.Build_outcome_with_diagnostics.t
-           , Dune_rpc_private.Response.Error.t )
-           result
+      -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
            Fiber.t)
   -> 'a
   -> unit
@@ -48,9 +46,7 @@ val run_via_rpc
   -> config:Dune_config_file.Dune_config.t
   -> Dune_util.Global_lock.Lock_held_by.t
   -> ('a
-      -> ( Dune_rpc_impl.Decl.Build_outcome_with_diagnostics.t
-           , Dune_rpc_private.Response.Error.t )
-           result
+      -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result
            Fiber.t)
   -> 'a
   -> unit

boot/libs.ml

@@ -164,6 +164,11 @@ let local_libraries =
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
+  ; { path = "otherlibs/ocamlc-loc/src"
+    ; main_module_name = Some "Ocamlc_loc"
+    ; include_subdirs_unqualified = false
+    ; special_builtin_support = None
+    }
   ; { path = "otherlibs/dune-rpc/private"
     ; main_module_name = Some "Dune_rpc_private"
     ; include_subdirs_unqualified = false
@@ -194,11 +199,6 @@ let local_libraries =
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
-  ; { path = "otherlibs/ocamlc-loc/src"
-    ; main_module_name = Some "Ocamlc_loc"
-    ; include_subdirs_unqualified = false
-    ; special_builtin_support = None
-    }
   ; { path = "src/fsevents"
     ; main_module_name = Some "Fsevents"
     ; include_subdirs_unqualified = false
@@ -324,11 +324,6 @@ let local_libraries =
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
-  ; { path = "otherlibs/dune-site/src/private"
-    ; main_module_name = Some "Dune_site_private"
-    ; include_subdirs_unqualified = false
-    ; special_builtin_support = None
-    }
   ; { path = "src/dune_threaded_console"
     ; main_module_name = Some "Dune_threaded_console"
     ; include_subdirs_unqualified = false
@@ -369,8 +364,8 @@ let local_libraries =
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
-  ; { path = "src/source"
-    ; main_module_name = Some "Source"
+  ; { path = "otherlibs/dune-site/src/private"
+    ; main_module_name = Some "Dune_site_private"
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
@@ -379,6 +374,11 @@ let local_libraries =
     ; include_subdirs_unqualified = false
     ; special_builtin_support = None
     }
+  ; { path = "src/source"
+    ; main_module_name = Some "Source"
+    ; include_subdirs_unqualified = false
+    ; special_builtin_support = None
+    }
   ; { path = "src/dune_rules"
     ; main_module_name = Some "Dune_rules"
     ; include_subdirs_unqualified = true

otherlibs/dune-rpc/private/dune

@@ -1,7 +1,7 @@
 (library
  (name dune_rpc_private)
  (public_name dune-rpc.private)
- (libraries stdune ordering pp csexp dyn xdg unix)
+ (libraries csexp dyn ocamlc_loc ordering pp stdune unix xdg)
  (synopsis "for internal use only"))
 
 (ocamllex dbus_address)

otherlibs/dune-rpc/private/dune_rpc_private.ml

@@ -21,6 +21,7 @@ module Public = struct
     let diagnostics = Procedures.Public.diagnostics.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
     let build_dir = Procedures.Public.build_dir.decl
   end
 
@@ -642,6 +643,7 @@ module Client = struct
       Builder.declare_notification t Procedures.Public.shutdown;
       Builder.declare_request t Procedures.Public.format_dune_file;
       Builder.declare_request t Procedures.Public.promote;
+      Builder.declare_request t Procedures.Public.promote_many;
       Builder.declare_request t Procedures.Public.build_dir;
       Builder.implement_notification t Procedures.Server_side.abort (fun () ->
         handler.abort);

otherlibs/dune-rpc/private/dune_rpc_private.mli

@@ -196,6 +196,10 @@ module Procedures : sig
     val shutdown : unit Decl.Notification.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.t
+
     val build_dir : (unit, Path.t) Decl.Request.t
   end
 
@@ -240,6 +244,7 @@ module Public : sig
     val diagnostics : (unit, Diagnostic.t list) 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
     val build_dir : (unit, Path.t) t
   end
 

otherlibs/dune-rpc/private/exported_types.ml

@@ -703,3 +703,137 @@ module Job = struct
     ;;
   end
 end
+
+module Compound_user_error = struct
+  type t =
+    { main : User_message.t
+    ; related : User_message.t list
+    }
+
+  let create ~main ~related =
+    let () =
+      List.iter related ~f:(fun (related : User_message.t) ->
+        match related.loc with
+        | Some _ -> ()
+        | None ->
+          Code_error.raise
+            "related messages must have locations"
+            [ "related", String (Stdune.User_message.to_string related) ])
+    in
+    { main; related }
+  ;;
+
+  let sexp =
+    let open Conv in
+    let from { main; related } = main, related in
+    let to_ (main, related) = create ~main ~related in
+    let main = field "main" (required User_message.sexp_without_annots) in
+    let related = field "related" (required (list User_message.sexp_without_annots)) in
+    iso (record (both main related)) to_ from
+  ;;
+
+  let to_dyn { main; related } =
+    let open Dyn in
+    record
+      [ "main", string (Stdune.User_message.to_string main)
+      ; "related", (list string) (List.map related ~f:Stdune.User_message.to_string)
+      ]
+  ;;
+
+  let annot =
+    Stdune.User_message.Annots.Key.create ~name:"compound-user-error" (Dyn.list to_dyn)
+  ;;
+
+  let make ~main ~related = create ~main ~related
+
+  let make_loc ~dir { Ocamlc_loc.path; chars; lines } : Stdune.Loc.t =
+    let pos_fname =
+      let dir = Stdune.Path.drop_optional_build_context_maybe_sandboxed dir in
+      Stdune.Path.to_absolute_filename (Stdune.Path.relative dir path)
+    in
+    let pos_lnum_start, pos_lnum_stop =
+      match lines with
+      | Single i -> i, i
+      | Range (i, j) -> i, j
+    in
+    let pos_cnum_start, pos_cnum_stop =
+      match chars with
+      | None -> 0, 0
+      | Some (x, y) -> x, y
+    in
+    let pos = { Lexing.pos_fname; pos_lnum = 0; pos_bol = 0; pos_cnum = 0 } in
+    let start = { pos with pos_lnum = pos_lnum_start; pos_cnum = pos_cnum_start } in
+    let stop = { pos with pos_lnum = pos_lnum_stop; pos_cnum = pos_cnum_stop } in
+    Stdune.Loc.create ~start ~stop
+  ;;
+
+  let parse_output ~dir s =
+    Ocamlc_loc.parse s
+    |> List.map ~f:(fun (report : Ocamlc_loc.report) ->
+      let make_message (loc, message) =
+        let loc = make_loc ~dir loc in
+        let message = Pp.verbatim message in
+        Stdune.User_message.make ~loc [ message ]
+      in
+      let main = make_message (report.loc, report.message) in
+      let related = List.map report.related ~f:make_message in
+      make ~main ~related)
+  ;;
+end
+
+module Build_outcome_with_diagnostics = struct
+  type t =
+    | Success
+    | Failure of Compound_user_error.t list
+
+  let sexp_v1 =
+    let open Conv in
+    let success = constr "Success" unit (fun () -> Success) in
+    let failure = constr "Failure" unit (fun () -> Failure []) in
+    let variants = [ econstr success; econstr failure ] in
+    sum variants (function
+      | Success -> case () success
+      | Failure _ -> case () failure)
+  ;;
+
+  let sexp_v2 =
+    let open Conv in
+    let success = constr "Success" unit (fun () -> Success) in
+    let failure =
+      constr "Failure" (list Compound_user_error.sexp) (fun errors -> Failure errors)
+    in
+    let variants = [ econstr success; econstr failure ] in
+    sum variants (function
+      | Success -> case () success
+      | Failure errors -> case errors failure)
+  ;;
+
+  let sexp = sexp_v2
+end
+
+module Files_to_promote = struct
+  type t =
+    | All
+    | These of Stdune.Path.Source.t list * (Stdune.Path.Source.t -> unit)
+
+  let on_missing fn =
+    Stdune.User_warning.emit
+      [ Pp.paragraphf
+          "Nothing to promote for %s."
+          (Stdune.Path.Source.to_string_maybe_quoted fn)
+      ]
+  ;;
+
+  let sexp =
+    let open Conv in
+    let to_ = function
+      | [] -> All
+      | paths -> These (List.map ~f:Stdune.Path.Source.of_string paths, on_missing)
+    in
+    let from = function
+      | All -> []
+      | These (paths, _) -> List.map ~f:Stdune.Path.Source.to_string paths
+    in
+    iso (list Path.sexp) to_ from
+  ;;
+end