Add Exn.code_error_dyn

This is the recommended function to use for all code errors. It will become the default once we get rid of Sexp.t Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
ocaml · Jun 5, 2019 · 105408d · 105408d
1 parent f4d6c20
commit 105408d
Show file tree

Hide file tree

Showing 9 changed files with 136 additions and 114 deletions.
diff --git a/src/report_error.ml b/src/report_error.ml
@@ -51,7 +51,7 @@ let builtin_printer = function
           Format.fprintf ppf "@{<error>Internal error, please report upstream \
                               including the contents of _build/log.@}\n\
                               Description:%a\n"
-            Sexp.pp sexp
+            Dyn.pp sexp
     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/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,86 @@ 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)
diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml
@@ -1,8 +1,9 @@
 module List = Dune_caml.ListLabels
 module String = Dune_caml.StringLabels
+module Dyn = Dyn0
 type t = exn
 
-exception Code_error of Sexp.t
+exception Code_error of Dyn.t
 
 exception Fatal_error of string
 
@@ -14,7 +15,7 @@ external reraise       : exn -> _ = "%reraise"
 
 let () =
   Printexc.register_printer (function
-    | Code_error s -> Some (Format.asprintf "%a" Sexp.pp s)
+    | Code_error s -> Some (Format.asprintf "%a" Dyn.pp s)
     | Loc_error (loc, s) -> Some (Format.asprintf "%a%s" Loc0.print loc s)
     | _ -> None)
 
@@ -32,11 +33,19 @@ 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
-    (List (Atom message
-           :: List.map vars ~f:(fun (name, value) ->
-             Sexp.List [Atom name; value])))
+    (Dyn0.Sexp (List (Atom message
+                      :: List.map vars ~f:(fun (name, value) ->
+                        Sexp.List [Atom name; value]))))
   |> raise
 
 let pp_uncaught ~backtrace fmt exn =

diff --git a/src/stdune/exn.mli b/src/stdune/exn.mli
@@ -2,7 +2,7 @@
 
 (** 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
+exception Code_error of Dyn0.t
 
 
 (* CR-soon diml:
@@ -23,6 +23,8 @@ val fatalf
 
 val code_error : string -> (string * Sexp.t) list -> _
 
+val code_error_dyn : string -> (string * Dyn0.t) list -> _
+
 type t = exn
 
 external raise         : exn -> _ = "%raise"

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/test/unit-tests/path.mlt b/test/unit-tests/path.mlt
@@ -224,10 +224,11 @@ 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"]]).
+ (Sexp
+   (List
+     [Atom "Path.insert_after_build_dir_exn";
+      List [Atom "path"; List [Atom "In_source_tree"; Atom "."]];
+      List [Atom "insert"; Atom "foobar"]])).
 |}]
 
 Path.insert_after_build_dir_exn Path.build_dir "foobar"
@@ -249,20 +250,22 @@ 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"]]]).
+ (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"]]])).
 |}]
 
 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"]]]).
+ (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"]]])).
 |}]
 
 Path.append Path.root (Path.relative Path.root "foo")
@@ -279,20 +282,22 @@ 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"]]]).
+ (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"]]])).
 |}]
 
 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"]]]).
+ (Sexp
+   (List
+     [Atom "Path.rm_rf called on external dir";
+      List
+       [Atom "t"; List [Atom "External"; Atom "/does/not/exist/foo/bar/baz"]]])).
 |}]
 
 Path.drop_build_context (Path.relative Path.build_dir "foo/bar")

diff --git a/test/unit-tests/sexp.mlt b/test/unit-tests/sexp.mlt
@@ -338,16 +338,18 @@ test Dune (t [Text "x%{"])
 [%%expect{|
 Exception:
 Code_error
- (List
-   [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]]).
+ (Sexp
+   (List
+     [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]])).
 |}]
 
 test Dune (t [Text "x%"; Text "{"])
 [%%expect{|
 Exception:
 Code_error
- (List
-   [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]]).
+ (Sexp
+   (List
+     [Atom "Invalid text in unquoted template"; List [Atom "s"; Atom "x%{"]])).
 |}]
 
 (* This round trip failure is expected *)