test: serialize and deserialize RPC error messages (#8411)

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,15 @@ module Error = struct
     | Diagnostic d -> `Diagnostic d.diagnostic
   ;;
 
+  module For_tests = struct
+    let make ~description ~dir ~promotion () =
+      let id = Id.gen () in
+      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

@@ -126,6 +126,19 @@ 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
+      :  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,22 @@
+(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_impl
+  dune_engine
+  dune_re
+  stdune
+  ;; 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)))

test/expect-tests/dune_rpc_impl/dune_rpc_impl_tests.ml

@@ -0,0 +1,257 @@
+open Stdune
+module Dune_rpc = Dune_rpc_private
+module Re = Dune_re
+
+let () =
+  Stdune.Path.set_root (Stdune.Path.External.of_filename_relative_to_initial_cwd ".");
+  Stdune.Path.Build.set_build_dir (Stdune.Path.Outside_build_dir.of_string "_build")
+;;
+
+let test ~dir ~f main =
+  let description =
+    `Diagnostic (Dune_engine.Compound_user_error.make ~main ~related:[])
+  in
+  Dune_console.printf "---- Original ----";
+  f main;
+  Dune_console.printf "------- RPC ------";
+  Dune_engine.Build_system.Error.For_tests.make ~description ~dir ~promotion:None ()
+  |> Dune_rpc_impl.Diagnostics.For_tests.diagnostic_of_error
+  |> Dune_rpc_private.Diagnostic.to_user_message
+  |> f
+;;
+
+let test_plain ~dir main = test main ~dir ~f:Dune_console.print_user_message
+
+let test_dyn ~dir main =
+  test main ~dir ~f:(fun x ->
+    Stdune.User_message.pp x
+    |> Pp.to_dyn Stdune.User_message.Style.to_dyn
+    |> Dyn.to_string
+    |> print_endline)
+;;
+
+let scrub output =
+  Re.replace_string
+    (Re.compile (Re.str Stdune.Path.(to_absolute_filename root)))
+    ~by:"TEST"
+    output
+  |> print_endline
+;;
+
+let%expect_test "serialize and deserialize error message" =
+  let dir = None in
+  let message = User_error.make [ Pp.verbatim "Oh no!" ] in
+  test_plain ~dir message;
+  test_dyn ~dir message;
+  [%expect
+    {|
+    ---- Original ----
+    Error: Oh no!
+    ------- RPC ------
+    Error: Error: Oh no!
+    ---- Original ----
+    Vbox
+      0,Seq
+          Box
+            0,Concat
+                Break ("", 1, ""),("", 0, ""),[ Seq
+                                                  Tag Error,Verbatim "Error",
+                                                  Char
+                                                    :
+                                              ; Verbatim "Oh no!"
+                                              ],Break ("", 0, ""),("", 0, "")
+    ------- RPC ------
+    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, "") |}]
+;;
+
+let%expect_test "serialize and deserialize error message with location" =
+  let loc = Stdune.Loc.of_pos ("Bar", 1, 2, 3) in
+  let dir = Some (Stdune.Path.of_string "/Foo") in
+  let message = User_error.make ~loc [ Pp.verbatim "An error with location!" ] in
+  test_plain ~dir message;
+  test_dyn ~dir message;
+  [%expect
+    {|
+    ---- Original ----
+    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
+      0,Concat
+          Nop,[ Seq
+                  Box 0,Tag Loc,Text "File \"Bar\", line 1, characters 2-3:",
+                  Break
+                    ("", 0, ""),("", 0, "")
+              ; Seq
+                  Box
+                    0,Concat
+                        Break ("", 1, ""),("", 0, ""),[ Seq
+                                                          Tag
+                                                            Error,Verbatim
+                                                                    "Error",
+                                                          Char
+                                                            :
+                                                      ; Verbatim
+                                                          "An error with location!"
+                                                      ],Break
+                                                          ("", 0, ""),("", 0, "")
+              ]
+    ------- RPC ------
+    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,
+                  Break
+                    ("", 0, ""),("", 0, "")
+              ; Seq
+                  Box
+                    0,Concat
+                        Break ("", 1, ""),("", 0, ""),[ Seq
+                                                          Tag
+                                                            Details,Verbatim
+                                                                      "Error",
+                                                          Char
+                                                            :
+                                                      ; Verbatim
+                                                          "An error with location!"
+                                                      ],Break
+                                                          ("", 0, ""),("", 0, "")
+              ] |}]
+;;
+
+let%expect_test "serialize and deserialize error with location exerpt and hint" =
+  Io.String_path.write_file "foo.ml" "let x = 1\nlet y = 2\nlet z = 3\n";
+  let loc = Stdune.Loc.of_pos ("foo.ml", 1, 2, 3) in
+  let dir = Some (Stdune.Path.of_string ".") in
+  let hints = [ Pp.verbatim "Hint 1"; Pp.verbatim "Hint 2" ] in
+  let message = User_error.make ~loc ~hints [ Pp.verbatim "An error with location!" ] in
+  test_plain ~dir message;
+  test_dyn ~dir message;
+  scrub [%expect.output];
+  [%expect
+    {|
+    ---- Original ----
+    File "foo.ml", line 1, characters 2-3:
+    1 | let x = 1
+          ^
+    Error: An error with location!
+    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!
+    ---- Original ----
+    Vbox
+      0,Concat
+          Nop,[ Seq
+                  Box 0,Tag Loc,Text "File \"foo.ml\", line 1, characters 2-3:",
+                  Break
+                    ("", 0, ""),("", 0, "")
+              ; Seq
+                  Box
+                    0,Concat
+                        Break ("", 1, ""),("", 0, ""),[ Seq
+                                                          Tag
+                                                            Error,Verbatim
+                                                                    "Error",
+                                                          Char
+                                                            :
+                                                      ; Verbatim
+                                                          "An error with location!"
+                                                      ],Break
+                                                          ("", 0, ""),("", 0, "")
+              ; Seq
+                  Box
+                    0,Seq
+                        Seq
+                          Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""),
+                        Verbatim
+                          "Hint 1",Break ("", 0, ""),("", 0, "")
+              ; Seq
+                  Box
+                    0,Seq
+                        Seq
+                          Tag Hint,Verbatim "Hint:",Break ("", 1, ""),("", 0, ""),
+                        Verbatim
+                          "Hint 2",Break ("", 0, ""),("", 0, "")
+              ]
+    ------- RPC ------
+    Vbox
+      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, "")
+              ; Seq
+                  Box
+                    0,Concat
+                        Break ("", 1, ""),("", 0, ""),[ Seq
+                                                          Tag
+                                                            Details,Verbatim
+                                                                      "Error",
+                                                          Char
+                                                            :
+                                                      ; Verbatim
+                                                          "An error with location!"
+                                                      ],Break
+                                                          ("", 0, ""),("", 0, "")
+              ] |}]
+;;