Add Stdune.Code_error

This new code_error exception uses Dyn.t rather than Sexp.t

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

src/report_error.ml

@@ -46,12 +46,12 @@ let builtin_printer = function
         Format.fprintf ppf "%s\n" (String.capitalize msg)
     in
     Some (make_printer pp)
-  | Stdune.Exn.Code_error sexp ->
+  | Code_error.E t ->
     let pp = fun ppf ->
           Format.fprintf ppf "@{<error>Internal error, please report upstream \
                               including the contents of _build/log.@}\n\
                               Description:%a\n"
-            Dyn.pp sexp
+            Dyn.pp (Code_error.to_dyn t)
     in
     Some (make_printer ~backtrace:true pp)
   | Unix.Unix_error (err, func, fname) ->

src/stdune/code_error.ml

@@ -0,0 +1,23 @@
+module Dyn = Dyn0
+
+type t =
+  { message : string
+  ; data : (string * Dyn.t) list
+  }
+
+exception E of t
+
+let raise message data =
+  raise (E { message; data })
+
+let to_dyn { message; data } : Dyn.t =
+  Tuple
+    [ String message
+    ; Record data
+    ]
+
+let () =
+  Printexc.register_printer (function
+    | E t -> Some (Dyn.to_string (to_dyn t))
+    | _ -> None)
+

src/stdune/code_error.mli

@@ -0,0 +1,12 @@
+(** A programming error that should be reported upstream *)
+
+type t =
+  { message : string
+  ; data : (string * Dyn0.t) list
+  }
+
+exception E of t
+
+val to_dyn : t -> Dyn0.t
+
+val raise : string -> (string * Dyn0.t) list -> _

src/stdune/dyn0.ml

@@ -100,3 +100,5 @@ and pp_sexp = function
       ]
 
 let pp fmt t = Pp.pp fmt (pp t)
+
+let to_string t = Format.asprintf "%a" pp t

src/stdune/exn.ml

@@ -3,8 +3,6 @@ module String = Dune_caml.StringLabels
 module Dyn = Dyn0
 type t = exn
 
-exception Code_error of Dyn.t
-
 exception Fatal_error of string
 
 exception Loc_error of Loc0.t * string
@@ -15,7 +13,6 @@ external reraise       : exn -> _ = "%reraise"
 
 let () =
   Printexc.register_printer (function
-    | Code_error s -> Some (Format.asprintf "%a" Dyn.pp s)
     | Loc_error (loc, s) -> Some (Format.asprintf "%a%s" Loc0.print loc s)
     | _ -> None)
 
@@ -33,20 +30,10 @@ let protectx x ~f ~finally =
 
 let protect ~f ~finally = protectx () ~f ~finally
 
-let code_error_dyn message vars =
-  Code_error (
-    Tuple
-      [ String message
-      ; Record vars
-      ])
-  |> raise
-
 let code_error message vars =
-  Code_error
-    (Dyn0.Sexp (List (Atom message
-                      :: List.map vars ~f:(fun (name, value) ->
-                        Sexp.List [Atom name; value]))))
-  |> raise
+  List.map vars ~f:(fun (v, sexp) ->
+    (v, Dyn0.Sexp sexp))
+  |> Code_error.raise message
 
 let pp_uncaught ~backtrace fmt exn =
   let s =

src/stdune/exn.mli

@@ -1,9 +1,5 @@
 (** Exceptions *)
 
-(** An programming error, that should be reported upstream. The error message
-    should try to be developer friendly rather than user friendly. *)
-exception Code_error of Dyn0.t
-
 
 (* CR-soon diml:
    - Rename to [User_error]
@@ -21,9 +17,7 @@ val fatalf
   -> ('a, unit, string, string, string, 'b) format6
   -> 'a
 
-val code_error : string -> (string * Sexp.t) list -> _
-
-val code_error_dyn : string -> (string * Dyn0.t) list -> _
+val code_error : string -> (string * Sexp0.t) list -> _
 
 type t = exn
 

src/stdune/stdune.ml

@@ -45,6 +45,7 @@ module Dyn        = Dyn
 module Float      = Float
 module Tuple      = Tuple
 module Poly       = Poly
+module Code_error = Code_error
 
 external reraise : exn -> _ = "%reraise"
 

test/unit-tests/path.mlt

@@ -223,12 +223,11 @@ Path.is_managed (e "relative/path")
 Path.insert_after_build_dir_exn Path.root "foobar"
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Path.insert_after_build_dir_exn";
-      List [Atom "path"; List [Atom "In_source_tree"; Atom "."]];
-      List [Atom "insert"; Atom "foobar"]])).
+E
+ {message = "Path.insert_after_build_dir_exn";
+  data =
+   [("path", Sexp (List [Atom "In_source_tree"; Atom "."]));
+    ("insert", Sexp (Atom "foobar"))]}.
 |}]
 
 Path.insert_after_build_dir_exn Path.build_dir "foobar"
@@ -249,23 +248,21 @@ Path.append Path.build_dir (Path.relative Path.root "foo")
 Path.append Path.build_dir (Path.relative Path.build_dir "foo")
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Path.append called with directory that's not in the source tree";
-      List [Atom "a"; List [Atom "In_build_dir"; Atom "."]];
-      List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]])).
+E
+ {message = "Path.append called with directory that's not in the source tree";
+  data =
+   [("a", Sexp (List [Atom "In_build_dir"; Atom "."]));
+    ("b", Sexp (List [Atom "In_build_dir"; Atom "foo"]))]}.
 |}]
 
 Path.append Path.root (Path.relative Path.build_dir "foo")
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Path.append called with directory that's not in the source tree";
-      List [Atom "a"; List [Atom "In_source_tree"; Atom "."]];
-      List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]])).
+E
+ {message = "Path.append called with directory that's not in the source tree";
+  data =
+   [("a", Sexp (List [Atom "In_source_tree"; Atom "."]));
+    ("b", Sexp (List [Atom "In_build_dir"; Atom "foo"]))]}.
 |}]
 
 Path.append Path.root (Path.relative Path.root "foo")
@@ -281,23 +278,20 @@ Path.append (Path.of_string "/root") (Path.relative Path.root "foo")
 Path.append (Path.of_string "/root") (Path.relative Path.build_dir "foo")
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Path.append called with directory that's not in the source tree";
-      List [Atom "a"; List [Atom "External"; Atom "/root"]];
-      List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]])).
+E
+ {message = "Path.append called with directory that's not in the source tree";
+  data =
+   [("a", Sexp (List [Atom "External"; Atom "/root"]));
+    ("b", Sexp (List [Atom "In_build_dir"; Atom "foo"]))]}.
 |}]
 
 Path.rm_rf (Path.of_string "/does/not/exist/foo/bar/baz")
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Path.rm_rf called on external dir";
-      List
-       [Atom "t"; List [Atom "External"; Atom "/does/not/exist/foo/bar/baz"]]])).
+E
+ {message = "Path.rm_rf called on external dir";
+  data =
+   [("t", Sexp (List [Atom "External"; Atom "/does/not/exist/foo/bar/baz"]))]}.
 |}]
 
 Path.drop_build_context (Path.relative Path.build_dir "foo/bar")

test/unit-tests/sexp.mlt

@@ -337,19 +337,17 @@ test Dune (a "toto")
 test Dune (t [Text "x%{"])
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]])).
+E
+ {message = "Invalid text in unquoted template";
+  data = [("s", Sexp (Atom "x%{"))]}.
 |}]
 
 test Dune (t [Text "x%"; Text "{"])
 [%%expect{|
 Exception:
-Code_error
- (Sexp
-   (List
-     [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]])).
+E
+ {message = "Invalid text in unquoted template";
+  data = [("s", Sexp (Atom "x%{"))]}.
 |}]
 
 (* This round trip failure is expected *)