handle name attribute in errors correctly

ppx/browser/dune

@@ -28,7 +28,7 @@
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
 
 (copy_files#
- (files ../common/ppx_deriving_json_common.ml))
+ (files ../native/common/ppx_deriving_json_common.ml))
 
 (copy_files#
- (files ../common/ppx_deriving_tools.{ml,mli}))
+ (files ../native/common/ppx_deriving_tools.{ml,mli}))

ppx/common/ppx_deriving_json_common.ml → ppx/native/common/ppx_deriving_json_common.ml

@@ -1,27 +1,6 @@
 open StdLabels
 open Ppxlib
 open Ast_builder.Default
-open Ppx_deriving_tools.Conv
-
-let get_of_variant_case ?mark_as_seen ~variant ~polyvariant = function
-  | Vcs_ctx_variant ctx -> Attribute.get ?mark_as_seen variant ctx
-  | Vcs_ctx_polyvariant ctx -> Attribute.get ?mark_as_seen polyvariant ctx
-
-let get_of_variant ?mark_as_seen ~variant ~polyvariant = function
-  | Vrt_ctx_variant ctx -> Attribute.get ?mark_as_seen variant ctx
-  | Vrt_ctx_polyvariant ctx -> Attribute.get ?mark_as_seen polyvariant ctx
-
-let attr_json_name ctx =
-  Attribute.declare "json.name" ctx
-    Ast_pattern.(single_expr_payload (estring __'))
-    (fun x -> x)
-
-let vcs_attr_json_name =
-  let variant =
-    attr_json_name Attribute.Context.constructor_declaration
-  in
-  let polyvariant = attr_json_name Attribute.Context.rtag in
-  get_of_variant_case ~variant ~polyvariant
 
 let ld_attr_json_key =
   Attribute.get

ppx/common/ppx_deriving_tools.ml → ppx/native/common/ppx_deriving_tools.ml

@@ -359,6 +359,23 @@ module Conv = struct
     | Vrt_ctx_variant of type_declaration
     | Vrt_ctx_polyvariant of core_type
 
+  let get_of_variant_case ?mark_as_seen ~variant ~polyvariant = function
+    | Vcs_ctx_variant ctx -> Attribute.get ?mark_as_seen variant ctx
+    | Vcs_ctx_polyvariant ctx ->
+        Attribute.get ?mark_as_seen polyvariant ctx
+
+  let attr_json_name ctx =
+    Attribute.declare "json.name" ctx
+      Ast_pattern.(single_expr_payload (estring __'))
+      (fun x -> x)
+
+  let vcs_attr_json_name =
+    let variant =
+      attr_json_name Attribute.Context.constructor_declaration
+    in
+    let polyvariant = attr_json_name Attribute.Context.rtag in
+    get_of_variant_case ~variant ~polyvariant
+
   let repr_polyvariant_cases cs =
     List.rev cs |> List.map ~f:(fun c -> c, Schema.repr_row_field c)
 
@@ -508,6 +525,10 @@ module Conv = struct
              (cs
              |> List.map ~f:(fun c ->
                     let name = c.pcd_name in
+                    let name =
+                      Option.value ~default:name
+                        (vcs_attr_json_name (Vcs_ctx_variant c))
+                    in
                     match c.pcd_args with
                     | Pcstr_record _fs ->
                         Printf.sprintf {|["%s", { _ }]|} name.txt
@@ -707,4 +728,6 @@ module Conv = struct
       :> deriving)
 end
 
+let vcs_attr_json_name = Conv.vcs_attr_json_name
+
 include Schema

ppx/common/ppx_deriving_tools.mli → ppx/native/common/ppx_deriving_tools.mli

@@ -2,6 +2,7 @@
 
 open Ppxlib
 
+
 (** A deriver is represented by this api *)
 class virtual deriving : object
   method virtual name : label
@@ -147,6 +148,9 @@ module Conv : sig
     *)
 end
 
+val vcs_attr_json_name: ?mark_as_seen:bool -> Conv.variant_case_ctx -> label loc option
+(** return the payload of the [@name "..."] attribute if there is one. *)
+
 val not_supported : loc:location -> string -> 'a
 (** [not_supported what] terminates ppx with an error message telling [what] unsupported. *)
 

ppx/native/dune

@@ -27,8 +27,4 @@
    %{target}
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
 
-(copy_files#
- (files ../common/ppx_deriving_json_common.ml))
-
-(copy_files#
- (files ../common/ppx_deriving_tools.{ml,mli}))
+(include_subdirs unqualified)

ppx/test/errors.t/prettify.ml

@@ -6,6 +6,7 @@ type variant =
   | B of int
   | C of int * string
   | D of { x : int; y : string }
+  | Different_named [@name "different_name"]
 [@@deriving json]
 
 type j = {

ppx/test/errors.t/run.t

@@ -10,7 +10,7 @@ $ ocamlopt -dsource _build/default/prettify.pp.ml
     "d": [ 123, [ 1.2, 2.3, 2.4 ], "i am here" ]
   }
   $ dune exec ./prettify.exe -- tag_as_string.json
-  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got "A"|})
+  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] or ["different_name"] but got "A"|})
   [2]
   $ dune exec ./prettify.exe -- wrong_core_type.json
   Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected int but got string: "i am a string"|})
@@ -28,10 +28,10 @@ $ ocamlopt -dsource _build/default/prettify.pp.ml
   Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected field "b" but got {"a": _, "foo": _, "c": _, "d": _}|})
   [2]
   $ dune exec ./prettify.exe -- unknown_tag.json
-  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["Bar"]|})
+  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] or ["different_name"] but got ["Bar"]|})
   [2]
   $ dune exec ./prettify.exe -- wrong_tag_payload.json
-  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] but got ["B", 123, "booh"]|})
+  Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|expected ["A"] or ["Foo"] or ["B", _] or ["C", _, _] or ["D", { _ }] or ["different_name"] but got ["B", 123, "booh"]|})
   [2]
   $ dune exec ./prettify.exe -- extra_field.json
   Fatal error: exception Ppx_deriving_json_runtime.Of_json_error(Json_error {|did not expect field "bar" but got {"a": _, "foo": _, "bar": _, "b": _, "c": _, "d": _}|})

ppx/test/ppx_deriving_json_js.t

@@ -52,15 +52,15 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec param_of_json a_of_json =
-      (fun x -> a_of_json x : Js.Json.t -> 'a param)
+    let rec param_of_json a_of_json : Js.Json.t -> 'a param =
+     fun x -> a_of_json x
 
     let _ = param_of_json
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec param_to_json a_to_json =
-      (fun x -> a_to_json x : 'a param -> Js.Json.t)
+    let rec param_to_json a_to_json : 'a param -> Js.Json.t =
+     fun x -> a_to_json x
 
     let _ = param_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
@@ -679,48 +679,45 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec c_of_json a_of_json =
-      (fun x ->
-         if Js.Array.isArray x then
-           let array = (Obj.magic x : Js.Json.t array) in
-           let len = Js.Array.length array in
-           if Stdlib.( > ) len 0 then
-             let tag = Js.Array.unsafe_get array 0 in
-             if Stdlib.( = ) (Js.typeof tag) "string" then
-               let tag = (Obj.magic tag : string) in
-               if Stdlib.( = ) tag "C" then (
-                 if Stdlib.( <> ) len 2 then
-                   Ppx_deriving_json_runtime.of_json_msg_error ~json:x
-                     "expected a JSON array of length 2";
-                 `C (a_of_json (Js.Array.unsafe_get array 1)))
-               else
-                 raise
-                   (Ppx_deriving_json_runtime.Of_json_error
-                      (Ppx_deriving_json_runtime.Unexpected_variant
-                         "unexpected variant"))
-             else
-               Ppx_deriving_json_runtime.of_json_error ~json:x
-                 "expected a non empty JSON array with element being a \
-                  string"
-           else
-             Ppx_deriving_json_runtime.of_json_error ~json:x
-               "expected a non empty JSON array"
-         else
-           Ppx_deriving_json_runtime.of_json_error ~json:x
-             "expected a non empty JSON array"
-        : Js.Json.t -> 'a c)
+    let rec c_of_json a_of_json : Js.Json.t -> 'a c =
+     fun x ->
+      if Js.Array.isArray x then
+        let array = (Obj.magic x : Js.Json.t array) in
+        let len = Js.Array.length array in
+        if Stdlib.( > ) len 0 then
+          let tag = Js.Array.unsafe_get array 0 in
+          if Stdlib.( = ) (Js.typeof tag) "string" then
+            let tag = (Obj.magic tag : string) in
+            if Stdlib.( = ) tag "C" then (
+              if Stdlib.( <> ) len 2 then
+                Ppx_deriving_json_runtime.of_json_msg_error ~json:x
+                  "expected a JSON array of length 2";
+              `C (a_of_json (Js.Array.unsafe_get array 1)))
+            else
+              raise
+                (Ppx_deriving_json_runtime.Of_json_error
+                   (Ppx_deriving_json_runtime.Unexpected_variant
+                      "unexpected variant"))
+          else
+            Ppx_deriving_json_runtime.of_json_error ~json:x
+              "expected a non empty JSON array with element being a string"
+        else
+          Ppx_deriving_json_runtime.of_json_error ~json:x
+            "expected a non empty JSON array"
+      else
+        Ppx_deriving_json_runtime.of_json_error ~json:x
+          "expected a non empty JSON array"
 
     let _ = c_of_json
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec c_to_json a_to_json =
-      (fun x ->
-         match x with
-         | `C x_0 ->
-             (Obj.magic [| (Obj.magic "C" : Js.Json.t); a_to_json x_0 |]
-               : Js.Json.t)
-        : 'a c -> Js.Json.t)
+    let rec c_to_json a_to_json : 'a c -> Js.Json.t =
+     fun x ->
+      match x with
+      | `C x_0 ->
+          (Obj.magic [| (Obj.magic "C" : Js.Json.t); a_to_json x_0 |]
+            : Js.Json.t)
 
     let _ = c_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
@@ -979,53 +976,49 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec p2_of_json a_of_json b_of_json =
-      (fun x ->
-         if Js.Array.isArray x then
-           let array = (Obj.magic x : Js.Json.t array) in
-           let len = Js.Array.length array in
-           if Stdlib.( > ) len 0 then
-             let tag = Js.Array.unsafe_get array 0 in
-             if Stdlib.( = ) (Js.typeof tag) "string" then
-               let tag = (Obj.magic tag : string) in
-               if Stdlib.( = ) tag "A" then (
-                 if Stdlib.( <> ) len 2 then
-                   Ppx_deriving_json_runtime.of_json_msg_error ~json:x
-                     "expected a JSON array of length 2";
-                 A (a_of_json (Js.Array.unsafe_get array 1)))
-               else if Stdlib.( = ) tag "B" then (
-                 if Stdlib.( <> ) len 2 then
-                   Ppx_deriving_json_runtime.of_json_msg_error ~json:x
-                     "expected a JSON array of length 2";
-                 B (b_of_json (Js.Array.unsafe_get array 1)))
-               else
-                 Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON"
-             else
-               Ppx_deriving_json_runtime.of_json_error ~json:x
-                 "expected a non empty JSON array with element being a \
-                  string"
-           else
-             Ppx_deriving_json_runtime.of_json_error ~json:x
-               "expected a non empty JSON array"
-         else
-           Ppx_deriving_json_runtime.of_json_error ~json:x
-             "expected a non empty JSON array"
-        : Js.Json.t -> ('a, 'b) p2)
+    let rec p2_of_json a_of_json b_of_json : Js.Json.t -> ('a, 'b) p2 =
+     fun x ->
+      if Js.Array.isArray x then
+        let array = (Obj.magic x : Js.Json.t array) in
+        let len = Js.Array.length array in
+        if Stdlib.( > ) len 0 then
+          let tag = Js.Array.unsafe_get array 0 in
+          if Stdlib.( = ) (Js.typeof tag) "string" then
+            let tag = (Obj.magic tag : string) in
+            if Stdlib.( = ) tag "A" then (
+              if Stdlib.( <> ) len 2 then
+                Ppx_deriving_json_runtime.of_json_msg_error ~json:x
+                  "expected a JSON array of length 2";
+              A (a_of_json (Js.Array.unsafe_get array 1)))
+            else if Stdlib.( = ) tag "B" then (
+              if Stdlib.( <> ) len 2 then
+                Ppx_deriving_json_runtime.of_json_msg_error ~json:x
+                  "expected a JSON array of length 2";
+              B (b_of_json (Js.Array.unsafe_get array 1)))
+            else Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON"
+          else
+            Ppx_deriving_json_runtime.of_json_error ~json:x
+              "expected a non empty JSON array with element being a string"
+        else
+          Ppx_deriving_json_runtime.of_json_error ~json:x
+            "expected a non empty JSON array"
+      else
+        Ppx_deriving_json_runtime.of_json_error ~json:x
+          "expected a non empty JSON array"
 
     let _ = p2_of_json
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec p2_to_json a_to_json b_to_json =
-      (fun x ->
-         match x with
-         | A x_0 ->
-             (Obj.magic [| (Obj.magic "A" : Js.Json.t); a_to_json x_0 |]
-               : Js.Json.t)
-         | B x_0 ->
-             (Obj.magic [| (Obj.magic "B" : Js.Json.t); b_to_json x_0 |]
-               : Js.Json.t)
-        : ('a, 'b) p2 -> Js.Json.t)
+    let rec p2_to_json a_to_json b_to_json : ('a, 'b) p2 -> Js.Json.t =
+     fun x ->
+      match x with
+      | A x_0 ->
+          (Obj.magic [| (Obj.magic "A" : Js.Json.t); a_to_json x_0 |]
+            : Js.Json.t)
+      | B x_0 ->
+          (Obj.magic [| (Obj.magic "B" : Js.Json.t); b_to_json x_0 |]
+            : Js.Json.t)
 
     let _ = p2_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]