test: serialize and deserialize RPC error messages

We demonstrate a bug with how error messages are serialized. Currently
there are two "Error:" prefixes after serializing and deserializing.
This is because the prefix hasn't been stripped in the initial
serialization. We should strip the prefix since the severity information
is recorded elsewhere in the diagnostic data.

Signed-off-by: Ali Caglayan <alizter@gmail.com>

otherlibs/stdune/src/stdune.ml

@@ -30,6 +30,32 @@ module Pp = struct
   let compare ~compare x y =
     Ordering.of_int (Pp.compare (fun a b -> Ordering.to_int (compare a b)) x y)
   ;;
+
+  let to_dyn tag_to_dyn t =
+    match Pp.to_ast t with
+    | Error _ -> Dyn.variant "Contains Format" [ Dyn.opaque "<error>" ]
+    | Ok t ->
+      let open Dyn in
+      let rec to_dyn t =
+        match (t : _ Pp.Ast.t) with
+        | Nop -> variant "Nop" []
+        | Seq (x, y) -> variant "Seq" [ to_dyn x; to_dyn y ]
+        | Concat (x, y) -> variant "Concat" [ to_dyn x; list to_dyn y ]
+        | Box (i, t) -> variant "Box" [ int i; to_dyn t ]
+        | Vbox (i, t) -> variant "Vbox" [ int i; to_dyn t ]
+        | Hbox t -> variant "Hbox" [ to_dyn t ]
+        | Hvbox (i, t) -> variant "Hvbox" [ int i; to_dyn t ]
+        | Hovbox (i, t) -> variant "Hovbox" [ int i; to_dyn t ]
+        | Verbatim s -> variant "Verbatim" [ string s ]
+        | Char c -> variant "Char" [ char c ]
+        | Break (x, y) ->
+          variant "Break" [ triple string int string x; triple string int string y ]
+        | Newline -> variant "Newline" []
+        | Text s -> variant "Text" [ string s ]
+        | Tag (s, t) -> variant "Tag" [ tag_to_dyn s; to_dyn t ]
+      in
+      to_dyn t
+  ;;
 end
 
 module Result = Result

otherlibs/stdune/src/user_message.ml

@@ -13,6 +13,23 @@ module Style = struct
     | Success
     | Ansi_styles of Ansi_color.Style.t list
 
+  let to_dyn =
+    let open Dyn in
+    function
+    | Loc -> variant "Loc" []
+    | Error -> variant "Error" []
+    | Warning -> variant "Warning" []
+    | Kwd -> variant "Kwd" []
+    | Id -> variant "Id" []
+    | Prompt -> variant "Prompt" []
+    | Hint -> variant "Hint" []
+    | Details -> variant "Details" []
+    | Ok -> variant "Ok" []
+    | Debug -> variant "Debug" []
+    | Success -> variant "Success" []
+    | Ansi_styles l -> variant "Ansi_styles" [ list Ansi_color.Style.to_dyn l ]
+  ;;
+
   let compare t1 t2 : Ordering.t =
     match t1, t2 with
     | Loc, Loc -> Eq

otherlibs/stdune/src/user_message.mli

@@ -22,6 +22,7 @@ module Style : sig
     | Success
     | Ansi_styles of Ansi_color.Style.t list
 
+  val to_dyn : t -> Dyn.t
   val compare : t -> t -> Ordering.t
 end
 

src/dune_engine/build_system.ml

@@ -92,6 +92,14 @@ module Error = struct
     | Diagnostic d -> `Diagnostic d.diagnostic
   ;;
 
+  module For_tests = struct
+    let make ~id ~description ~dir ~promotion () =
+      match description with
+      | `Exn exn -> Exn { id; exn }
+      | `Diagnostic diagnostic -> Diagnostic { id; diagnostic; dir; promotion }
+    ;;
+  end
+
   module Set : sig
     type error := t
 

src/dune_engine/build_system.mli

@@ -88,6 +88,7 @@ module Error : sig
 
     module Map : Map.S with type key = t
 
+    val gen : unit -> t
     val compare : t -> t -> Ordering.t
     val to_int : t -> int
     val to_dyn : t -> Dyn.t
@@ -126,6 +127,20 @@ module Error : sig
     val current : t -> error Id.Map.t
     val empty : t
   end
+
+  module For_tests : sig
+    (** Internal helpers for testing purposes. Do not use. *)
+
+    (** Construct an [Error.t] *)
+    val make
+      :  id:Id.t
+      -> description:
+           [ `Exn of Exn_with_backtrace.t | `Diagnostic of Compound_user_error.t ]
+      -> dir:Path.t option
+      -> promotion:Diff_promotion.Annot.t option
+      -> unit
+      -> t
+  end
 end
 
 (** The current set of active errors. *)

src/dune_rpc_impl/dune_rpc_impl.ml

@@ -6,6 +6,12 @@ module Private = Dune_rpc_client.Private
 module Watch_mode_config = Watch_mode_config
 module Where = Dune_rpc_client.Where
 
+module Diagnostics = struct
+  module For_tests = struct
+    let diagnostic_of_error = Diagnostics.diagnostic_of_error
+  end
+end
+
 module Poll_active =
   Dune_rpc_private.Registry.Poll
     (Fiber)

test/expect-tests/dune_rpc_impl/dune

@@ -0,0 +1,27 @@
+(library
+ (name dune_rpc_impl_tests)
+ (modules dune_rpc_impl_tests)
+ (inline_tests)
+ (libraries
+  ocaml_config
+  dune_util
+  dune_console
+  dune_rpc_private
+  dune_rpc_server
+  dune_rpc_impl
+  dune_rpc_client
+  dune_engine
+  dune_re
+  stdune
+  test_scheduler
+  csexp
+  fiber
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect.config
+  ppx_expect.config_types
+  ppx_expect.common
+  base
+  ppx_inline_test.config)
+ (preprocess
+  (pps ppx_expect)))