rpc: serialize user message styles

doc/changes/8516.md

@@ -0,0 +1,2 @@
+- RPC message styles are now serialised meaning that RPC diagnostics keep their Ansi
+  styling. (#8516, fixes #6921, @Alizter)

otherlibs/dune-rpc/dune_rpc.ml

@@ -14,6 +14,8 @@ module V1 = struct
   module Message = Message
   module Where = Where
   module Registry = Registry
+  module Ansi_color = Ansi_color
+  module User_message = User_message
   include Public
 
   module Client = struct

otherlibs/dune-rpc/dune_rpc.mli

@@ -86,6 +86,101 @@ module V1 : sig
     val to_string_absolute : t -> string
   end
 
+  module Ansi_color : sig
+    module RGB8 : sig
+      (** 8-bit RGB color *)
+      type t
+
+      (** [to_int t] returns the 8-bit color as an integer in the range [0, 255]. *)
+      val to_int : t -> int
+    end
+
+    module RGB24 : sig
+      (** 24-bit RGB color (true color) *)
+      type t
+
+      (** [red t] returns the red component of the 24-bit color [t]. *)
+      val red : t -> int
+
+      (** [green t] returns the green component of the 24-bit color [t]. *)
+      val green : t -> int
+
+      (** [blue t] returns the blue component of the 24-bit color [t]. *)
+      val blue : t -> int
+
+      (** [to_int t] returns the 24-bit color as an integer in the range [0, 0xFFFFFF].
+          Each color components consists of 8 bits. *)
+      val to_int : t -> int
+    end
+
+    module Style : sig
+      (** Ansi Terminal Styles *)
+      type t =
+        [ `Fg_default
+        | `Fg_black
+        | `Fg_red
+        | `Fg_green
+        | `Fg_yellow
+        | `Fg_blue
+        | `Fg_magenta
+        | `Fg_cyan
+        | `Fg_white
+        | `Fg_bright_black
+        | `Fg_bright_red
+        | `Fg_bright_green
+        | `Fg_bright_yellow
+        | `Fg_bright_blue
+        | `Fg_bright_magenta
+        | `Fg_bright_cyan
+        | `Fg_bright_white
+        | `Fg_8_bit_color of RGB8.t
+        | `Fg_24_bit_color of RGB24.t
+        | `Bg_default
+        | `Bg_black
+        | `Bg_red
+        | `Bg_green
+        | `Bg_yellow
+        | `Bg_blue
+        | `Bg_magenta
+        | `Bg_cyan
+        | `Bg_white
+        | `Bg_bright_black
+        | `Bg_bright_red
+        | `Bg_bright_green
+        | `Bg_bright_yellow
+        | `Bg_bright_blue
+        | `Bg_bright_magenta
+        | `Bg_bright_cyan
+        | `Bg_bright_white
+        | `Bg_8_bit_color of RGB8.t
+        | `Bg_24_bit_color of RGB24.t
+        | `Bold
+        | `Dim
+        | `Italic
+        | `Underline
+        ]
+    end
+  end
+
+  module User_message : sig
+    (** User Message Styles *)
+    module Style : sig
+      type t =
+        | Loc
+        | Error
+        | Warning
+        | Kwd
+        | Id
+        | Prompt
+        | Hint
+        | Details
+        | Ok
+        | Debug
+        | Success
+        | Ansi_styles of Ansi_color.Style.t list
+    end
+  end
+
   module Target : sig
     type t =
       | Path of string
@@ -121,6 +216,7 @@ module V1 : sig
 
       val loc : t -> Loc.t
       val message : t -> unit Pp.t
+      val message_with_style : t -> User_message.Style.t Pp.t
     end
 
     type t
@@ -129,6 +225,7 @@ module V1 : sig
     val loc : t -> Loc.t option
     val id : t -> Id.t
     val message : t -> unit Pp.t
+    val message_with_style : t -> User_message.Style.t Pp.t
     val severity : t -> severity option
     val promotion : t -> Promotion.t list
 

otherlibs/dune-rpc/private/diagnostics_v1.ml

@@ -0,0 +1,118 @@
+open Import
+open Exported_types
+
+module Related = struct
+  type t =
+    { message : unit Pp.t
+    ; loc : Loc.t
+    }
+
+  let sexp =
+    let open Conv in
+    let loc = field "loc" (required Loc.sexp) in
+    let message = field "message" (required sexp_pp_unit) in
+    let to_ (loc, message) = { loc; message } in
+    let from { loc; message } = loc, message in
+    iso (record (both loc message)) to_ from
+  ;;
+
+  let to_diagnostic_related t : Diagnostic.Related.t =
+    { message = t.message |> Pp.map_tags ~f:(fun _ -> User_message.Style.Details)
+    ; loc = t.loc
+    }
+  ;;
+
+  let of_diagnostic_related (t : Diagnostic.Related.t) =
+    { message = t.message |> Pp.map_tags ~f:(fun _ -> ()); loc = t.loc }
+  ;;
+end
+
+type t =
+  { targets : Target.t list
+  ; id : Diagnostic.Id.t
+  ; message : unit Pp.t
+  ; loc : Loc.t option
+  ; severity : Diagnostic.severity option
+  ; promotion : Diagnostic.Promotion.t list
+  ; directory : string option
+  ; related : Related.t list
+  }
+
+let sexp_severity =
+  let open Conv in
+  enum [ "error", Diagnostic.Error; "warning", Warning ]
+;;
+
+let sexp =
+  let open Conv in
+  let from { targets; message; loc; severity; promotion; directory; id; related } =
+    targets, message, loc, severity, promotion, directory, id, related
+  in
+  let to_ (targets, message, loc, severity, promotion, directory, id, related) =
+    { targets; message; loc; severity; promotion; directory; id; related }
+  in
+  let loc = field "loc" (optional Loc.sexp) in
+  let message = field "message" (required sexp_pp_unit) in
+  let targets = field "targets" (required (list Target.sexp)) in
+  let severity = field "severity" (optional sexp_severity) in
+  let directory = field "directory" (optional string) in
+  let promotion = field "promotion" (required (list Diagnostic.Promotion.sexp)) in
+  let id = field "id" (required Diagnostic.Id.sexp) in
+  let related = field "related" (required (list Related.sexp)) in
+  iso
+    (record (eight targets message loc severity promotion directory id related))
+    to_
+    from
+;;
+
+let to_diagnostic t : Diagnostic.t =
+  { targets = t.targets
+  ; message = t.message |> Pp.map_tags ~f:(fun _ -> User_message.Style.Details)
+  ; loc = t.loc
+  ; severity = t.severity
+  ; promotion = t.promotion
+  ; directory = t.directory
+  ; id = t.id
+  ; related = t.related |> List.map ~f:Related.to_diagnostic_related
+  }
+;;
+
+let of_diagnostic (t : Diagnostic.t) =
+  { targets = t.targets
+  ; message = t.message |> Pp.map_tags ~f:(fun _ -> ())
+  ; loc = t.loc
+  ; severity = t.severity
+  ; promotion = t.promotion
+  ; directory = t.directory
+  ; id = t.id
+  ; related = t.related |> List.map ~f:Related.of_diagnostic_related
+  }
+;;
+
+module Event = struct
+  type nonrec t =
+    | Add of t
+    | Remove of t
+
+  let sexp =
+    let diagnostic = sexp in
+    let open Conv in
+    let add = constr "Add" diagnostic (fun a -> Add a) in
+    let remove = constr "Remove" diagnostic (fun a -> Remove a) in
+    sum
+      [ econstr add; econstr remove ]
+      (function
+       | Add t -> case t add
+       | Remove t -> case t remove)
+  ;;
+
+  let to_event : t -> Diagnostic.Event.t = function
+    | Add t -> Add (to_diagnostic t)
+    | Remove t -> Remove (to_diagnostic t)
+  ;;
+
+  let of_event : Diagnostic.Event.t -> t = function
+    | Add t -> Add (of_diagnostic t)
+    | Remove t -> Remove (of_diagnostic t)
+  ;;
+end

otherlibs/dune-rpc/private/diagnostics_v1.mli

@@ -0,0 +1,22 @@
+(** V1 of the diagnostics module. *)
+
+module Related : sig
+  type t
+
+  val to_diagnostic_related : t -> Exported_types.Diagnostic.Related.t
+  val of_diagnostic_related : Exported_types.Diagnostic.Related.t -> t
+end
+
+type t
+
+val sexp : (t, Conv.values) Conv.t
+val to_diagnostic : t -> Exported_types.Diagnostic.t
+val of_diagnostic : Exported_types.Diagnostic.t -> t
+
+module Event : sig
+  type t
+
+  val sexp : (t, Conv.values) Conv.t
+  val to_event : t -> Exported_types.Diagnostic.Event.t
+  val of_event : Exported_types.Diagnostic.Event.t -> t
+end