refactor: create Diagnostic.to_user_message so it can be reused (#7812)

Another patch wanted to use this function, so move it out of private bin/diagnostics.ml to somewhere it can be reused. Signed-off-by: Spencer Baugh <sbaugh@janestreet.com> Co-authored-by: Spencer Baugh <sbaugh@janestreet.com>
ocaml · May 31, 2023 · d4ceaa9 · d4ceaa9
1 parent bd6b86a
commit d4ceaa9
Show file tree

Hide file tree

Showing 3 changed files with 32 additions and 27 deletions.
diff --git a/bin/diagnostics.ml b/bin/diagnostics.ml
@@ -2,32 +2,6 @@ open! Stdune
 open Import
 module Client = Dune_rpc_impl.Client
 
-let format_diagnostic (err : Dune_rpc_private.Diagnostic.t) : User_message.t =
-  let prefix =
-    Option.map err.severity ~f:(fun sev ->
-        let severity, prefix =
-          match sev with
-          | Dune_rpc_private.Diagnostic.Error ->
-            (User_message.Style.Error, "Error:")
-          | Warning -> (Warning, "Warning:")
-        in
-        Pp.tag severity (Pp.text prefix))
-  in
-  let directory =
-    match err.directory with
-    | None -> []
-    | Some d ->
-      [ Pp.tag User_message.Style.Loc (Pp.textf "(In directory %s)" d) ]
-  in
-  let formatted_loc =
-    match err.loc with
-    | None -> []
-    | Some l -> [ Pp.map_tags ~f:(fun _ -> User_message.Style.Loc) (Loc.pp l) ]
-  in
-  User_message.make ?prefix
-    (directory @ formatted_loc
-    @ [ Pp.map_tags ~f:(fun _ -> User_message.Style.Details) err.message ])
-
 let exec () =
   let open Fiber.O in
   let where = Rpc.active_server () in
@@ -48,7 +22,8 @@ let exec () =
   in
   match errors with
   | Ok errors ->
-    List.iter errors ~f:(fun err -> User_message.print (format_diagnostic err))
+    List.iter errors ~f:(fun err ->
+        User_message.print (Dune_rpc.Diagnostic.to_user_message err))
   | Error e -> Rpc.raise_rpc_error e
 
 let info =

diff --git a/otherlibs/dune-rpc/private/exported_types.ml b/otherlibs/dune-rpc/private/exported_types.ml
@@ -265,6 +265,34 @@ module Diagnostic = struct
 
   let to_dyn t = Sexp.to_dyn (Conv.to_sexp sexp t)
 
+  let to_user_message t =
+    let prefix =
+      Option.map t.severity ~f:(fun sev ->
+          let severity, prefix =
+            match sev with
+            | Error -> (Stdune.User_message.Style.Error, "Error:")
+            | Warning -> (Warning, "Warning:")
+          in
+          Pp.tag severity (Pp.text prefix))
+    in
+    let directory =
+      match t.directory with
+      | None -> []
+      | Some d ->
+        [ Pp.tag Stdune.User_message.Style.Loc (Pp.textf "(In directory %s)" d)
+        ]
+    in
+    let formatted_loc =
+      match t.loc with
+      | None -> []
+      | Some l ->
+        [ Pp.map_tags ~f:(fun _ -> Stdune.User_message.Style.Loc) (Loc.pp l) ]
+    in
+    Stdune.User_message.make ?prefix
+      (directory @ formatted_loc
+      @ [ Pp.map_tags ~f:(fun _ -> Stdune.User_message.Style.Details) t.message
+        ])
+
   module Event = struct
     type nonrec t =
       | Add of t

diff --git a/otherlibs/dune-rpc/private/exported_types.mli b/otherlibs/dune-rpc/private/exported_types.mli
@@ -111,6 +111,8 @@ module Diagnostic : sig
 
   val to_dyn : t -> Dyn.t
 
+  val to_user_message : t -> Stdune.User_message.t
+
   module Event : sig
     type nonrec t =
       | Add of t