Add Exn.code_error_dyn (#2246)

Add Exn.code_error_dyn
ocaml · Jun 5, 2019 · 19fb7f9 · 19fb7f9
2 parents 6cd4d81 + 5efce2d
commit 19fb7f9
Show file tree

Hide file tree

Showing 12 changed files with 162 additions and 129 deletions.
diff --git a/src/report_error.ml b/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"
-            Sexp.pp sexp
+            Dyn.pp (Code_error.to_dyn t)
     in
     Some (make_printer ~backtrace:true pp)
   | Unix.Unix_error (err, func, fname) ->

diff --git a/src/stdune/caml/dune_caml.ml b/src/stdune/caml/dune_caml.ml
@@ -11,6 +11,7 @@ module Digest   = Digest
 module StringLabels = StringLabels
 module ListLabels   = ListLabels
 module List   = List
+module ArrayLabels   = ArrayLabels
 
 type ('a, 'error) result = ('a, 'error) Result.t =
   | Ok    of 'a

diff --git a/src/stdune/code_error.ml b/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)
+
diff --git a/src/stdune/code_error.mli b/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 -> _
diff --git a/src/stdune/dyn.ml b/src/stdune/dyn.ml
@@ -1,88 +1,5 @@
 include Dyn0
 
-let rec pp = function
-  | Unit -> Pp.verbatim "()"
-  | Int i -> Pp.verbatim (string_of_int i)
-  | Bool b -> Pp.verbatim (string_of_bool b)
-  | String s -> Pp.verbatim s
-  | Bytes b -> Pp.verbatim (Bytes.to_string b)
-  | Char c -> Pp.char c
-  | Float f -> Pp.verbatim (string_of_float f)
-  | Sexp s -> pp_sexp s
-  | Option None -> pp (Variant ("None", []))
-  | Option (Some x) -> pp (Variant ("Some", [x]))
-  | List x ->
-    Pp.box
-      [ Pp.char '['
-      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) x ~f:pp
-      ; Pp.char ']'
-      ]
-  | Array a ->
-    Pp.box
-      [ Pp.verbatim "[|"
-      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) (Array.to_list a) ~f:pp
-      ; Pp.verbatim "|]"
-      ]
-  | Set xs ->
-    Pp.box
-      [ Pp.verbatim "set {"
-      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:pp
-      ; Pp.verbatim "}"
-      ]
-  | Map xs ->
-    Pp.box
-      [ Pp.verbatim "map {"
-      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:(fun (k, v) ->
-          Pp.box
-            [ pp k
-            ; Pp.space
-            ; Pp.verbatim ":"
-            ; Pp.space
-            ; pp v
-            ]
-        )
-      ; Pp.verbatim "}"
-      ]
-  | Tuple x ->
-    Pp.box
-      [ Pp.char '('
-      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ',') Pp.space) x ~f:pp
-      ; Pp.char ')'
-      ]
-  | Record fields ->
-    Pp.vbox ~indent:2
-      [ Pp.char '{'
-      ; Pp.concat_map ~sep:(Pp.char ';') fields ~f:(fun (f, v) ->
-          Pp.concat
-            [ Pp.verbatim f
-            ; Pp.space
-            ; Pp.char '='
-            ; Pp.space
-            ; Pp.box ~indent:2 [pp v]
-            ]
-        )
-      ; Pp.char '}'
-      ]
-  | Variant (v, []) -> Pp.verbatim v
-  | Variant (v, xs) ->
-    Pp.hvbox ~indent:2
-      [ Pp.verbatim v
-      ; Pp.space
-      ; Pp.concat_map ~sep:(Pp.char ',') xs ~f:pp
-      ]
-
-and pp_sexp = function
-  | Sexp.Atom s -> Pp.verbatim (Escape.quote_if_needed s)
-  | List [] -> Pp.verbatim "()"
-  | List l ->
-    Pp.box ~indent:1
-      [ Pp.char '('
-      ; Pp.hvbox [ Pp.concat_map l ~sep:Pp.space ~f:pp_sexp ]
-      ; Pp.char ')'
-      ]
-
-let pp fmt t = Pp.pp fmt (pp t)
-
 let rec to_sexp =
   let open Sexp.Encoder in
   function

diff --git a/src/stdune/dyn0.ml b/src/stdune/dyn0.ml
@@ -1,3 +1,5 @@
+module Array = Dune_caml.ArrayLabels
+
 type t =
   | Unit
   | Int of int
@@ -15,3 +17,88 @@ type t =
   | Variant of string * t list
   | Map of (t * t) list
   | Set of t list
+
+let rec pp = function
+  | Unit -> Pp.verbatim "()"
+  | Int i -> Pp.verbatim (string_of_int i)
+  | Bool b -> Pp.verbatim (string_of_bool b)
+  | String s -> Pp.verbatim s
+  | Bytes b -> Pp.verbatim (Bytes.to_string b)
+  | Char c -> Pp.char c
+  | Float f -> Pp.verbatim (string_of_float f)
+  | Sexp s -> pp_sexp s
+  | Option None -> pp (Variant ("None", []))
+  | Option (Some x) -> pp (Variant ("Some", [x]))
+  | List x ->
+    Pp.box
+      [ Pp.char '['
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) x ~f:pp
+      ; Pp.char ']'
+      ]
+  | Array a ->
+    Pp.box
+      [ Pp.verbatim "[|"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) (Array.to_list a) ~f:pp
+      ; Pp.verbatim "|]"
+      ]
+  | Set xs ->
+    Pp.box
+      [ Pp.verbatim "set {"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:pp
+      ; Pp.verbatim "}"
+      ]
+  | Map xs ->
+    Pp.box
+      [ Pp.verbatim "map {"
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ';') Pp.space) xs ~f:(fun (k, v) ->
+          Pp.box
+            [ pp k
+            ; Pp.space
+            ; Pp.verbatim ":"
+            ; Pp.space
+            ; pp v
+            ]
+        )
+      ; Pp.verbatim "}"
+      ]
+  | Tuple x ->
+    Pp.box
+      [ Pp.char '('
+      ; Pp.concat_map ~sep:(Pp.seq (Pp.char ',') Pp.space) x ~f:pp
+      ; Pp.char ')'
+      ]
+  | Record fields ->
+    Pp.vbox ~indent:2
+      [ Pp.char '{'
+      ; Pp.concat_map ~sep:(Pp.char ';') fields ~f:(fun (f, v) ->
+          Pp.concat
+            [ Pp.verbatim f
+            ; Pp.space
+            ; Pp.char '='
+            ; Pp.space
+            ; Pp.box ~indent:2 [pp v]
+            ]
+        )
+      ; Pp.char '}'
+      ]
+  | Variant (v, []) -> Pp.verbatim v
+  | Variant (v, xs) ->
+    Pp.hvbox ~indent:2
+      [ Pp.verbatim v
+      ; Pp.space
+      ; Pp.concat_map ~sep:(Pp.char ',') xs ~f:pp
+      ]
+
+and pp_sexp = function
+  | Sexp0.Atom s -> Pp.verbatim (Escape.quote_if_needed s)
+  | List [] -> Pp.verbatim "()"
+  | List l ->
+    Pp.box ~indent:1
+      [ Pp.char '('
+      ; Pp.hvbox [ Pp.concat_map l ~sep:Pp.space ~f:pp_sexp ]
+      ; Pp.char ')'
+      ]
+
+let pp fmt t = Pp.pp fmt (pp t)
+
+let to_string t = Format.asprintf "%a" pp t
diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml
@@ -1,9 +1,8 @@
 module List = Dune_caml.ListLabels
 module String = Dune_caml.StringLabels
+module Dyn = Dyn0
 type t = exn
 
-exception Code_error of Sexp.t
-
 exception Fatal_error of string
 
 exception Loc_error of Loc0.t * string
@@ -14,7 +13,6 @@ external reraise       : exn -> _ = "%reraise"
 
 let () =
   Printexc.register_printer (function
-    | Code_error s -> Some (Format.asprintf "%a" Sexp.pp s)
     | Loc_error (loc, s) -> Some (Format.asprintf "%a%s" Loc0.print loc s)
     | _ -> None)
 
@@ -33,11 +31,9 @@ let protectx x ~f ~finally =
 let protect ~f ~finally = protectx () ~f ~finally
 
 let code_error message vars =
-  Code_error
-    (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 =

diff --git a/src/stdune/exn.mli b/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 Sexp.t
-
 
 (* CR-soon diml:
    - Rename to [User_error]
@@ -21,7 +17,7 @@ val fatalf
   -> ('a, unit, string, string, string, 'b) format6
   -> 'a
 
-val code_error : string -> (string * Sexp.t) list -> _
+val code_error : string -> (string * Sexp0.t) list -> _
 
 type t = exn
 

diff --git a/src/stdune/pp.ml b/src/stdune/pp.ml
@@ -1,3 +1,4 @@
+module List = Dune_caml.ListLabels
 module String = Dune_caml.StringLabels
 
 type +'a t =

diff --git a/src/stdune/stdune.ml b/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"
 

diff --git a/test/unit-tests/path.mlt b/test/unit-tests/path.mlt
@@ -223,11 +223,11 @@ Path.is_managed (e "relative/path")
 Path.insert_after_build_dir_exn Path.root "foobar"
 [%%expect{|
 Exception:
-Code_error
- (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"
@@ -248,21 +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
- (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
- (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")
@@ -278,21 +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
- (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
- (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")