From 0aa397b87d89eeb3bb13df8f9b836e8d0c168d5d Mon Sep 17 00:00:00 2001 From: Ali Caglayan Date: Thu, 24 Aug 2023 13:07:36 +0100 Subject: [PATCH] rpc: serialize user message styles Signed-off-by: Ali Caglayan --- doc/changes/8516.md | 2 + otherlibs/dune-rpc/dune_rpc.ml | 2 + otherlibs/dune-rpc/dune_rpc.mli | 97 +++++ otherlibs/dune-rpc/private/diagnostics_v1.ml | 118 ++++++ otherlibs/dune-rpc/private/diagnostics_v1.mli | 22 ++ otherlibs/dune-rpc/private/exported_types.ml | 354 ++++++++++++++++-- otherlibs/dune-rpc/private/exported_types.mli | 56 ++- otherlibs/dune-rpc/private/procedures.ml | 30 +- otherlibs/stdune/src/ansi_color.ml | 25 +- otherlibs/stdune/src/ansi_color.mli | 20 + src/dune_rpc_impl/diagnostics.ml | 19 +- src/dune_rpc_server/dune_rpc_server.ml | 1 + test/expect-tests/dune_rpc/dune_rpc_tests.ml | 6 + .../dune_rpc_e2e/dune_rpc_diagnostics.ml | 13 +- .../dune_rpc_impl/dune_rpc_impl_tests.ml | 155 ++++---- 15 files changed, 782 insertions(+), 138 deletions(-) create mode 100644 doc/changes/8516.md create mode 100644 otherlibs/dune-rpc/private/diagnostics_v1.ml create mode 100644 otherlibs/dune-rpc/private/diagnostics_v1.mli diff --git a/doc/changes/8516.md b/doc/changes/8516.md new file mode 100644 index 00000000000..cc2f351d024 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/otherlibs/dune-rpc/dune_rpc.ml b/otherlibs/dune-rpc/dune_rpc.ml index a970a167acc..81f787f16e0 100644 --- a/otherlibs/dune-rpc/dune_rpc.ml +++ b/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 diff --git a/otherlibs/dune-rpc/dune_rpc.mli b/otherlibs/dune-rpc/dune_rpc.mli index 462908135c7..92ac68b7734 100644 --- a/otherlibs/dune-rpc/dune_rpc.mli +++ b/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 diff --git a/otherlibs/dune-rpc/private/diagnostics_v1.ml b/otherlibs/dune-rpc/private/diagnostics_v1.ml new file mode 100644 index 00000000000..fa79da03039 --- /dev/null +++ b/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 diff --git a/otherlibs/dune-rpc/private/diagnostics_v1.mli b/otherlibs/dune-rpc/private/diagnostics_v1.mli new file mode 100644 index 00000000000..f82a33c63f1 --- /dev/null +++ b/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 diff --git a/otherlibs/dune-rpc/private/exported_types.ml b/otherlibs/dune-rpc/private/exported_types.ml index f497d494cd3..5938b4354d4 100644 --- a/otherlibs/dune-rpc/private/exported_types.ml +++ b/otherlibs/dune-rpc/private/exported_types.ml @@ -34,6 +34,240 @@ module Loc = struct ;; end +module Ansi_color = struct + module RGB8 = struct + include Stdune.Ansi_color.RGB8 + + let sexp = + Conv.iso Conv.char Stdune.Ansi_color.RGB8.of_char Stdune.Ansi_color.RGB8.to_char + ;; + end + + module RGB24 = struct + include Stdune.Ansi_color.RGB24 + + let sexp = + Conv.iso Conv.int Stdune.Ansi_color.RGB24.of_int Stdune.Ansi_color.RGB24.to_int + ;; + end + + module Style = struct + type t = Stdune.Ansi_color.Style.t + + let sexp = + let open Conv in + let fg_default = constr "Fg_default" unit (fun () -> `Fg_default) in + let fg_black = constr "Fg_black" unit (fun () -> `Fg_black) in + let fg_red = constr "Fg_red" unit (fun () -> `Fg_red) in + let fg_green = constr "Fg_green" unit (fun () -> `Fg_green) in + let fg_yellow = constr "Fg_yellow" unit (fun () -> `Fg_yellow) in + let fg_blue = constr "Fg_blue" unit (fun () -> `Fg_blue) in + let fg_magenta = constr "Fg_magenta" unit (fun () -> `Fg_magenta) in + let fg_cyan = constr "Fg_cyan" unit (fun () -> `Fg_cyan) in + let fg_white = constr "Fg_white" unit (fun () -> `Fg_white) in + let fg_bright_black = constr "Fg_bright_black" unit (fun () -> `Fg_bright_black) in + let fg_bright_red = constr "Fg_bright_red" unit (fun () -> `Fg_bright_red) in + let fg_bright_green = constr "Fg_bright_green" unit (fun () -> `Fg_bright_green) in + let fg_bright_yellow = + constr "Fg_bright_yellow" unit (fun () -> `Fg_bright_yellow) + in + let fg_bright_blue = constr "Fg_bright_blue" unit (fun () -> `Fg_bright_blue) in + let fg_bright_magenta = + constr "Fg_bright_magenta" unit (fun () -> `Fg_bright_magenta) + in + let fg_bright_cyan = constr "Fg_bright_cyan" unit (fun () -> `Fg_bright_cyan) in + let fg_bright_white = constr "Fg_bright_white" unit (fun () -> `Fg_bright_white) in + let fg_8_bit_color = + constr "Fg_8_bit_color" RGB8.sexp (fun c -> `Fg_8_bit_color c) + in + let fg_24_bit_color = + constr "Fg_24_bit_color" RGB24.sexp (fun c -> `Fg_24_bit_color c) + in + let bg_default = constr "Bg_default" unit (fun () -> `Bg_default) in + let bg_black = constr "Bg_black" unit (fun () -> `Bg_black) in + let bg_red = constr "Bg_red" unit (fun () -> `Bg_red) in + let bg_green = constr "Bg_green" unit (fun () -> `Bg_green) in + let bg_yellow = constr "Bg_yellow" unit (fun () -> `Bg_yellow) in + let bg_blue = constr "Bg_blue" unit (fun () -> `Bg_blue) in + let bg_magenta = constr "Bg_magenta" unit (fun () -> `Bg_magenta) in + let bg_cyan = constr "Bg_cyan" unit (fun () -> `Bg_cyan) in + let bg_white = constr "Bg_white" unit (fun () -> `Bg_white) in + let bg_bright_black = constr "Bg_bright_black" unit (fun () -> `Bg_bright_black) in + let bg_bright_red = constr "Bg_bright_red" unit (fun () -> `Bg_bright_red) in + let bg_bright_green = constr "Bg_bright_green" unit (fun () -> `Bg_bright_green) in + let bg_bright_yellow = + constr "Bg_bright_yellow" unit (fun () -> `Bg_bright_yellow) + in + let bg_bright_blue = constr "Bg_bright_blue" unit (fun () -> `Bg_bright_blue) in + let bg_bright_magenta = + constr "Bg_bright_magenta" unit (fun () -> `Bg_bright_magenta) + in + let bg_bright_cyan = constr "Bg_bright_cyan" unit (fun () -> `Bg_bright_cyan) in + let bg_bright_white = constr "Bg_bright_white" unit (fun () -> `Bg_bright_white) in + let bg_8_bit_color = + constr "Bg_8_bit_color" RGB8.sexp (fun c -> `Bg_8_bit_color c) + in + let bg_24_bit_color = + constr "Bg_24_bit_color" RGB24.sexp (fun c -> `Bg_24_bit_color c) + in + let bold = constr "Bold" unit (fun () -> `Bold) in + let dim = constr "Dim" unit (fun () -> `Dim) in + let italic = constr "Italic" unit (fun () -> `Italic) in + let underline = constr "Underline" unit (fun () -> `Underline) in + sum + [ econstr fg_default + ; econstr fg_black + ; econstr fg_red + ; econstr fg_green + ; econstr fg_yellow + ; econstr fg_blue + ; econstr fg_magenta + ; econstr fg_cyan + ; econstr fg_white + ; econstr fg_bright_black + ; econstr fg_bright_red + ; econstr fg_bright_green + ; econstr fg_bright_yellow + ; econstr fg_bright_blue + ; econstr fg_bright_magenta + ; econstr fg_bright_cyan + ; econstr fg_bright_white + ; econstr fg_8_bit_color + ; econstr fg_24_bit_color + ; econstr bg_default + ; econstr bg_black + ; econstr bg_red + ; econstr bg_green + ; econstr bg_yellow + ; econstr bg_blue + ; econstr bg_magenta + ; econstr bg_cyan + ; econstr bg_white + ; econstr bg_bright_black + ; econstr bg_bright_red + ; econstr bg_bright_green + ; econstr bg_bright_yellow + ; econstr bg_bright_blue + ; econstr bg_bright_magenta + ; econstr bg_bright_cyan + ; econstr bg_bright_white + ; econstr bg_8_bit_color + ; econstr bg_24_bit_color + ; econstr bold + ; econstr dim + ; econstr italic + ; econstr underline + ] + (function + | `Fg_default -> case () fg_default + | `Fg_black -> case () fg_black + | `Fg_red -> case () fg_red + | `Fg_green -> case () fg_green + | `Fg_yellow -> case () fg_yellow + | `Fg_blue -> case () fg_blue + | `Fg_magenta -> case () fg_magenta + | `Fg_cyan -> case () fg_cyan + | `Fg_white -> case () fg_white + | `Fg_bright_black -> case () fg_bright_black + | `Fg_bright_red -> case () fg_bright_red + | `Fg_bright_green -> case () fg_bright_green + | `Fg_bright_yellow -> case () fg_bright_yellow + | `Fg_bright_blue -> case () fg_bright_blue + | `Fg_bright_magenta -> case () fg_bright_magenta + | `Fg_bright_cyan -> case () fg_bright_cyan + | `Fg_bright_white -> case () fg_bright_white + | `Fg_8_bit_color c -> case c fg_8_bit_color + | `Fg_24_bit_color c -> case c fg_24_bit_color + | `Bg_default -> case () bg_default + | `Bg_black -> case () bg_black + | `Bg_red -> case () bg_red + | `Bg_green -> case () bg_green + | `Bg_yellow -> case () bg_yellow + | `Bg_blue -> case () bg_blue + | `Bg_magenta -> case () bg_magenta + | `Bg_cyan -> case () bg_cyan + | `Bg_white -> case () bg_white + | `Bg_bright_black -> case () bg_bright_black + | `Bg_bright_red -> case () bg_bright_red + | `Bg_bright_green -> case () bg_bright_green + | `Bg_bright_yellow -> case () bg_bright_yellow + | `Bg_bright_blue -> case () bg_bright_blue + | `Bg_bright_magenta -> case () bg_bright_magenta + | `Bg_bright_cyan -> case () bg_bright_cyan + | `Bg_bright_white -> case () bg_bright_white + | `Bg_8_bit_color c -> case c bg_8_bit_color + | `Bg_24_bit_color c -> case c bg_24_bit_color + | `Bold -> case () bold + | `Dim -> case () dim + | `Italic -> case () italic + | `Underline -> case () underline) + ;; + end +end + +module User_message = struct + module Style = struct + type t = Stdune.User_message.Style.t = + | Loc + | Error + | Warning + | Kwd + | Id + | Prompt + | Hint + | Details + | Ok + | Debug + | Success + | Ansi_styles of Ansi_color.Style.t list + + let sexp = + let open Conv in + let loc = constr "Loc" unit (fun () -> Loc) in + let error = constr "Error" unit (fun () -> Error) in + let warning = constr "Warning" unit (fun () -> Warning) in + let kwd = constr "Kwd" unit (fun () -> Kwd) in + let id = constr "Id" unit (fun () -> Id) in + let prompt = constr "Prompt" unit (fun () -> Prompt) in + let hint = constr "Hint" unit (fun () -> Hint) in + let details = constr "Details" unit (fun () -> Details) in + let ok = constr "Ok" unit (fun () -> Ok) in + let debug = constr "Debug" unit (fun () -> Debug) in + let success = constr "Success" unit (fun () -> Success) in + let ansi_styles = + constr "Ansi_styles" (list Ansi_color.Style.sexp) (fun l -> Ansi_styles l) + in + sum + [ econstr loc + ; econstr error + ; econstr warning + ; econstr kwd + ; econstr id + ; econstr prompt + ; econstr hint + ; econstr details + ; econstr ok + ; econstr debug + ; econstr success + ; econstr ansi_styles + ] + (function + | Loc -> case () loc + | Error -> case () error + | Warning -> case () warning + | Kwd -> case () kwd + | Id -> case () id + | Prompt -> case () prompt + | Hint -> case () hint + | Details -> case () details + | Ok -> case () ok + | Debug -> case () debug + | Success -> case () success + | Ansi_styles l -> case l ansi_styles) + ;; + end +end + module Target = struct type t = | Path of string @@ -88,6 +322,73 @@ module Path = struct let relative = Filename.concat end +(* This has a subtle difference with [sexp_pp] in how we serialise tags. *) +let sexp_pp_unit : unit Pp.t Conv.value = + let open Conv in + let open Pp.Ast in + let nop = constr "Nop" unit (fun () -> Nop) in + let verbatim = constr "Verbatim" string (fun s -> Verbatim s) in + let char = constr "Char" char (fun c -> Char c) in + let newline = constr "Newline" unit (fun () -> Newline) in + let t = + fixpoint (fun t -> + let text = constr "Text" string (fun s -> Text s) in + let seq = constr "Seq" (pair t t) (fun (x, y) -> Seq (x, y)) in + let concat = constr "Concat" (pair t (list t)) (fun (x, y) -> Concat (x, y)) in + let box = constr "Box" (pair int t) (fun (x, y) -> Box (x, y)) in + let vbox = constr "Vbox" (pair int t) (fun (x, y) -> Vbox (x, y)) in + let hbox = constr "Hbox" t (fun t -> Hbox t) in + let hvbox = constr "Hvbox" (pair int t) (fun (x, y) -> Hvbox (x, y)) in + let hovbox = constr "Hovbox" (pair int t) (fun (x, y) -> Hovbox (x, y)) in + let break = + constr + "Break" + (pair (triple string int string) (triple string int string)) + (fun (x, y) -> Break (x, y)) + in + let tag = constr "Tag" t (fun t -> Tag ((), t)) in + sum + [ econstr nop + ; econstr verbatim + ; econstr char + ; econstr newline + ; econstr text + ; econstr seq + ; econstr concat + ; econstr box + ; econstr vbox + ; econstr hbox + ; econstr hvbox + ; econstr hovbox + ; econstr break + ; econstr tag + ] + (function + | Nop -> case () nop + | Seq (x, y) -> case (x, y) seq + | Concat (x, y) -> case (x, y) concat + | Box (i, t) -> case (i, t) box + | Vbox (i, t) -> case (i, t) vbox + | Hbox t -> case t hbox + | Hvbox (i, t) -> case (i, t) hvbox + | Hovbox (i, t) -> case (i, t) hovbox + | Verbatim s -> case s verbatim + | Char c -> case c char + | Break (x, y) -> case (x, y) break + | Newline -> case () newline + | Text s -> case s text + | Tag ((), t) -> case t tag)) + in + let to_ast x = + match Pp.to_ast x with + | Ok s -> s + | Error () -> + (* We don't use the format constructor in dune. *) + assert false + in + iso t Pp.of_ast to_ast +;; + module Diagnostic = struct type severity = | Error @@ -112,7 +413,7 @@ module Diagnostic = struct ;; end - let sexp_pp : (unit Pp.t, Conv.values) Conv.t = + let sexp_pp (conv_tag : 'a Conv.value) : 'a Pp.t Conv.value = let open Conv in let open Pp.Ast in let nop = constr "Nop" unit (fun () -> Nop) in @@ -135,7 +436,7 @@ module Diagnostic = struct (pair (triple string int string) (triple string int string)) (fun (x, y) -> Break (x, y)) in - let tag = constr "Tag" t (fun t -> Tag ((), t)) in + let tag = constr "Tag" (pair conv_tag t) (fun (s, t) -> Tag (s, t)) in sum [ econstr nop ; econstr verbatim @@ -166,7 +467,7 @@ module Diagnostic = struct | Break (x, y) -> case (x, y) break | Newline -> case () newline | Text s -> case s text - | Tag ((), t) -> case t tag)) + | Tag (s, t) -> case (s, t) tag)) in let to_ast x = match Pp.to_ast x with @@ -189,17 +490,18 @@ module Diagnostic = struct module Related = struct type t = - { message : unit Pp.t + { message : User_message.Style.t Pp.t ; loc : Loc.t } - let message t = t.message + let message t = t.message |> Pp.map_tags ~f:(fun _ -> ()) + let message_with_style t = t.message let loc t = t.loc let sexp = let open Conv in let loc = field "loc" (required Loc.sexp) in - let message = field "message" (required sexp_pp) in + let message = field "message" (required (sexp_pp User_message.Style.sexp)) in let to_ (loc, message) = { loc; message } in let from { loc; message } = loc, message in iso (record (both loc message)) to_ from @@ -209,7 +511,7 @@ module Diagnostic = struct type t = { targets : Target.t list ; id : Id.t - ; message : unit Pp.t + ; message : User_message.Style.t Pp.t ; loc : Loc.t option ; severity : severity option ; promotion : Promotion.t list @@ -218,7 +520,8 @@ module Diagnostic = struct } let loc t = t.loc - let message t = t.message + let message t = t.message |> Pp.map_tags ~f:(fun _ -> ()) + let message_with_style t = t.message let severity t = t.severity let promotion t = t.promotion let targets t = t.targets @@ -240,7 +543,7 @@ module Diagnostic = struct { targets; message; loc; severity; promotion; directory; id; related } in let loc = field "loc" (optional Loc.sexp) in - let message = field "message" (required sexp_pp) in + let message = field "message" (required (sexp_pp User_message.Style.sexp)) 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 @@ -256,35 +559,8 @@ 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) - (Stdune.Loc.of_lexbuf_loc l |> Stdune.Loc.pp) - ] - in - Stdune.User_message.make - ?prefix - (directory - @ formatted_loc - @ [ Pp.map_tags ~f:(fun _ -> Stdune.User_message.Style.Details) t.message ]) + let loc = Option.map t.loc ~f:Stdune.Loc.of_lexbuf_loc in + Stdune.User_message.make ?loc [ t.message ] ;; module Event = struct @@ -394,7 +670,7 @@ module Job = struct let id = field "id" (required Id.sexp) in let started_at = field "started_at" (required float) in let pid = field "pid" (required int) in - let description = field "description" (required Diagnostic.sexp_pp) in + let description = field "description" (required sexp_pp_unit) in iso (record (four id pid description started_at)) to_ from ;; diff --git a/otherlibs/dune-rpc/private/exported_types.mli b/otherlibs/dune-rpc/private/exported_types.mli index d6401f11afe..48315b1ede1 100644 --- a/otherlibs/dune-rpc/private/exported_types.mli +++ b/otherlibs/dune-rpc/private/exported_types.mli @@ -11,6 +11,10 @@ module Loc : sig val sexp : t Conv.value end +(** This is kept around for compatibility reasons. Before we serialised [Pp.t] tags as + [(Tag pp)] but now we serialise them as [Tag (pair tag pp)]. *) +val sexp_pp_unit : unit Pp.t Conv.value + module Target : sig type t = | Path of string @@ -33,6 +37,52 @@ module Path : sig val sexp : t Conv.value end +module Ansi_color : sig + module RGB8 : sig + type t = Stdune.Ansi_color.RGB8.t + + val to_int : t -> int + val of_int : int -> t + val sexp : t Conv.value + end + + module RGB24 : sig + type t = Stdune.Ansi_color.RGB24.t + + val to_int : t -> int + val of_int : int -> t + val red : t -> int + val green : t -> int + val blue : t -> int + val make : red:int -> green:int -> blue:int -> t + val sexp : t Conv.value + end + + module Style : sig + type t = Stdune.Ansi_color.Style.t + + val sexp : t Conv.value + end +end + +module User_message : sig + module Style : sig + type t = Stdune.User_message.Style.t = + | Loc + | Error + | Warning + | Kwd + | Id + | Prompt + | Hint + | Details + | Ok + | Debug + | Success + | Ansi_styles of Ansi_color.Style.t list + end +end + module Diagnostic : sig type severity = | Error @@ -60,11 +110,12 @@ module Diagnostic : sig module Related : sig type t = - { message : unit Pp.t + { message : User_message.Style.t Pp.t ; loc : Loc.t } val message : t -> unit Pp.t + val message_with_style : t -> User_message.Style.t Pp.t val loc : t -> Loc.t val sexp : t Conv.value end @@ -72,7 +123,7 @@ module Diagnostic : sig type t = { targets : Target.t list ; id : Id.t - ; message : unit Pp.t + ; message : User_message.Style.t Pp.t ; loc : Loc.t option ; severity : severity option ; promotion : Promotion.t list @@ -84,6 +135,7 @@ module Diagnostic : sig val id : t -> Id.t val loc : t -> Loc.t option 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 val targets : t -> Target.t list diff --git a/otherlibs/dune-rpc/private/procedures.ml b/otherlibs/dune-rpc/private/procedures.ml index 0f49f2d495d..f08f3de0f8f 100644 --- a/otherlibs/dune-rpc/private/procedures.ml +++ b/otherlibs/dune-rpc/private/procedures.ml @@ -10,13 +10,24 @@ module Public = struct module Diagnostics = struct let v1 = + Decl.Request.make_gen + ~version:1 + ~req:Conv.unit + ~resp:(Conv.list Diagnostics_v1.sexp) + ~upgrade_req:Fun.id + ~downgrade_req:Fun.id + ~upgrade_resp:(List.map ~f:Diagnostics_v1.to_diagnostic) + ~downgrade_resp:(List.map ~f:Diagnostics_v1.of_diagnostic) + ;; + + let v2 = Decl.Request.make_current_gen + ~version:2 ~req:Conv.unit ~resp:(Conv.list Diagnostic.sexp) - ~version:1 ;; - let decl = Decl.Request.make ~method_:"diagnostics" ~generations:[ v1 ] + let decl = Decl.Request.make ~method_:"diagnostics" ~generations:[ v1; v2 ] end module Shutdown = struct @@ -184,10 +195,21 @@ module Poll = struct let name = "diagnostic" let v1 = + Decl.Request.make_gen + ~version:1 + ~req:Id.sexp + ~resp:(Conv.option (Conv.list Diagnostics_v1.Event.sexp)) + ~upgrade_req:Fun.id + ~downgrade_req:Fun.id + ~upgrade_resp:(Option.map ~f:(List.map ~f:Diagnostics_v1.Event.to_event)) + ~downgrade_resp:(Option.map ~f:(List.map ~f:Diagnostics_v1.Event.of_event)) + ;; + + let v2 = Decl.Request.make_current_gen + ~version:2 ~req:Id.sexp ~resp:(Conv.option (Conv.list Diagnostic.Event.sexp)) - ~version:1 ;; end @@ -209,7 +231,7 @@ module Poll = struct let diagnostic = let open Diagnostic in - make name [ v1 ] + make name [ v1; v2 ] ;; let running_jobs = diff --git a/otherlibs/stdune/src/ansi_color.ml b/otherlibs/stdune/src/ansi_color.ml index 57a533211c9..3da20d05158 100644 --- a/otherlibs/stdune/src/ansi_color.ml +++ b/otherlibs/stdune/src/ansi_color.ml @@ -4,13 +4,17 @@ module RGB8 : sig val to_dyn : t -> Dyn.t val of_int : int -> t val to_int : t -> int + val of_char : char -> t + val to_char : t -> char val compare : t -> t -> Ordering.t - (** This is only used internally. *) + (* This is only used internally. *) val write_to_buffer : Buffer.t -> t -> unit end = struct type t = char + let of_char t = t + let to_char t = t let to_dyn t = Dyn.Int (int_of_char t) let of_int t = char_of_int (t land 0xFF) let to_int t = int_of_char t @@ -30,9 +34,11 @@ module RGB24 : sig val red : t -> int val green : t -> int val blue : t -> int - val create : r:int -> g:int -> b:int -> t + val make : red:int -> green:int -> blue:int -> t + val to_int : t -> int + val of_int : int -> t - (** This is only used internally. *) + (* This is only used internally. *) val write_to_buffer : Buffer.t -> t -> unit end = struct type t = int @@ -42,7 +48,12 @@ end = struct let green t = Int.shift_right t 8 land 0xFF let blue t = t land 0xFF let to_dyn t = Dyn.list Dyn.int [ red t; green t; blue t ] - let create ~r ~g ~b = ((r land 0xFF) lsl 16) lor ((g land 0xFF) lsl 8) lor (b land 0xFF) + let to_int t = t + let of_int t = t + + let make ~red ~green ~blue = + ((red land 0xFF) lsl 16) lor ((green land 0xFF) lsl 8) lor (blue land 0xFF) + ;; let write_to_buffer buf t = Buffer.add_string buf "38;2;"; @@ -564,14 +575,16 @@ let rec parse_styles l (accu : Style.t list) = parse_styles l (match Int.of_string r, Int.of_string g, Int.of_string b with - | Some r, Some g, Some b -> `Fg_24_bit_color (RGB24.create ~r ~g ~b) :: accu + | Some red, Some green, Some blue -> + `Fg_24_bit_color (RGB24.make ~red ~green ~blue) :: accu | _ -> accu) (* Parsing 24-bit background colors *) | "48" :: "2" :: r :: g :: b :: l -> parse_styles l (match Int.of_string r, Int.of_string g, Int.of_string b with - | Some r, Some g, Some b -> `Bg_24_bit_color (RGB24.create ~r ~g ~b) :: accu + | Some red, Some green, Some blue -> + `Bg_24_bit_color (RGB24.make ~red ~green ~blue) :: accu | _ -> accu) | s :: l -> parse_styles diff --git a/otherlibs/stdune/src/ansi_color.mli b/otherlibs/stdune/src/ansi_color.mli index ac672c31a5e..cedf0366c43 100644 --- a/otherlibs/stdune/src/ansi_color.mli +++ b/otherlibs/stdune/src/ansi_color.mli @@ -4,6 +4,16 @@ module RGB8 : sig (** [RGB8.to_int t] returns the [int] value of [t] as an 8 bit integer. *) val to_int : t -> int + + (** [RGB8.of_int i] creates an [RGB8.t] from an [int] considered as an 8 bit integer. + The first 24 bits are discarded. *) + val of_int : int -> t + + (** [RGB8.of_char c] creates an [RGB8.t] from a [char] considered as an 8 bit integer. *) + val of_char : char -> t + + (** [RGB8.to_char t] returns the [char] value of [t] considered as an 8 bit integer. *) + val to_char : t -> char end module RGB24 : sig @@ -18,6 +28,16 @@ module RGB24 : sig (** [RGB24.blue t] returns the blue component of [t] *) val blue : t -> int + + (** [RGB24.make ~red ~green ~blue] creates an [RGB24.t] from the given components *) + val make : red:int -> green:int -> blue:int -> t + + (** [RGB24.to_int t] returns the [int] value of [t] as a 24 bit integer. *) + val to_int : t -> int + + (** [RGB24.of_int i] creates an [RGB24.t] from an [int] considered as a 24 bit integer. + The first 8 bits are discarded. *) + val of_int : int -> t end module Style : sig diff --git a/src/dune_rpc_impl/diagnostics.ml b/src/dune_rpc_impl/diagnostics.ml index d828c2686e3..361c1fdc54d 100644 --- a/src/dune_rpc_impl/diagnostics.ml +++ b/src/dune_rpc_impl/diagnostics.ml @@ -32,7 +32,6 @@ let diagnostic_of_error : Build_system_error.t -> Dune_rpc_private.Diagnostic.t | `Diagnostic { Compound_user_error.main = message; related } -> message, related in let loc = Option.map message.loc ~f:make_loc in - let make_message pars = Pp.map_tags (Pp.concat pars) ~f:(fun _ -> ()) in let id = Build_system_error.id m |> Build_system_error.Id.to_int |> Diagnostic.Id.create in @@ -48,14 +47,28 @@ let diagnostic_of_error : Build_system_error.t -> Dune_rpc_private.Diagnostic.t in let related = List.map related ~f:(fun (related : User_message.t) -> - { Dune_rpc_private.Diagnostic.Related.message = make_message related.paragraphs + { Dune_rpc_private.Diagnostic.Related.message = Pp.concat related.paragraphs ; loc = make_loc (Option.value_exn related.loc) }) in + let message = + let paragraphs = + let paragraphs = message.paragraphs in + match message.hints with + | [] -> paragraphs + | _ -> + let open Pp.O in + List.append + paragraphs + (List.map message.hints ~f:(fun hint -> + Pp.tag User_message.Style.Hint (Pp.verbatim "Hint:") ++ Pp.space ++ hint)) + in + List.map paragraphs ~f:Pp.box |> Pp.concat ~sep:Pp.cut |> Pp.vbox + in { Dune_rpc_private.Diagnostic.severity = Some Dune_rpc_private.Diagnostic.Error ; id ; targets = [] - ; message = make_message message.paragraphs + ; message ; loc ; promotion ; related diff --git a/src/dune_rpc_server/dune_rpc_server.ml b/src/dune_rpc_server/dune_rpc_server.ml index 2f412cb580d..1b903d1772c 100644 --- a/src/dune_rpc_server/dune_rpc_server.ml +++ b/src/dune_rpc_server/dune_rpc_server.ml @@ -2,6 +2,7 @@ open Stdune open Dune_rpc_private open Fiber.O module Session_id = Stdune.Id.Make () +module User_message = Stdune.User_message type error = { message : User_message.t diff --git a/test/expect-tests/dune_rpc/dune_rpc_tests.ml b/test/expect-tests/dune_rpc/dune_rpc_tests.ml index 01b2310fb53..bc8af7fc46b 100644 --- a/test/expect-tests/dune_rpc/dune_rpc_tests.ml +++ b/test/expect-tests/dune_rpc/dune_rpc_tests.ml @@ -882,6 +882,9 @@ let%expect_test "print digests for all public RPCs" = Version 1: Request: Unit Response: ffd3de9652c685594aacfc51d28f2533 + Version 2: + Request: Unit + Response: 0d4442e0c36d6727a9acf9aabce6a6ad |}]; Decl.Notification.print_generations Procedures.Public.shutdown; [%expect {| Version 1: Unit |}]; @@ -924,6 +927,9 @@ let%expect_test "print digests for all public RPCs" = Version 1: Request: Sexp Response: 443627a52ab5595206164d020ff01c56 + Version 2: + Request: Sexp + Response: 12995aa06697c01ef35c0339bd2fa29e |}]; Decl.Request.print_generations (Procedures.Poll.poll Procedures.Poll.running_jobs); [%expect diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml index 3a9fa1835c5..625d70f1ef9 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml @@ -240,8 +240,7 @@ let%expect_test "related error" = ] ] ; [ "message" - ; [ "Verbatim"; "Module \"Foo\" is used in several\n\ - stanzas:\n\ + ; [ "Verbatim"; "Module \"Foo\" is used in several stanzas:\n\ " ] ] ; [ "promotion"; [] ] @@ -311,8 +310,7 @@ let%expect_test "promotion" = ] ; [ "message" ; [ "Verbatim" - ; "Error: Files _build/default/x and _build/default/x.gen\n\ - differ.\n\ + ; "Error: Files _build/default/x and _build/default/x.gen differ.\n\ " ] ] @@ -430,8 +428,8 @@ let%expect_test "error from user rule" = ] ; [ "message" ; [ "Verbatim" - ; "Error: Rule failed to generate the following\n\ - targets:- foo\n\ + ; "Error: Rule failed to generate the following targets:\n\ + - foo\n\ " ] ] @@ -471,8 +469,7 @@ let%expect_test "library error location" = ] ] ; [ "message" - ; [ "Verbatim"; "Error: Library \"fake-library\" not\n\ - found.\n\ + ; [ "Verbatim"; "Error: Library \"fake-library\" not found.\n\ " ] ] ; [ "promotion"; [] ] diff --git a/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml index bd4c24105fe..fb0426299ee 100644 --- a/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml +++ b/test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml @@ -48,7 +48,7 @@ let%expect_test "serialize and deserialize error message" = ---- Original ---- Error: Oh no! ------- RPC ------ - Error: Error: Oh no! + Error: Oh no! ---- Original ---- Vbox 0,Seq @@ -64,18 +64,18 @@ let%expect_test "serialize and deserialize error message" = Vbox 0,Seq Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" - ; Concat - Break ("", 1, ""),("", 0, ""), - [ Seq - Tag - Details,Verbatim "Error", - Char - : - ; Verbatim "Oh no!" - ] - ],Break ("", 0, ""),("", 0, "") |}] + 0,Vbox + 0,Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Error,Verbatim + "Error", + Char + : + ; Verbatim "Oh no!" + ],Break + ("", 0, ""),("", 0, "") |}] ;; let%expect_test "serialize and deserialize error message with location" = @@ -90,9 +90,7 @@ let%expect_test "serialize and deserialize error message with location" = File "Bar", line 1, characters 2-3: Error: An error with location! ------- RPC ------ - Error: (In directory /Foo) File "/Foo/Bar", line 1, characters 2-3: - Error: An error with location! ---- Original ---- Vbox @@ -119,36 +117,26 @@ let%expect_test "serialize and deserialize error message with location" = Vbox 0,Concat Nop,[ Seq - Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" - ; Tag - Loc,Text - "(In directory /Foo)" - ],Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Seq - Seq - Tag - Loc,Verbatim - "File \"/Foo/Bar\", line 1, characters 2-3:",Newline,Nop, + Box 0,Tag Loc,Text "File \"/Foo/Bar\", line 1, characters 2-3:", Break ("", 0, ""),("", 0, "") ; Seq Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Details,Verbatim + 0,Vbox + 0,Box + 0,Concat + Break ("", 1, ""),("", 0, ""),[ Seq + Tag + Error, + Verbatim "Error", - Char - : - ; Verbatim - "An error with location!" - ],Break - ("", 0, ""),("", 0, "") + Char + : + ; Verbatim + "An error with location!" + ],Break + ("", 0, ""), + ("", 0, "") ] |}] ;; @@ -171,13 +159,12 @@ let%expect_test "serialize and deserialize error with location exerpt and hint" Hint: Hint 1 Hint: Hint 2 ------- RPC ------ - Error: (In directory - TEST) File "TEST/foo.ml", line 1, characters 2-3: 1 | let x = 1 ^ - Error: An error with location! + Hint: Hint 1 + Hint: Hint 2 ---- Original ---- Vbox 0,Concat @@ -218,40 +205,56 @@ let%expect_test "serialize and deserialize error with location exerpt and hint" 0,Concat Nop,[ Seq Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Tag Error,Text "Error:" - ; Tag - Loc,Text - "(In directory TEST)" - ],Break - ("", 0, ""),("", 0, "") - ; Seq - Box - 0,Seq - Seq - Tag - Loc,Verbatim - "File \"TEST/foo.ml\", line 1, characters 2-3:",Newline, - Seq - Seq - Seq - Seq - Seq Verbatim "1",Verbatim " | ",Verbatim - "let x = 1",Newline, - Verbatim - " ^",Newline,Break ("", 0, ""),("", 0, "") + 0,Tag + Loc,Text + "File \"TEST/foo.ml\", line 1, characters 2-3:", + Break + ("", 0, ""),("", 0, "") ; Seq Box - 0,Concat - Break ("", 1, ""),("", 0, ""),[ Seq - Tag - Details,Verbatim - "Error", - Char - : - ; Verbatim - "An error with location!" - ],Break - ("", 0, ""),("", 0, "") + 0,Vbox + 0,Concat + Break ("", 0, ""),("", 0, ""),[ Box + 0,Concat + Break + ("", 1, ""), + ("", 0, ""), + [ Seq + Tag + Error, + Verbatim + "Error", + Char + : + ; Verbatim + "An error with location!" + ] + ; Box + 0,Seq + Seq + Tag + Hint, + Verbatim + "Hint:", + Break + ("", 1, ""), + ("", 0, ""), + Verbatim + "Hint 1" + ; Box + 0,Seq + Seq + Tag + Hint, + Verbatim + "Hint:", + Break + ("", 1, ""), + ("", 0, ""), + Verbatim + "Hint 2" + ],Break + ("", 0, ""), + ("", 0, "") ] |}] ;;