Skip to content

Commit

Permalink
rpc: serialize user message styles
Browse files Browse the repository at this point in the history
Signed-off-by: Ali Caglayan <alizter@gmail.com>
  • Loading branch information
Alizter committed Sep 8, 2023
1 parent faa389a commit 14637d5
Show file tree
Hide file tree
Showing 15 changed files with 784 additions and 138 deletions.
2 changes: 2 additions & 0 deletions doc/changes/8516.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
- RPC message styles are now serialised meaning that RPC diagnostics keep their Ansi
styling. (#8516, fixes #6921, @Alizter)
2 changes: 2 additions & 0 deletions otherlibs/dune-rpc/dune_rpc.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
97 changes: 97 additions & 0 deletions otherlibs/dune-rpc/dune_rpc.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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

Expand Down
118 changes: 118 additions & 0 deletions otherlibs/dune-rpc/private/diagnostics_v1.ml
Original file line number Diff line number Diff line change
@@ -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
22 changes: 22 additions & 0 deletions otherlibs/dune-rpc/private/diagnostics_v1.mli
Original file line number Diff line number Diff line change
@@ -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
Loading

0 comments on commit 14637d5

Please sign in to comment.