Fix to use Config_json_name of obj tuple arguments of `tuple_like var…

…iant constructors (#418) * add constructor having arguments with json name of polymorphic variant * fix to use Config_json_name of variant_argument of `tuple_like variant constructor with `obj `default * fix test * generate code * fix test * fix test values * fix melange version
kxcdev · Mar 6, 2024 · c3ff240 · c3ff240
1 parent d6a2cd7
commit c3ff240
Show file tree

Hide file tree

Showing 14 changed files with 156 additions and 43 deletions.
diff --git a/bindoj.opam b/bindoj.opam
@@ -45,7 +45,7 @@ depends: [
   "ocamlformat" {with-test & = "0.26.0"}
   "ocaml" {>= "4.14"}
   "cohttp-lwt-unix" {with-test}
-  "melange" {with-doc & >= "2.0.0"}
+  "melange" {with-doc & >= "2.0.0" & < "3.0.0"}
 ]
 build: [
   ["dune" "subst"] {dev}

diff --git a/dune-project b/dune-project
@@ -50,4 +50,4 @@
   (ocamlformat (and :with-test (= 0.26.0)))
   (ocaml (>= 4.14))
   (cohttp-lwt-unix :with-test)
-  (melange (and :with-doc (>= 2.0.0)))))
+  (melange (and :with-doc (>= 2.0.0) (< 3.0.0)))))
diff --git a/example/for_dev/typedesc_examples/lib_gen/ex_variant_gen.ml b/example/for_dev/typedesc_examples/lib_gen/ex_variant_gen.ml
@@ -844,7 +844,8 @@ let ex_variant_int_list_objtuple_typed_decl =
     Bindoj_test_common_typedesc_examples.Ex_variant.Int_list_objtuple.decl
     ex_variant_int_list_objtuple_reflect
 
-type ex_variant_foo = [ `Foo0 | `Foo1 of int | `Foo2 of int * int ]
+type ex_variant_foo =
+  [ `Foo0 | `Foo1 of int | `Foo2 of int * int | `Foo3 of int * int ]
 
 let rec (ex_variant_foo_reflect : _ Bindoj_runtime.Refl.t) =
   lazy
@@ -879,21 +880,43 @@ let rec (ex_variant_foo_reflect : _ Bindoj_runtime.Refl.t) =
              | _ -> None);
          }
      in
+     let ctor_Foo3 =
+       Refl.TupleLike
+         {
+           get =
+             (function
+             | `Foo3 (x0, x1) -> [ Expr.of_int x0; Expr.of_int x1 ]
+             | _ -> invalid_arg "Foo3 is expected");
+           mk =
+             (function
+             | [ x0; x1 ] ->
+                 Expr.to_int x0 >>= fun x0 ->
+                 Expr.to_int x1 >>= fun x1 -> Some (`Foo3 (x0, x1))
+             | _ -> None);
+         }
+     in
      Refl.Variant
        {
          constructors =
            StringMap.of_list
-             [ ("Foo0", ctor_Foo0); ("Foo1", ctor_Foo1); ("Foo2", ctor_Foo2) ];
+             [
+               ("Foo0", ctor_Foo0);
+               ("Foo1", ctor_Foo1);
+               ("Foo2", ctor_Foo2);
+               ("Foo3", ctor_Foo3);
+             ];
          classify =
            (function
            | `Foo0 -> ("Foo0", ctor_Foo0)
            | `Foo1 _ -> ("Foo1", ctor_Foo1)
-           | `Foo2 _ -> ("Foo2", ctor_Foo2));
+           | `Foo2 _ -> ("Foo2", ctor_Foo2)
+           | `Foo3 _ -> ("Foo3", ctor_Foo3));
        })
 [@@warning "-33-39"]
 
 let ex_variant_foo_json_discriminator_value =
-  (function `Foo0 -> "foo0" | `Foo1 _ -> "foo1" | `Foo2 _ -> "foo2"
+  (function
+   | `Foo0 -> "foo0" | `Foo1 _ -> "foo1" | `Foo2 _ -> "foo2" | `Foo3 _ -> "foo3"
     : ex_variant_foo -> string)
 [@@warning "-39"]
 
@@ -915,6 +938,12 @@ let ex_variant_foo_json_shape_explanation =
                    `mandatory_field ("kind", `exactly (`str "foo2"));
                    `mandatory_field ("value", `tuple_of [ `integral; `integral ]);
                  ];
+               `object_of
+                 [
+                   `mandatory_field ("kind", `exactly (`str "foo3"));
+                   `mandatory_field ("field1", `integral);
+                   `mandatory_field ("field2", `integral);
+                 ];
              ] ) )
     : Bindoj_runtime.json_shape_explanation)
 [@@warning "-39"]
@@ -930,6 +959,13 @@ let rec ex_variant_foo_to_json =
            ("kind", `str "foo2");
            ("value", `arr [ int_to_json x0; int_to_json x1 ]);
          ]
+   | `Foo3 (x0, x1) ->
+       `obj
+         [
+           ("kind", `str "foo3");
+           ("field1", int_to_json x0);
+           ("field2", int_to_json x1);
+         ]
     : ex_variant_foo -> Kxclib.Json.jv)
 [@@warning "-39"]
 
@@ -984,11 +1020,23 @@ and ex_variant_foo_of_json' =
                          string_of_jv_kind (classify_jv jv)),
                       `f "value" :: path )
               | None -> Error ("mandatory field 'value' does not exist", path))
+          | `obj (("kind", `str "foo3") :: param) ->
+              let ( >>= ) = Result.bind in
+              List.assoc_opt "field1" param
+              |> Option.to_result
+                   ~none:("mandatory field 'field1' does not exist", path)
+              >>= int_of_json' (`f "field1" :: path)
+              >>= fun x0 ->
+              List.assoc_opt "field2" param
+              |> Option.to_result
+                   ~none:("mandatory field 'field2' does not exist", path)
+              >>= int_of_json' (`f "field2" :: path)
+              >>= fun x1 -> Ok (`Foo3 (x0, x1))
           | `obj (("kind", `str discriminator_value) :: _) ->
               Error
                 ( Printf.sprintf
                     "given discriminator field value '%s' is not one of [ \
-                     'foo0', 'foo1', 'foo2' ]"
+                     'foo0', 'foo1', 'foo2', 'foo3' ]"
                     discriminator_value,
                   `f "kind" :: path )
           | `obj (("kind", jv) :: _) ->

diff --git a/example/for_dev/typedesc_examples/lib_gen/ex_variant_gen.mli b/example/for_dev/typedesc_examples/lib_gen/ex_variant_gen.mli
@@ -104,7 +104,8 @@ val ex_variant_int_list_objtuple_typed_decl :
     ex_variant_int_list_objtuple )
   Bindoj_runtime.generic_typed_type_decl
 
-type ex_variant_foo = [ `Foo0 | `Foo1 of int | `Foo2 of int * int ]
+type ex_variant_foo =
+  [ `Foo0 | `Foo1 of int | `Foo2 of int * int | `Foo3 of int * int ]
 
 val ex_variant_foo_reflect : ex_variant_foo Bindoj_runtime.Refl.t
 val ex_variant_foo_json_discriminator_value : ex_variant_foo -> string

diff --git a/example/for_dev/typedesc_examples/lib_gen_ts/ex_variant.ts b/example/for_dev/typedesc_examples/lib_gen_ts/ex_variant.ts
@@ -88,11 +88,13 @@ export function analyzeExVariantIntListObjtuple<__bindoj_ret>(__bindoj_fns: {
 export type ExVariantFoo =
   | { kind: "foo0" }
   | { kind: "foo1"; value: number }
-  | { kind: "foo2"; value: [number, number] };
+  | { kind: "foo2"; value: [number, number] }
+  | { kind: "foo3"; field1: number; field2: number };
 export function analyzeExVariantFoo<__bindoj_ret>(__bindoj_fns: {
   foo0: (__bindoj_v: { kind: "foo0" }) => __bindoj_ret;
   foo1: (__bindoj_v: { kind: "foo1"; value: number }) => __bindoj_ret;
   foo2: (__bindoj_v: { kind: "foo2"; value: [number, number] }) => __bindoj_ret;
+  foo3: (__bindoj_v: { kind: "foo3"; field1: number; field2: number }) => __bindoj_ret;
 }): (__bindoj_x: ExVariantFoo) => __bindoj_ret {
   return (__bindoj_x: ExVariantFoo) => {
     if (__bindoj_x.kind === "foo0") {
@@ -101,6 +103,8 @@ export function analyzeExVariantFoo<__bindoj_ret>(__bindoj_fns: {
       return __bindoj_fns[__bindoj_x.kind](__bindoj_x);
     } else if (__bindoj_x.kind === "foo2") {
       return __bindoj_fns[__bindoj_x.kind](__bindoj_x);
+    } else if (__bindoj_x.kind === "foo3") {
+      return __bindoj_fns[__bindoj_x.kind](__bindoj_x);
     } else {
       throw new TypeError("panic @analyzeExVariantFoo - unrecognized: " + __bindoj_x);
     }

diff --git a/example/for_dev/typedesc_examples/lib_gen_ts/json-examples/ex_variant_examples.json b/example/for_dev/typedesc_examples/lib_gen_ts/json-examples/ex_variant_examples.json
@@ -40,7 +40,12 @@
     },
     { "kind": "intcons", "_0": 26335605, "_1": { "kind": "intcons", "_0": 35460072, "_1": { "kind": "intnil" } } }
   ],
-  "ExVariantFoo": [{ "kind": "foo0" }, { "kind": "foo1", "value": 1 }, { "kind": "foo2", "value": [1, 2] }],
+  "ExVariantFoo": [
+    { "kind": "foo0" },
+    { "kind": "foo1", "value": 1 },
+    { "kind": "foo2", "value": [1, 2] },
+    { "kind": "foo3", "field1": 1, "field2": 2 }
+  ],
   "ExVariantCustomizedUnion": [
     { "tag": "case-tuple-like-arg'", "arg": 42 },
     { "tag": "case-tuple-like-exactly'", "Argument": 1024 },

diff --git a/example/for_dev/typedesc_examples/lib_gen_ts/json-schema/ex_variant_schema.json b/example/for_dev/typedesc_examples/lib_gen_ts/json-schema/ex_variant_schema.json
@@ -194,6 +194,17 @@
         },
         "required": ["value", "kind"],
         "additionalProperties": false
+      },
+      {
+        "title": "foo3",
+        "type": "object",
+        "properties": {
+          "field1": { "type": "integer" },
+          "field2": { "type": "integer" },
+          "kind": { "enum": ["foo3"], "type": "string" }
+        },
+        "required": ["field1", "field2", "kind"],
+        "additionalProperties": false
       }
     ]
   },

diff --git a/src/lib_codec/json.ml b/src/lib_codec/json.ml
@@ -192,9 +192,9 @@ let explain_encoded_json_shape'
       let tuple_style = Json_config.get_tuple_style vc_configs in
       begin match tuple_style, vas with
       | `obj `default, vas ->
-        vas |> List.mapi (fun i ->
-          Json_config.tuple_index_to_field_name i
-          |> process_non_spread_variant_argument' ~base_ident_codec base_mangling_style)
+        vas |> List.mapi (fun i va ->
+          let field_name = Json_config.(get_name_opt va.va_configs |? tuple_index_to_field_name i) in
+          process_non_spread_variant_argument' ~base_ident_codec base_mangling_style field_name va)
       | `arr, [ va ] ->
         [ process_non_spread_variant_argument' ~base_ident_codec base_mangling_style arg_fname va ]
       | `arr, vas ->
@@ -308,14 +308,6 @@ let rec of_json_impl : ?path:jvpath -> env:tdenv -> 'a typed_type_decl -> jv ->
     | Some a -> Result.ok a
   in
   let try_result jvpath f = try f () with Invalid_argument msg -> Error (msg, jvpath) in
-  let parse_obj_style_tuple path (conv: jvpath -> string -> _ -> jv option -> (Expr.t, string * jvpath) result) (ts: _ list) (fields: jv StringMap.t) =
-    ts
-    |> List.mapi (fun i t ->
-      let field_name = Json_config.tuple_index_to_field_name i in
-      fields |> StringMap.find_opt field_name
-      |> conv (`f field_name :: path) field_name t)
-    |> sequence_list
-  in
   let map2i f l1 l2 =
     let rec map2i i f l1 l2 =
       match (l1, l2) with
@@ -328,6 +320,15 @@ let rec of_json_impl : ?path:jvpath -> env:tdenv -> 'a typed_type_decl -> jv ->
     in
     map2i 0 f l1 l2
   in
+  let parse_obj_style_tuple ~get_field_name path (conv: jvpath -> string -> _ -> jv option -> (Expr.t, string * jvpath) result) (ts: _ list) (fields: jv StringMap.t) =
+    ts |> List.mapi (fun i t ->
+      let field_name = get_field_name t i in
+      fields
+      |> StringMap.find_opt field_name
+      |> conv (`f field_name :: path) field_name t
+    )
+    |> sequence_list
+  in
   let expr_of_json base_mangling_style (path: jvpath) (ct: coretype) (jv: jv) : (Expr.t, string * jvpath) result =
     let base_mangling_style = Json_config.get_mangling_style_opt ct.ct_configs |? base_mangling_style in
     let rec go (path: jvpath) (d: Coretype.desc) (jv: jv) =
@@ -395,7 +396,9 @@ let rec of_json_impl : ?path:jvpath -> env:tdenv -> 'a typed_type_decl -> jv ->
           | _, `arr ->
             Result.error (sprintf "an array is expected for a tuple value, but the given is of type '%s'" (jv |> classify_jv |> string_of_jv_kind), path)
           | `obj fields, `obj `default ->
-            parse_obj_style_tuple path (fun path' field_name -> !? (function
+            parse_obj_style_tuple
+              ~get_field_name:(constant Json_config.tuple_index_to_field_name)
+              path (fun path' field_name -> !? (function
               | Coretype.Option (Option _), _ -> Error ("Nested option types cannot be json fields.", path')
               | Option _, None -> Ok Expr.None
               | desc, Some jv -> go path' desc jv
@@ -512,13 +515,16 @@ let rec of_json_impl : ?path:jvpath -> env:tdenv -> 'a typed_type_decl -> jv ->
               in
               begin match Json_config.get_tuple_style ctor.vc_configs, ts with
               | `obj `default, _ :: _ :: _ ->
-                parse_obj_style_tuple path (fun path' field_name -> !?(function
-                  | { va_type = `direct ct | `nested ({ td_kind = Alias_decl ct; _ }, _); _ }, None
-                    when Coretype.is_option ct ->
-                      Ok Expr.None
-                  | va, Some jv -> variant_argument_of_json base_mangling_style path' va jv
-                  | _, None -> Error (sprintf "mandatory field '%s' does not exist" field_name, path))
-                ) ts obj
+                parse_obj_style_tuple
+                  ~get_field_name:Json_config.(fun t i -> get_name_opt t.va_configs |? tuple_index_to_field_name i)
+                  path
+                  (fun path' field_name -> !?(function
+                    | { va_type = `direct ct | `nested ({ td_kind = Alias_decl ct; _ }, _); _ }, None
+                      when Coretype.is_option ct ->
+                        Ok Expr.None
+                    | va, Some jv -> variant_argument_of_json base_mangling_style path' va jv
+                    | _, None -> Error (sprintf "mandatory field '%s' does not exist" field_name, path))
+                  ) ts obj
                 >>= (fun x -> mk_result path x)
               | _, [] -> mk_result path []
               | _, _ ->
@@ -727,7 +733,8 @@ let rec to_json ~(env: tdenv) (a: 'a typed_type_decl) (value: 'a) : jv =
             let value, is_option = variant_argument_to_json base_mangling_style t e in
             if is_option && e = Expr.None then None
             else
-              Some (Json_config.tuple_index_to_field_name i, value)
+              let field_name = Json_config.(get_name_opt t.va_configs |? tuple_index_to_field_name i) in
+              Some (field_name, value)
             ) |&?> identity
           in
           `obj (discriminator_field @ fields)

diff --git a/src/lib_gen/json_codec.ml b/src/lib_gen/json_codec.ml
@@ -278,11 +278,11 @@ let opt_to_result : loc:location -> expression -> expression =
   fun ~loc err ->
     [%expr Option.to_result ~none:[%e err]]
 
-let encoder_of_objtuple ?additional_field ~loc to_expr = function
+let encoder_of_objtuple ?additional_field ~loc ~get_field_name to_expr = function
   | [] -> additional_field |?! (fun () -> [%expr []])
   | ts ->
     let es = ts |> List.mapi (fun i t ->
-      let label = estring ~loc (tuple_index_to_field_name i) in
+      let label = estring ~loc (get_field_name t i) in
       let encoded, is_optional = to_expr i t in
       let efield = [%expr ([%e label], [%e encoded])] in
       efield, is_optional)
@@ -323,7 +323,7 @@ let encoder_of_coretype =
       match Json_config.get_tuple_style configs with
       | `obj `default ->
         let fields =
-          encoder_of_objtuple ~loc (fun i -> function
+          encoder_of_objtuple ~loc ~get_field_name:(constant tuple_index_to_field_name) (fun i -> function
             | Option (Option _) -> failwith "Nested option cannot be json fields."
             | Option t ->
               [%expr [%e go t] [%e evari i]], true
@@ -877,7 +877,11 @@ let gen_json_encoder' :
             ]
           | _, `obj `default ->
             args
-            |> encoder_of_objtuple ~loc ~additional_field:cstr (expr_of_arg ~is_field:true)
+            |> encoder_of_objtuple
+              ~loc
+              ~get_field_name:(fun va i -> Json_config.get_name_opt va.va_configs |? tuple_index_to_field_name i)
+              ~additional_field:cstr
+              (expr_of_arg ~is_field:true)
             |> List.return
           end
         | `inline_record fields ->
@@ -1119,7 +1123,7 @@ let gen_json_decoder_impl :
               | `obj `default, _ :: _ :: _ ->
                 let bindings =
                   args |> List.mapi (fun i arg ->
-                    let label_name = tuple_index_to_field_name i in
+                    let label_name = Json_config.get_name_opt arg.va_configs |? tuple_index_to_field_name i in
                     let label_name_e = estring ~loc label_name in
                     let assoc_opt = [%expr List.assoc_opt [%e label_name_e] [%e param_e]] in
                     let decoder = [%expr [%e arg_to_decoder arg] (`f [%e label_name_e] :: path) ] in
@@ -1739,7 +1743,7 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t =
               else [arg_name, Schema_object.tuple ts]
             | _, `obj `default ->
               args |> List.mapi (fun i t ->
-                Json_config.tuple_index_to_field_name i, convert_variant_argument t
+                Json_config.(get_name_opt t.va_configs |? tuple_index_to_field_name i), convert_variant_argument t
               )
           in
           List.return (Some discriminator_value, vc_doc, arg_field @ discriminator_field)

diff --git a/src/lib_gen_ts/typescript_datatype.ml b/src/lib_gen_ts/typescript_datatype.ml
@@ -337,7 +337,7 @@ and ts_type_desc_of_fwrt_decl' :
                 args |> List.mapi (fun i arg ->
                   let (`optional_property tsps_optional), tsps_type_desc = property_type_of_variant_argument base_mangling_style arg in
                   { tsps_modifiers = arg.fva_annot;
-                    tsps_name = Json_config.tuple_index_to_field_name i;
+                    tsps_name = Json_config.(get_name_opt arg.fva_configs |? tuple_index_to_field_name i);
                     tsps_optional; tsps_type_desc })
               in
               members @ fields, nested