From 3d15f555980184a9bd6d25a8980626a2a31a3fa4 Mon Sep 17 00:00:00 2001 From: kxc-wraikny <115773797+kxc-wraikny@users.noreply.github.com> Date: Mon, 21 Aug 2023 11:46:20 +0900 Subject: [PATCH] Update typescript optional field (#362) * update tests * update implementation * update docs * regenerate example * add examples (ex17, ex18) * Fixed to not generate unused option_to_json * fix lib_gen_ts * fix error message in test * add sample_values to ex18 * update error message of apidir_srever_bridge * update copyright * update fold_coretypes' * fix error message * fix signature of internal functions * add more docs * fix ancestral_configs * add rope tests with tsps_optional=true --------- Co-authored-by: Haochen M. Kotoi-Xie --- doc/tests_src/ocaml_json_codec.md | 68 +-- example/ex01/generated/ex01.ml | 74 ++- example/ex01/test/test.t | 4 +- example/ex02/generated/ex02.ml | 242 ++++------ example/ex02/generated/ex02.ts | 17 +- example/ex02/generated/ex02_apidir.json | 59 +-- example/ex02/test/test.t | 4 +- .../apidir_server_bridge.ml | 10 +- src/lib_codec/json.ml | 187 +++++--- src/lib_gen/caml_datatype.ml | 40 +- src/lib_gen/json_codec.ml | 443 ++++++++++++------ src/lib_gen/unit_test/gen/output/dune | 34 ++ .../unit_test/gen/output_embed_full_impl/dune | 18 + .../unit_test/gen/output_with_decl/dune | 18 + src/lib_gen/utils.ml | 9 - src/lib_gen_ts/config/bindoj_gen_ts_config.ml | 1 + .../config/bindoj_gen_ts_config.mli | 1 + src/lib_gen_ts/typescript_datatype.ml | 142 ++++-- src/lib_gen_ts/unit_test/lib_gen_ts_test.ml | 16 +- src/lib_test_common/of_json_error_examples.ml | 55 ++- src/lib_test_common/typedesc_examples/all.ml | 2 + src/lib_test_common/typedesc_examples/ex01.ml | 9 +- .../ex01_inherited_mangling.ml | 15 +- src/lib_test_common/typedesc_examples/ex02.ml | 47 +- .../ex02_inherited_mangling.ml | 53 +-- .../typedesc_examples/ex02_no_mangling.ml | 47 +- .../typedesc_examples/ex02_reused.ml | 36 +- src/lib_test_common/typedesc_examples/ex03.ml | 14 +- .../typedesc_examples/ex03_objtuple.ml | 18 +- src/lib_test_common/typedesc_examples/ex04.ml | 25 +- src/lib_test_common/typedesc_examples/ex05.ml | 71 ++- src/lib_test_common/typedesc_examples/ex06.ml | 22 +- src/lib_test_common/typedesc_examples/ex07.ml | 24 +- src/lib_test_common/typedesc_examples/ex08.ml | 10 +- src/lib_test_common/typedesc_examples/ex09.ml | 4 +- src/lib_test_common/typedesc_examples/ex10.ml | 13 +- src/lib_test_common/typedesc_examples/ex13.ml | 11 +- src/lib_test_common/typedesc_examples/ex14.ml | 17 +- src/lib_test_common/typedesc_examples/ex15.ml | 74 ++- src/lib_test_common/typedesc_examples/ex16.ml | 24 +- src/lib_test_common/typedesc_examples/ex17.ml | 65 +++ src/lib_test_common/typedesc_examples/ex18.ml | 294 ++++++++++++ src/lib_test_common/typedesc_examples/util.ml | 4 + .../typedesc_generated_examples.ml | 2 + .../typedesc_generated_examples/ex05.ml | 1 - .../ex05_notuple.ml | 1 - .../typedesc_generated_examples/ex10.ml | 7 +- .../typedesc_generated_examples/ex17.ml | 45 ++ .../typedesc_generated_examples/ex18.ml | 142 ++++++ .../unit_test/comparing_of_json.ml | 4 +- src/lib_typedesc/type_desc.ml | 81 ++-- src/lib_typedesc/type_desc.mli | 18 + .../tests/sample_apidir_05.test.ts | 4 +- .../tests/sample_apidir_06.test.ts | 10 +- with_js/compile-tests/dune | 34 ++ with_js/jsoo-integration-tests/run.ml | 4 +- 56 files changed, 1746 insertions(+), 948 deletions(-) create mode 100644 src/lib_test_common/typedesc_examples/ex17.ml create mode 100644 src/lib_test_common/typedesc_examples/ex18.ml create mode 100644 src/lib_test_common/typedesc_generated_examples/ex17.ml create mode 100644 src/lib_test_common/typedesc_generated_examples/ex18.ml diff --git a/doc/tests_src/ocaml_json_codec.md b/doc/tests_src/ocaml_json_codec.md index 701965d..c1df982 100755 --- a/doc/tests_src/ocaml_json_codec.md +++ b/doc/tests_src/ocaml_json_codec.md @@ -177,22 +177,16 @@ let student_of_json' = | `obj param -> let (>>=) = Result.bind in (((List.assoc_opt "admissionYear" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'admissionYear' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'admissionYear' does not exist", + path))) >>= (int_of_json' ((`f "admissionYear") :: path))) >>= ((fun x0 -> (((List.assoc_opt "fullName" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'fullName' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'fullName' does not exist", + path))) >>= (string_of_json' ((`f "fullName") :: path))) >>= (fun x1 -> Ok { admission_year = x0; full_name = x1 }))) @@ -221,7 +215,7 @@ let student_of_json' = let person_to_json = (function | Anonymous -> `obj [("kind", (`str "anonymous"))] - | With_id (x0) -> + | With_id x0 -> `obj [("kind", (`str "with-id")); ("arg", (int_to_json x0))] | Student { student_id = x0; name = x1 } -> `obj @@ -256,54 +250,39 @@ let person_of_json' = | `obj (("kind", `str "student")::param) -> let (>>=) = Result.bind in (((List.assoc_opt "studentId" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'studentId' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'studentId' does not exist", + path))) >>= (int_of_json' ((`f "studentId") :: path))) >>= ((fun x0 -> (((List.assoc_opt "name" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'name' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'name' does not exist", + path))) >>= (string_of_json' ((`f "name") :: path))) >>= (fun x1 -> Ok (Student { student_id = x0; name = x1 })))) | `obj (("kind", `str "teacher")::param) -> let (>>=) = Result.bind in (((List.assoc_opt "facultyId" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'facultyId' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'facultyId' does not exist", + path))) >>= (int_of_json' ((`f "facultyId") :: path))) >>= ((fun x0 -> (((List.assoc_opt "name" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'name' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'name' does not exist", + path))) >>= (string_of_json' ((`f "name") :: path))) >>= (fun x1 -> (((List.assoc_opt "department" param) |> - (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'department' does not exist", - path))) + (Option.to_result + ~none:("mandatory field 'department' does not exist", + path))) >>= (string_of_json' ((`f "department") :: path))) >>= @@ -350,8 +329,7 @@ let person_of_json' = `object_of [`mandatory_field ("kind", (`exactly (`str "with-id"))); - `mandatory_field - ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "student"))); diff --git a/example/ex01/generated/ex01.ml b/example/ex01/generated/ex01.ml index c0b3006..cece1e6 100644 --- a/example/ex01/generated/ex01.ml +++ b/example/ex01/generated/ex01.ml @@ -74,7 +74,13 @@ let (my_tuple_reflect : _ Bindoj_runtime.Refl.t) = let my_tuple_json_shape_explanation = (`with_warning ( "not considering any config if exists", - `named ("MyTuple", `tuple_of [ `proper_float; `string ]) ) + `named + ( "MyTuple", + `object_of + [ + `mandatory_field ("_0", `proper_float); + `mandatory_field ("_1", `string); + ] ) ) : Bindoj_runtime.json_shape_explanation) [@@warning "-39"] @@ -110,19 +116,17 @@ and my_tuple_of_json' = in fun path -> function | (`obj fields : Kxclib.Json.jv) -> - let fields = Bindoj_runtime.StringMap.of_list fields in let ( >>= ) = Result.bind in - (Bindoj_runtime.StringMap.find_opt "_0" fields |> function - | Some a -> Ok a - | None -> Error ("mandatory field '_0' does not exist", path)) + List.assoc_opt "_0" fields + |> Option.to_result + ~none:("mandatory field '_0' does not exist", path) + >>= float_of_json' (`f "_0" :: path) >>= fun x0 -> - (Bindoj_runtime.StringMap.find_opt "_1" fields |> function - | Some a -> Ok a - | None -> Error ("mandatory field '_1' does not exist", path)) - >>= fun x1 -> - let ( >>= ) = Result.bind in - float_of_json' (`f "_0" :: path) x0 >>= fun x0 -> - string_of_json' (`f "_1" :: path) x1 >>= fun x1 -> Ok (x0, x1) + List.assoc_opt "_1" fields + |> Option.to_result + ~none:("mandatory field '_1' does not exist", path) + >>= string_of_json' (`f "_1" :: path) + >>= fun x1 -> Ok (x0, x1) | jv -> Error ( Printf.sprintf @@ -225,18 +229,13 @@ and student_of_json' = | `obj param -> let ( >>= ) = Result.bind in List.assoc_opt "admissionYear" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'admissionYear' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'admissionYear' does not exist", path) >>= int_of_json' (`f "admissionYear" :: path) >>= fun x0 -> List.assoc_opt "name" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'name' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'name' does not exist", path) >>= string_of_json' (`f "name" :: path) >>= fun x1 -> Ok { admission_year = x0; name = x1 } | jv -> @@ -376,7 +375,7 @@ let person_json_shape_explanation = `object_of [ `mandatory_field ("kind", `exactly (`str "with-id")); - `mandatory_field ("arg", `tuple_of [ `integral ]); + `mandatory_field ("arg", `integral); ]; `object_of [ @@ -459,41 +458,30 @@ and person_of_json' = | `obj (("kind", `str "student") :: param) -> let ( >>= ) = Result.bind in List.assoc_opt "studentId" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'studentId' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'studentId' does not exist", path) >>= int_of_json' (`f "studentId" :: path) >>= fun x0 -> List.assoc_opt "name" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'name' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'name' does not exist", path) >>= string_of_json' (`f "name" :: path) >>= fun x1 -> Ok (Student { student_id = x0; name = x1 }) | `obj (("kind", `str "teacher") :: param) -> let ( >>= ) = Result.bind in List.assoc_opt "facultyId" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'facultyId' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'facultyId' does not exist", path) >>= int_of_json' (`f "facultyId" :: path) >>= fun x0 -> List.assoc_opt "name" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'name' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'name' does not exist", path) >>= string_of_json' (`f "name" :: path) >>= fun x1 -> List.assoc_opt "department" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'department' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'department' does not exist", path) >>= string_of_json' (`f "department" :: path) >>= fun x2 -> Ok (Teacher { faculty_id = x0; name = x1; department = x2 }) diff --git a/example/ex01/test/test.t b/example/ex01/test/test.t index c8f154b..e8afd59 100644 --- a/example/ex01/test/test.t +++ b/example/ex01/test/test.t @@ -42,9 +42,9 @@ Check endpoints > -d '{"kind":"student","studentId":0}' HTTP/1.1 400 Status 400 Content-Type: application/json - content-length: 768 + content-length: 762 - "Bad request: invalid json format - mandatory field 'name' does not exist; expected shape: `with_warning (\n(\"not considering any config if exists\",\n `named ((\"Person\",\n `anyone_of ([`object_of ([`mandatory_field ((\"kind\", `exactly (\"anonymous\")))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"with-id\"))); `mandatory_field ((\"arg\", `tuple_of ([`integral])))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"student\"))); `mandatory_field ((\"studentId\", `integral));\n`mandatory_field ((\"name\", `string))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"teacher\"))); `mandatory_field ((\"facultyId\", `integral));\n`mandatory_field ((\"name\", `string));\n`mandatory_field ((\"department\", `string))])\n])))))" + "Bad request: invalid json format - mandatory field 'name' does not exist at root; expected shape: `with_warning (\n(\"not considering any config if exists\",\n `named ((\"Person\",\n `anyone_of ([`object_of ([`mandatory_field ((\"kind\", `exactly (\"anonymous\")))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"with-id\"))); `mandatory_field ((\"arg\", `integral))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"student\"))); `mandatory_field ((\"studentId\", `integral));\n`mandatory_field ((\"name\", `string))]);\n`object_of ([`mandatory_field ((\"kind\", `exactly (\"teacher\"))); `mandatory_field ((\"facultyId\", `integral));\n`mandatory_field ((\"name\", `string));\n`mandatory_field ((\"department\", `string))])\n])))))" Kill the server process in the background. $ kill -9 $PID diff --git a/example/ex02/generated/ex02.ml b/example/ex02/generated/ex02.ml index d83f653..2dca11b 100644 --- a/example/ex02/generated/ex02.ml +++ b/example/ex02/generated/ex02.ml @@ -146,32 +146,23 @@ and product_details_of_json' = | `obj param -> let ( >>= ) = Result.bind in List.assoc_opt "name" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'name' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'name' does not exist", path) >>= string_of_json' (`f "name" :: path) >>= fun x0 -> List.assoc_opt "description" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'description' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'description' does not exist", path) >>= string_of_json' (`f "description" :: path) >>= fun x1 -> List.assoc_opt "price" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'price' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'price' does not exist", path) >>= int_of_json' (`f "price" :: path) >>= fun x2 -> List.assoc_opt "count" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'count' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'count' does not exist", path) >>= int_of_json' (`f "count" :: path) >>= fun x3 -> Ok { name = x0; description = x1; price = x2; count = x3 } @@ -263,19 +254,16 @@ and product_of_json' = | `obj param -> let ( >>= ) = Result.bind in List.assoc_opt "id" param - |> (function - | Some a -> Ok a - | None -> Error ("mandatory field 'id' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'id' does not exist", path) >>= (fun path x -> product_id_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) (`f "id" :: path) >>= fun x0 -> List.assoc_opt "details" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'details' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'details' does not exist", path) >>= (fun path x -> product_details_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) @@ -465,7 +453,12 @@ let payment_method_json_shape_explanation = `mandatory_field ("cardNumber", `string); `mandatory_field ("holderName", `string); `mandatory_field - ("expirationDate", `tuple_of [ `integral; `integral ]); + ( "expirationDate", + `object_of + [ + `mandatory_field ("_0", `integral); + `mandatory_field ("_1", `integral); + ] ); `mandatory_field ("cvv", `string); ]; `object_of @@ -539,48 +532,32 @@ and payment_method_of_json' = | `obj (("kind", `str "credit-card") :: param) -> let ( >>= ) = Result.bind in List.assoc_opt "cardNumber" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'cardNumber' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'cardNumber' does not exist", path) >>= string_of_json' (`f "cardNumber" :: path) >>= fun x0 -> List.assoc_opt "holderName" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'holderName' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'holderName' does not exist", path) >>= string_of_json' (`f "holderName" :: path) >>= fun x1 -> List.assoc_opt "expirationDate" param - |> (function - | Some a -> Ok a - | None -> - Error - ( "mandatory field 'expirationDate' does not exist", - path )) + |> Option.to_result + ~none: + ("mandatory field 'expirationDate' does not exist", path) >>= (fun path -> function | (`obj fields : Kxclib.Json.jv) -> - let fields = Bindoj_runtime.StringMap.of_list fields in let ( >>= ) = Result.bind in - (Bindoj_runtime.StringMap.find_opt "_0" fields - |> function - | Some a -> Ok a - | None -> - Error ("mandatory field '_0' does not exist", path)) + List.assoc_opt "_0" fields + |> Option.to_result + ~none:("mandatory field '_0' does not exist", path) + >>= int_of_json' (`f "_0" :: path) >>= fun x0 -> - (Bindoj_runtime.StringMap.find_opt "_1" fields - |> function - | Some a -> Ok a - | None -> - Error ("mandatory field '_1' does not exist", path)) - >>= fun x1 -> - let ( >>= ) = Result.bind in - int_of_json' (`f "_0" :: path) x0 >>= fun x0 -> - int_of_json' (`f "_1" :: path) x1 >>= fun x1 -> - Ok (x0, x1) + List.assoc_opt "_1" fields + |> Option.to_result + ~none:("mandatory field '_1' does not exist", path) + >>= int_of_json' (`f "_1" :: path) + >>= fun x1 -> Ok (x0, x1) | jv -> Error ( Printf.sprintf @@ -592,9 +569,8 @@ and payment_method_of_json' = (`f "expirationDate" :: path) >>= fun x2 -> List.assoc_opt "cvv" param - |> (function - | Some a -> Ok a - | None -> Error ("mandatory field 'cvv' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'cvv' does not exist", path) >>= string_of_json' (`f "cvv" :: path) >>= fun x3 -> Ok @@ -608,26 +584,18 @@ and payment_method_of_json' = | `obj (("kind", `str "bank-transfer") :: param) -> let ( >>= ) = Result.bind in List.assoc_opt "accountNumber" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'accountNumber' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'accountNumber' does not exist", path) >>= string_of_json' (`f "accountNumber" :: path) >>= fun x0 -> List.assoc_opt "bankName" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'bankName' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'bankName' does not exist", path) >>= string_of_json' (`f "bankName" :: path) >>= fun x1 -> List.assoc_opt "holderName" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'holderName' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'holderName' does not exist", path) >>= string_of_json' (`f "holderName" :: path) >>= fun x2 -> Ok @@ -723,12 +691,15 @@ let order_details_json_shape_explanation = `mandatory_field ( "products", `array_of - (`tuple_of + (`object_of [ - (match product_id_json_shape_explanation with - | `with_warning (_, (`named _ as s)) -> s - | `with_warning (_, s) | s -> `named ("ProductId", s)); - `integral; + `mandatory_field + ( "_0", + match product_id_json_shape_explanation with + | `with_warning (_, (`named _ as s)) -> s + | `with_warning (_, s) | s -> + `named ("ProductId", s) ); + `mandatory_field ("_1", `integral); ]) ); `mandatory_field ( "paymentMethod", @@ -792,35 +763,25 @@ and order_details_of_json' = | `obj param -> let ( >>= ) = Result.bind in List.assoc_opt "products" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'products' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'products' does not exist", path) >>= (list_of_json' (fun path -> function | (`obj fields : Kxclib.Json.jv) -> - let fields = Bindoj_runtime.StringMap.of_list fields in - let ( >>= ) = Result.bind in - (Bindoj_runtime.StringMap.find_opt "_0" fields - |> function - | Some a -> Ok a - | None -> - Error ("mandatory field '_0' does not exist", path)) - >>= fun x0 -> - (Bindoj_runtime.StringMap.find_opt "_1" fields - |> function - | Some a -> Ok a - | None -> - Error ("mandatory field '_1' does not exist", path)) - >>= fun x1 -> let ( >>= ) = Result.bind in - (fun path x -> - product_id_of_json' ~path x - |> Result.map_error (fun (msg, path, _) -> - (msg, path))) - (`f "_0" :: path) x0 + List.assoc_opt "_0" fields + |> Option.to_result + ~none:("mandatory field '_0' does not exist", path) + >>= (fun path x -> + product_id_of_json' ~path x + |> Result.map_error (fun (msg, path, _) -> + (msg, path))) + (`f "_0" :: path) >>= fun x0 -> - int_of_json' (`f "_1" :: path) x1 >>= fun x1 -> - Ok (x0, x1) + List.assoc_opt "_1" fields + |> Option.to_result + ~none:("mandatory field '_1' does not exist", path) + >>= int_of_json' (`f "_1" :: path) + >>= fun x1 -> Ok (x0, x1) | jv -> Error ( Printf.sprintf @@ -832,11 +793,8 @@ and order_details_of_json' = (`f "products" :: path) >>= fun x0 -> List.assoc_opt "paymentMethod" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'paymentMethod' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'paymentMethod' does not exist", path) >>= (fun path x -> payment_method_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) @@ -1051,37 +1009,29 @@ and order_of_json' = | `obj param -> let ( >>= ) = Result.bind in List.assoc_opt "id" param - |> (function - | Some a -> Ok a - | None -> Error ("mandatory field 'id' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'id' does not exist", path) >>= (fun path x -> order_id_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) (`f "id" :: path) >>= fun x0 -> List.assoc_opt "totalPrice" param - |> (function - | Some a -> Ok a - | None -> - Error - ("mandatory field 'totalPrice' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'totalPrice' does not exist", path) >>= int_of_json' (`f "totalPrice" :: path) >>= fun x1 -> List.assoc_opt "details" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'details' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'details' does not exist", path) >>= (fun path x -> order_details_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) (`f "details" :: path) >>= fun x2 -> List.assoc_opt "status" param - |> (function - | Some a -> Ok a - | None -> - Error ("mandatory field 'status' does not exist", path)) + |> Option.to_result + ~none:("mandatory field 'status' does not exist", path) >>= (fun path x -> order_status_of_json' ~path x |> Result.map_error (fun (msg, path, _) -> (msg, path))) @@ -1173,18 +1123,17 @@ let product_query_json_shape_explanation = let rec product_query_to_json = (let string_to_json (x : string) : Kxclib.Json.jv = `str x - and option_to_json t_to_json = function - | Some x -> t_to_json x - | None -> (`null : Kxclib.Json.jv) and int_to_json (x : int) : Kxclib.Json.jv = `num (float_of_int x) in fun { searchQuery = x0; minimum_price = x1; maximum_price = x2; limit = x3 } -> `obj - [ - ("searchQuery", (option_to_json string_to_json) x0); - ("minimumPrice", (option_to_json int_to_json) x1); - ("maximumPrice", (option_to_json int_to_json) x2); - ("limit", (option_to_json int_to_json) x3); - ] + (List.filter_map + (fun x -> x) + [ + Option.map (fun x0 -> ("searchQuery", string_to_json x0)) x0; + Option.map (fun x1 -> ("minimumPrice", int_to_json x1)) x1; + Option.map (fun x2 -> ("maximumPrice", int_to_json x2)) x2; + Option.map (fun x3 -> ("limit", int_to_json x3)) x3; + ]) : product_query -> Kxclib.Json.jv) [@@warning "-39"] @@ -1348,10 +1297,7 @@ let order_query_json_shape_explanation = [@@warning "-39"] let rec order_query_to_json = - (let option_to_json t_to_json = function - | Some x -> t_to_json x - | None -> (`null : Kxclib.Json.jv) - and list_to_json t_to_json xs : Kxclib.Json.jv = `arr (List.map t_to_json xs) + (let list_to_json t_to_json xs : Kxclib.Json.jv = `arr (List.map t_to_json xs) and int_to_json (x : int) : Kxclib.Json.jv = `num (float_of_int x) in fun { products = x0; @@ -1361,13 +1307,19 @@ let rec order_query_to_json = limit = x4; } -> `obj - [ - ("products", (option_to_json (list_to_json int_to_json)) x0); - ("status", (option_to_json (list_to_json order_status_to_json)) x1); - ("minimumPrice", (option_to_json int_to_json) x2); - ("maximumPrice", (option_to_json int_to_json) x3); - ("limit", (option_to_json int_to_json) x4); - ] + (List.filter_map + (fun x -> x) + [ + Option.map + (fun x0 -> ("products", (list_to_json int_to_json) x0)) + x0; + Option.map + (fun x1 -> ("status", (list_to_json order_status_to_json) x1)) + x1; + Option.map (fun x2 -> ("minimumPrice", int_to_json x2)) x2; + Option.map (fun x3 -> ("maximumPrice", int_to_json x3)) x3; + Option.map (fun x4 -> ("limit", int_to_json x4)) x4; + ]) : order_query -> Kxclib.Json.jv) [@@warning "-39"] diff --git a/example/ex02/generated/ex02.ts b/example/ex02/generated/ex02.ts index 6996801..e7753dd 100644 --- a/example/ex02/generated/ex02.ts +++ b/example/ex02/generated/ex02.ts @@ -47,17 +47,12 @@ export type OrderStatus = "Unpaid" | "Paid" | "Shipped" | "Delivered" | "Cancele export type Order = { details: OrderDetails; id: OrderId; status: OrderStatus; totalPrice: number }; -export type ProductQuery = { - limit: number | null | undefined; - maximumPrice: number | null | undefined; - minimumPrice: number | null | undefined; - searchQuery: string | null | undefined; -}; +export type ProductQuery = { limit?: number; maximumPrice?: number; minimumPrice?: number; searchQuery?: string }; export type OrderQuery = { - limit: number | null | undefined; - maximumPrice: number | null | undefined; - minimumPrice: number | null | undefined; - products: number[] | null | undefined; - status: OrderStatus[] | null | undefined; + limit?: number; + maximumPrice?: number; + minimumPrice?: number; + products?: number[]; + status?: OrderStatus[]; }; diff --git a/example/ex02/generated/ex02_apidir.json b/example/ex02/generated/ex02_apidir.json index e769ac4..24f2148 100644 --- a/example/ex02/generated/ex02_apidir.json +++ b/example/ex02/generated/ex02_apidir.json @@ -12,29 +12,12 @@ "application/json": { "schema": { "$ref": "#/components/schemas/ProductQuery" }, "examples": { - "Sample to get all products": { - "value": { - "searchQuery": null, - "minimumPrice": null, - "maximumPrice": null, - "limit": null - } - }, + "Sample to get all products": { "value": {} }, "Sample with search query": { - "value": { - "searchQuery": "novel", - "minimumPrice": null, - "maximumPrice": null, - "limit": null - } + "value": { "searchQuery": "novel" } }, "Sample with minimum price": { - "value": { - "searchQuery": null, - "minimumPrice": 1000, - "maximumPrice": null, - "limit": null - } + "value": { "minimumPrice": 1000 } } } } @@ -141,41 +124,13 @@ "application/json": { "schema": { "$ref": "#/components/schemas/OrderQuery" }, "examples": { - "sample to get all orders": { - "value": { - "products": null, - "status": null, - "minimumPrice": null, - "maximumPrice": null, - "limit": null - } - }, - "Sample with products": { - "value": { - "products": [0], - "status": null, - "minimumPrice": null, - "maximumPrice": null, - "limit": null - } - }, + "sample to get all orders": { "value": {} }, + "Sample with products": { "value": { "products": [0] } }, "Sample with status": { - "value": { - "products": null, - "status": ["Delivered"], - "minimumPrice": null, - "maximumPrice": null, - "limit": null - } + "value": { "status": ["Delivered"] } }, "Sample with minimum total price": { - "value": { - "products": null, - "status": null, - "minimumPrice": 1500, - "maximumPrice": null, - "limit": null - } + "value": { "minimumPrice": 1500 } } } } diff --git a/example/ex02/test/test.t b/example/ex02/test/test.t index 9160c7d..ed5abd1 100644 --- a/example/ex02/test/test.t +++ b/example/ex02/test/test.t @@ -79,9 +79,9 @@ Check endpoints > -d '{ "_0": 0, _1: { "price": 1000 } }' HTTP/1.1 400 Status 400 Content-Type: application/json - content-length: 1006 + content-length: 1547 - "Bad request: invalid json format - mandatory field 'name' does not exist; expected shape: `with_warning (\n(\"not considering any config if exists\",\n `named ((\"ProductDetailsWithId\",\n `tuple_of ([`named ((\"ProductId\", `integral));\n `named ((\"ProductDetails\",\n `object_of ([`mandatory_field ((\"name\",\n `string));\n `mandatory_field ((\"description\",\n `string));\n `mandatory_field ((\"price\",\n `integral));\n `mandatory_field ((\"count\",\n `integral))\n ])))\n ])))))" + "Bad request: invalid json format - mandatory field 'name' does not exist at path ._1; expected shape: `with_warning (\n(\"not considering any config if exists\",\n `named ((\"ProductDetailsWithId\",\n `object_of ([`mandatory_field ((\"_0\",\n `named ((\"ProductId\", `integral))));\n `mandatory_field ((\"_1\",\n `named ((\"ProductDetails\",\n `object_of ([`mandatory_field (\n (\"name\",\n `string));\n `mandatory_field (\n (\"description\",\n `string));\n `mandatory_field (\n (\"price\",\n `integral));\n `mandatory_field (\n (\"count\",\n `integral))\n ])))))\n ])))))" Kill the server process in the background. $ kill -9 $PID diff --git a/src/lib_apidir_runtime/apidir_server_bridge.ml b/src/lib_apidir_runtime/apidir_server_bridge.ml index 1082bd5..6b43ca5 100644 --- a/src/lib_apidir_runtime/apidir_server_bridge.ml +++ b/src/lib_apidir_runtime/apidir_server_bridge.ml @@ -19,6 +19,7 @@ AnchorZ Inc. to satisfy its needs in its product development workflow. *) open Kxclib open Kxclib.Json +open Bindoj_runtime open Bindoj_apidir_shared module TupleJsonResponse : (Apidir_base.JsonResponse with type t = int * jv) = struct @@ -105,7 +106,7 @@ module Make (Dir : ApiDirManifest) (IoStyle : Monadic) = struct let jv = Bindoj_codec.Json.to_json ~env:tdenv ttd unpacked in (resp_status, jv) - let handle_json_post' : invp' -> jv -> TupleJsonResponse.t Bindoj_runtime.OfJsonResult.t io = + let handle_json_post' : invp' -> jv -> TupleJsonResponse.t OfJsonResult.t io = fun invp reqbody -> let invpm = let Invp(invp) = invp in @@ -116,23 +117,22 @@ module Make (Dir : ApiDirManifest) (IoStyle : Monadic) = struct invalid_arg "no handler registered for the requested api" | Some (Handler (invpa, handler)) -> - let module JR = Bindoj_runtime.OfJsonResult in match invpm.ipm_method, invpa.ipa_request_body with | `get, _ -> invalid_arg' "handle_json_post got GET invp: %s" invpm.ipm_name | `post, None -> invalid_arg' "POST method must have a request body definition: %s" invpm.ipm_name | `post, Some desc -> let ttd = Utils.ttd_of_media_type desc.rq_media_type in match reqbody |> Bindoj_codec.Json.of_json' ~env:tdenv ttd with - | Ok req -> handler req >|= (create_response invpa.ipa_responses &> JR.return) + | Ok req -> handler req >|= (create_response invpa.ipa_responses &> OfJsonResult.return) | Error e -> return (Error e) let handle_json_post : invp' -> jv -> TupleJsonResponse.t io = fun invp reqbody -> handle_json_post' invp reqbody >>= function | Ok resp -> return resp - | Error (errmsg, _, shape) -> + | Error ((_, _, shape) as e) -> Utils.bad_request "invalid json format - %s; expected shape: %a" - errmsg + (OfJsonResult.Err.to_string e) Bindoj_runtime.Json_shape.pp_shape_explanation shape let handle_json_get : invp' -> TupleJsonResponse.t io = diff --git a/src/lib_codec/json.ml b/src/lib_codec/json.ml index d366aa3..eda409f 100644 --- a/src/lib_codec/json.ml +++ b/src/lib_codec/json.ml @@ -103,12 +103,22 @@ let explain_encoded_json_shape' |> process_object and process_non_spread_variant_argument ~base_ident_codec base_mangling_style va: shape = if Json_config.get_nested_field_style va.va_configs = `spreading then - invalid_arg "Spreading of the nested type of tuple_like is only possible if that element is the only one."; - match va with - | { va_type = `direct ct; _ } -> + invalid_arg "Spreading of the nested type of tuple_like is only valid if there is only a single argument."; + match va.va_type with + | `direct ct -> process_coretype' ~base_ident_codec base_mangling_style ct - | { va_type = `nested (td, codec); _ } -> + | `nested (td, codec) -> process_td ~base_ident_codec:(inherit_codec base_ident_codec codec) td + and process_non_spread_variant_argument' ~base_ident_codec base_mangling_style field_name va: field_shape = + if Json_config.get_nested_field_style va.va_configs = `spreading then + invalid_arg "Spreading of the nested type of tuple_like is only valid if there is only a single argument."; + match va.va_type with + | `direct ({ ct_desc = Option desc; _ } as ct) + | `nested ({ td_kind = Alias_decl ({ ct_desc = Option desc; _ } as ct); _ }, _) -> + optional_field (field_name, process_coretype' ~base_ident_codec base_mangling_style { ct with ct_desc = desc }) + | _ -> + let shape = process_non_spread_variant_argument ~base_ident_codec base_mangling_style va in + mandatory_field (field_name, shape) and process_spread_variant_argument ~base_ident_codec va: field_shape list list = let base_mangling_style = Json_config.default_mangling_style in begin match validate_spreading_type va.va_type with @@ -143,11 +153,14 @@ let explain_encoded_json_shape' match nested_style, rf_type with | `nested, `direct ct -> List.return [ field_of_coretype base_mangling_style json_field_name ct ] - | `nested, `nested ({ td_kind = Alias_decl ct; _ } as td, codec) when Coretype.is_option ct -> + | `nested, `nested ({ td_kind = Alias_decl ({ ct_desc = Option desc; _ } as ct); _ }, codec) -> List.return [ optional_field ( json_field_name, - process_td ~base_ident_codec:(inherit_codec base_ident_codec codec) td) + process_coretype' + ~base_ident_codec:(inherit_codec base_ident_codec codec) + Json_config.default_mangling_style + { ct with ct_desc = desc }) ] | `nested, `nested (td, codec) -> List.return [ @@ -174,29 +187,31 @@ let explain_encoded_json_shape' let (discriminator_value, base_mangling_style) = Json_config.get_mangled_name_of_discriminator ~inherited:base_mangling_style ctor in - let append_discriminator fields = - let kind_field = - mandatory_field (discriminator_fname, exactly (`str discriminator_value)) - in - match fields with - | [] -> failwith "The given list must not be empty." - | fs -> (fs |&> (fun fields -> (kind_field :: fields))) - in - match vc_param with + begin match vc_param with | `no_param -> - append_discriminator (List.return []) + List.return [] | `tuple_like [ va ] when Json_config.get_nested_field_style va.va_configs = `spreading -> process_spread_variant_argument ~base_ident_codec va - |> append_discriminator - | `tuple_like cts -> + | `tuple_like vas -> let arg_fname = Json_config.(get_name_of_variant_arg default_name_of_variant_arg) vc_configs |> Json_config.mangled `field_name base_mangling_style in - let arg_shape = tuple_of (cts |&> process_non_spread_variant_argument ~base_ident_codec base_mangling_style) in - append_discriminator (List.return [ mandatory_field (arg_fname, arg_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) + | `arr, [ va ] -> + [ process_non_spread_variant_argument' ~base_ident_codec base_mangling_style arg_fname va ] + | `arr, vas -> + let arg_shape = tuple_of (vas |&> process_non_spread_variant_argument ~base_ident_codec base_mangling_style) in + [ mandatory_field (arg_fname, arg_shape) ] + end + |> List.return | `inline_record fields -> - append_discriminator (process_fields ~base_ident_codec base_mangling_style fields) + process_fields ~base_ident_codec base_mangling_style fields | `reused_inline_record { td_kind; td_configs; _ } -> let base_mangling_style = Json_config.(get_mangling_style_opt td_configs |? default_mangling_style) @@ -205,7 +220,13 @@ let explain_encoded_json_shape' | Record_decl fields -> fields | _ -> failwith' "panic - type decl of reused inline record '%s' must be record decl." vc_name in - append_discriminator (process_fields ~base_ident_codec base_mangling_style fields) + process_fields ~base_ident_codec base_mangling_style fields + end + |> function + | [] -> failwith "The given list must not be empty." + | fs -> + fs |&> fun fields -> + (mandatory_field (discriminator_fname, exactly (`str discriminator_value)) :: fields) and process_object fields = match fields with | [] -> failwith "The given list must not be empty." @@ -241,7 +262,17 @@ let explain_encoded_json_shape' ~base_mangling_style) base_ident_codec ident ident_json_name) | Option d -> nullable (go d) - | Tuple ds -> tuple_of (ds |&> go) + | Tuple ds -> + begin match Json_config.get_tuple_style configs with + | `obj `default -> + ds |> List.mapi (fun i -> + let field_name = Json_config.tuple_index_to_field_name i in + function + | Coretype.Option desc -> optional_field (field_name, go desc) + | desc -> mandatory_field (field_name, go desc)) + |> object_of + | `arr -> tuple_of (ds |&> go) + end | List desc -> array_of (go desc) | Map (`string, d) -> record_of (go d) | StringEnum xs -> string_enum (xs |&> Json_config.get_mangled_name_of_string_enum_case ~inherited:base_mangling_style) @@ -265,17 +296,14 @@ let explain_encoded_json_shape ~(env: tdenv) (td: 't typed_type_decl) : json_sha let nested_type_to_coretype = function - | `direct ct -> ct, Coretype.is_option ct - | `nested ({ td_name; td_kind; td_configs; _ }, codec) -> - let is_option = match td_kind with - | Alias_decl ct -> Coretype.is_option ct - | _ -> false - in + | `direct ct | `nested({ td_kind = Alias_decl ct; _ }, _) -> + ct, Coretype.is_option ct + | `nested ({ td_name; td_configs; _ }, codec) -> let mangling_style = Json_config.(get_mangling_style_opt td_configs |? default_mangling_style) in Coretype.mk_ident ~configs:[ Json_config.mangling_style mangling_style ] ~codec td_name, - is_option + false open MonadOps(ResultOf(struct type err = string * jvpath end)) @@ -287,15 +315,12 @@ 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 -> _ -> jv -> (Expr.t, string * jvpath) result) (ts: _ list) (fields: jv StringMap.t) = + 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 - |> function - | None -> Result.error (sprintf "mandatory field '%s' does not exist" field_name, path) - | Some x -> Result.ok x - >>= fun jv -> conv (`f field_name :: path) t jv) + |> conv (`f field_name :: path) field_name t) |> sequence_list in let map2i f l1 l2 = @@ -377,7 +402,12 @@ 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 go ts (StringMap.of_list fields) + parse_obj_style_tuple 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 + | _, None -> Error (sprintf "mandatory field '%s' does not exist" field_name, path) + )) ts (StringMap.of_list fields) >|= (fun xs -> Expr.Tuple xs) | _, `obj `default -> Result.error (sprintf "an object is expected for a tuple value, but the given is of type '%s'" (jv |> classify_jv |> string_of_jv_kind), path) @@ -489,38 +519,47 @@ let rec of_json_impl : ?path:jvpath -> env:tdenv -> 'a typed_type_decl -> jv -> let mk_result = mk_result "tuple" mk in let variant_argument_of_json base_mangling_style path va jv = if Json_config.get_nested_field_style va.va_configs = `spreading then - invalid_arg "Spreading of the nested type of tuple_like is only possible if that element is the only one."; + invalid_arg "Spreading of the nested type of tuple_like is only valid if there is only a single argument."; let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in let ct, _ = nested_type_to_coretype va.va_type in expr_of_json base_mangling_style path ct jv in begin match Json_config.get_tuple_style ctor.vc_configs, ts with | `obj `default, _ :: _ :: _ -> - parse_obj_style_tuple path (variant_argument_of_json base_mangling_style) ts obj + 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 >>= (fun x -> mk_result path x) | _, [] -> mk_result path [] | _, _ -> obj |> StringMap.find_opt arg_fname - |> opt_to_result (sprintf "mandatory field '%s' does not exist" arg_fname, path) - >>= (fun arg -> - let path = `f arg_fname :: path in + |> (fun arg -> + let arg_path = `f arg_fname :: path in match ts, arg with - | [t], _ -> - variant_argument_of_json base_mangling_style path t arg + | [ { va_type = `direct ct | `nested ({ td_kind = Alias_decl ct; _}, _); _ } + ], None when Coretype.is_option ct -> + mk_result path [ Expr.None ] + | [t], Some arg -> + variant_argument_of_json base_mangling_style arg_path t arg >>= fun expr -> mk_result path [expr] - | ts, `arr xs -> - try_result path - (fun () -> - map2i (fun i va -> - variant_argument_of_json base_mangling_style (`i i :: path) va) ts xs |> function - | Some es -> es >>=* fun x -> mk_result path x - | None -> - let ts_len = List.length ts in - let xs_len = List.length xs in - let msg = sprintf "expecting an array of length %d, but the given has a length of %d" ts_len xs_len in - Result.error (msg, path)) - | _, jv -> 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) + | ts, Some (`arr xs) -> + try_result path (fun () -> + map2i (fun i va -> + variant_argument_of_json base_mangling_style (`i i :: arg_path) va) ts xs + |> function + | Some es -> es >>=* fun x -> mk_result path x + | None -> + let ts_len = List.length ts in + let xs_len = List.length xs in + let msg = sprintf "expecting an array of length %d, but the given has a length of %d" ts_len xs_len in + Result.error (msg, arg_path)) + | _, Some jv -> 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) + | _, None -> Result.error (sprintf "mandatory field '%s' does not exist" arg_fname, path) ) end | `inline_record fields, InlineRecord { mk; _ } -> @@ -597,7 +636,14 @@ let rec to_json ~(env: tdenv) (a: 'a typed_type_decl) (value: 'a) : jv = match Json_config.get_tuple_style ct.ct_configs with | `arr -> `arr (List.map2 go ts xs) | `obj `default -> - `obj (List.combine ts xs |> List.mapi (fun i (t, x) -> Json_config.tuple_index_to_field_name i, go t x)) + `obj ( + List.combine ts xs + |> List.mapi (fun i -> function + | Coretype.Option (Option _), _ -> failwith "Nested option types cannot be json fields." + | Option _, Expr.None -> None + | (t, x) -> Some (Json_config.tuple_index_to_field_name i, go t x) + ) + |> List.filter_map identity) end | Map (`string, t), Expr.Map xs -> `obj (List.map (fun (k, v) -> k, go t v) xs) | Option t, Expr.Some x -> go t x @@ -621,7 +667,7 @@ let rec to_json ~(env: tdenv) (a: 'a typed_type_decl) (value: 'a) : jv = match StringMap.find_opt field.rf_name expr with | None -> fail (sprintf "missing field '%s'" rf_name) | Some value -> - let ct, _ = nested_type_to_coretype rf_type in + let ct, is_option = nested_type_to_coretype rf_type in match nested_style, rf_type with | `spreading, _ -> begin match validate_spreading_type rf_type with @@ -631,6 +677,7 @@ let rec to_json ~(env: tdenv) (a: 'a typed_type_decl) (value: 'a) : jv = | _ -> fail "Only record decl or variant decl can be spread." end end + | `nested, _ when is_option && value = Expr.None -> [] | `nested, _ -> [ json_field_name, expr_to_json base_mangling_style ct value ] in let variant_to_json base_mangling_style (ctor: variant_constructor) (expr: 'a Refl.constructor) = @@ -676,24 +723,30 @@ let rec to_json ~(env: tdenv) (a: 'a typed_type_decl) (value: 'a) : jv = fail "tuple length mismatch" end | `tuple_like ts, TupleLike { get; _ } -> - let variant_argument_to_json base_mangling_style va = + let variant_argument_to_json base_mangling_style va expr = if Json_config.get_nested_field_style va.va_configs = `spreading then - invalid_arg "Spreading of the nested type of tuple_like is only possible if that element is the only one."; - let ct, _ = nested_type_to_coretype va.va_type in - expr_to_json base_mangling_style ct + invalid_arg "Spreading of the nested type of tuple_like is only valid if there is only a single argument."; + let ct, is_option = nested_type_to_coretype va.va_type in + expr_to_json base_mangling_style ct expr, is_option in begin match ts, get value, Json_config.get_tuple_style ctor.vc_configs with | [], [], _ -> `obj discriminator_field | [t], [e], _ -> - let value = variant_argument_to_json base_mangling_style t e in - `obj (discriminator_field @ [arg_fname, value]) + let value, is_option = variant_argument_to_json base_mangling_style t e in + if is_option && e = Expr.None then + `obj discriminator_field + else + `obj (discriminator_field @ [arg_fname, value]) | ts, es, `arr -> - let value = `arr (List.map2 (variant_argument_to_json base_mangling_style) ts es) in + let value = `arr (List.map2 (fun va expr -> variant_argument_to_json base_mangling_style va expr |> fst) ts es) in `obj (discriminator_field @ [arg_fname, value]) | ts, es, `obj `default -> - let fields = List.combine ts es |> List.mapi (fun i (t, x) -> - Json_config.tuple_index_to_field_name i, - variant_argument_to_json base_mangling_style t x) + let fields = List.combine ts es |> List.mapi (fun i (t, e) -> + 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) + ) |&?> identity in `obj (discriminator_field @ fields) end diff --git a/src/lib_gen/caml_datatype.ml b/src/lib_gen/caml_datatype.ml index 383e1cb..ba354e2 100644 --- a/src/lib_gen/caml_datatype.ml +++ b/src/lib_gen/caml_datatype.ml @@ -73,8 +73,8 @@ and type_manifest_of_type_decl_kind : self_name:string -> type_decl -> core_type true (match ts with | [] -> failwith "impossible" - | [arg] -> [type_of_coretype ~self_name @@ nested_type_to_coretype arg.va_type] - | args -> [Typ.tuple (args |&> fun { va_type; _ } -> type_of_coretype ~self_name @@ nested_type_to_coretype va_type)]) + | [arg] -> [type_of_nested_type ~self_name arg.va_type] + | args -> [Typ.tuple (args |&> fun { va_type; _ } -> type_of_nested_type ~self_name va_type)]) | `inline_record _ -> failwith' "case '%s' with an inline record cannot be used in a polymorphic variant" ctor.vc_name | `reused_inline_record _ -> @@ -87,7 +87,7 @@ and label_declarations_of_record_fields ~self_name fields = Type.field ~attrs:(doc_attribute field.rf_doc) (locmk field.rf_name) - (type_of_coretype ~self_name @@ nested_type_to_coretype field.rf_type) + (type_of_nested_type ~self_name field.rf_type) and constructor_declarations_of_variant_constructors ~self_name ctors = ctors |&> fun ctor -> @@ -96,7 +96,7 @@ and constructor_declarations_of_variant_constructors ~self_name ctors = | `no_param -> ctor.vc_name, Pcstr_tuple [] | `tuple_like ts -> - ctor.vc_name, Pcstr_tuple (ts |&> fun { va_type; _ } -> type_of_coretype ~self_name @@ nested_type_to_coretype va_type) + ctor.vc_name, Pcstr_tuple (ts |&> fun { va_type; _ } -> type_of_nested_type ~self_name va_type) | `inline_record fields -> ctor.vc_name, Pcstr_record (fields |> label_declarations_of_record_fields ~self_name) | `reused_inline_record decl -> @@ -143,6 +143,10 @@ and type_of_coretype : self_name:string -> coretype -> core_type = | Self -> typcons self_name in go ct_desc +and type_of_nested_type ~self_name = function + | `direct ct -> type_of_coretype ~self_name ct + | `nested ({ td_name; _ }, codec) -> + typcons (Utils.type_name_with_codec ~codec td_name) open Bindoj_base.Typed_type_desc @@ -236,6 +240,14 @@ and coretype_of_expr ~self_name (ct: coretype) = in go ct.ct_desc +and nested_type_of_expr ~self_name = function + | `direct ct | `nested({ td_kind = Alias_decl ct; _ }, _) -> + coretype_of_expr ~self_name ct + | `nested({ td_name; _}, id_codec) -> + let loc = Location.none in + let ident = { Coretype.id_name = td_name; id_codec } in + [%expr Expr.to_refl [%e get_refl ident]] + and coretype_to_expr ~self_name (ct: coretype) = let loc = Location.none in let rec go = @@ -272,6 +284,14 @@ and coretype_to_expr ~self_name (ct: coretype) = in go ct.ct_desc +and nested_type_to_expr ~self_name = function + | `direct ct | `nested({ td_kind = Alias_decl ct; _ }, _) -> + coretype_to_expr ~self_name ct + | `nested({ td_name; _}, id_codec) -> + let loc = Location.none in + let ident = { Coretype.id_name = td_name; id_codec } in + [%expr Expr.of_refl [%e get_refl ident]] + and gen_reflect_alias ~self_name (ct: coretype) : expression = let loc = Location.none in [%expr Refl.Alias { @@ -297,7 +317,7 @@ and gen_reflect_record_impl ~self_name ?(mk_ctor=identity) (fields: record_field fields |> List.map (fun field -> Exp.tuple [ Exp.constant (Const.string (field.rf_name)); - [%expr [%e coretype_to_expr ~self_name @@ nested_type_to_coretype field.rf_type] [%e evar field.rf_name]] + [%expr [%e nested_type_to_expr ~self_name field.rf_type] [%e evar field.rf_name]] ] ) |> elist |> fun e -> [%expr StringMap.of_list [%e e]] in @@ -312,7 +332,7 @@ and gen_reflect_record_impl ~self_name ?(mk_ctor=identity) (fields: record_field [%expr [%e arg] |> StringMap.find_opt [%e sname] - >>= [%e coretype_of_expr ~self_name @@ nested_type_to_coretype field.rf_type] + >>= [%e nested_type_of_expr ~self_name field.rf_type] >>= fun [%p pname] -> [%e body] ] ) [%expr Some [%e mk_body]] @@ -357,12 +377,12 @@ and gen_reflect_variant_impl ~self_name ~poly (ctors: variant_constructor list) | `tuple_like [] -> invalid_arg "tuple_like but 0 items defined" | `tuple_like [t] -> let get = [%expr function - | [%p ctor_pat ~arg:[%pat? x] ()] -> [[%e coretype_to_expr ~self_name @@ nested_type_to_coretype t.va_type] x] + | [%p ctor_pat ~arg:[%pat? x] ()] -> [[%e nested_type_to_expr ~self_name t.va_type] x] | _ -> [%e invalid]] in let mk = [%expr function | [x] -> - [%e coretype_of_expr ~self_name @@ nested_type_to_coretype t.va_type] x + [%e nested_type_of_expr ~self_name t.va_type] x |> Option.map (fun x -> [%e ctor_expr ~arg:[%expr x] ()]) | _ -> None] in @@ -372,7 +392,7 @@ and gen_reflect_variant_impl ~self_name ~poly (ctors: variant_constructor list) let evars = ts |> List.mapi (fun i t -> t, evari i) in let get_body = evars |> List.map (fun (t, x) -> - [%expr [%e coretype_to_expr ~self_name @@ nested_type_to_coretype t.va_type] [%e x]] + [%expr [%e nested_type_to_expr ~self_name t.va_type] [%e x]] ) in let get = [%expr function @@ -382,7 +402,7 @@ and gen_reflect_variant_impl ~self_name ~poly (ctors: variant_constructor list) let mk_body = let body = ctor_expr ~arg:(evars |> List.map snd |> Exp.tuple) () in ts - |> List.mapi (fun i t -> pvari i, [%expr [%e coretype_of_expr ~self_name @@ nested_type_to_coretype t.va_type] [%e evari i]]) + |> List.mapi (fun i t -> pvari i, [%expr [%e nested_type_of_expr ~self_name t.va_type] [%e evari i]]) |> List.rev |> List.fold_left (fun expr (pv, result) -> [%expr [%e result] >>= fun [%p pv] -> [%e expr]] diff --git a/src/lib_gen/json_codec.ml b/src/lib_gen/json_codec.ml index 3feb062..307950f 100644 --- a/src/lib_gen/json_codec.ml +++ b/src/lib_gen/json_codec.ml @@ -229,32 +229,111 @@ let codec_of_coretype ~inherited_codec ~get_custom_codec ~get_name ~map_key_conv in go ct.ct_desc -let collect_builtin_codecs (td: type_decl) = - let folder state (ct: coretype) = - Coretype.fold (fun state -> - let add name = state |> StringMap.add name (builtin_codecs_map |> StringMap.find name) in - function - | Prim p -> add (Coretype.string_of_prim p) - | Uninhabitable -> add "uninhabitable" - | Option _ -> add "option" - | List _ -> add "list" - | Map _ -> add "map" - | Ident _ | Self | Tuple _ | StringEnum _ -> state - ) state ct.ct_desc +let collect_builtin_codecs ~including_optional_fields (td: type_decl) = + let folder state = + let folder configs = + let rec go state = + let add name = + state |> StringMap.add name + (builtin_codecs_map |> StringMap.find name) + in + function + | Coretype.Prim p -> add (Coretype.string_of_prim p) + | Uninhabitable -> add "uninhabitable" + | Option d -> go (add "option") d + | List d -> go (add "list") d + | Map (_, d) -> go (add "map") d + | Tuple ds -> + begin match Json_config.get_tuple_style configs with + | `arr -> List.fold_left go state ds + | `obj `default -> + List.fold_left (fun state -> function + | Coretype.Option (Option _) when not including_optional_fields -> + failwith "Nested option types cannot be json fields." + | Option d when not including_optional_fields -> + go state d + | d -> go state d + ) state ds + end + | Ident _ | Self | StringEnum _ -> state + in + go + in + function + | { Coretype.ct_desc; ct_configs }, `alias _ :: [] -> + folder ct_configs state ct_desc + | { ct_desc = Option desc; ct_configs }, + ( (`record_field _ | `variant_field _ | `variant_reused_field _ | `variant_argument (1, _, _, _))::_ + | `alias _ :: (`record_field _ | `variant_field _ | `variant_reused_field _ | `variant_argument (1, _, _, _))::_) + when not including_optional_fields -> + folder ct_configs state desc + | { ct_desc; ct_configs }, + ( (`variant_argument (_, _, vc_configs, _))::_ + | `alias _::(`variant_argument (_, _, vc_configs, _))::_) -> + begin match Json_config.get_tuple_style vc_configs, ct_desc with + | `obj `default, Option desc when not including_optional_fields -> + folder ct_configs state desc + | _, desc -> folder ct_configs state desc + end + | { ct_desc; ct_configs }, _ -> folder ct_configs state ct_desc in - fold_coretypes folder StringMap.empty td + fold_coretypes' folder StringMap.empty td -let bind_results : (pattern * expression) list -> expression -> expression = fun bindings body -> +let bind_results' + : (pattern * expression * [ `bind | `pipe ]) list + -> expression -> expression = + fun bindings body -> let loc = Location.none in - [%expr - let (>>=) = Result.bind in - [%e List.fold_right (fun (p, e) body -> - [%expr [%e e] >>= (fun [%p p] -> [%e body])]) - bindings body]] + let expr, has_bind = + List.fold_right (fun (p, e, kind) (body, has_bind) -> + match kind with + | `bind -> [%expr [%e e] >>= (fun [%p p] -> [%e body])], true + | `pipe -> [%expr [%e e] |> (fun [%p p] -> [%e body])], has_bind + ) bindings (body, false) + in + if has_bind then + [%expr let (>>=) = Result.bind in [%e expr]] + else + expr -let opt_to_result : expression -> expression = - let loc = Location.none in - fun err -> [%expr function | Some a -> Ok a | None -> Error [%e err]] +let bind_results : (pattern * expression) list -> expression -> expression = fun bindings body -> + bindings + |&> (fun (p, e) -> (p, e, `bind)) + |> Fn.flip bind_results' body + +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 + | [] -> 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 encoded, is_optional = to_expr i t in + let efield = [%expr ([%e label], [%e encoded])] in + efield, is_optional) + in + let has_optional = List.exists snd es in + let fields = + es |> List.mapi (fun i (efield, is_optional) -> + if is_optional then + let v = "x"^string_of_int i in + [%expr Option.map (fun [%p pvar v] -> [%e efield]) [%e evar v]] + else if has_optional then + [%expr Some [%e efield]] + else efield + ) + |> elist ~loc + in + let e = + if has_optional then + [%expr List.filter_map Kxclib.identity [%e fields]] + else fields in + begin match additional_field with + | None -> e + | Some f -> [%expr [%e f] :: [%e e]] + end let encoder_of_coretype = let open Coretype in @@ -267,24 +346,23 @@ let encoder_of_coretype = ts |> List.mapi (fun i _ -> pvari i) |> Pat.tuple in - let rec mk_list acc = function - | [] -> acc - | x :: xs -> mk_list [%expr [%e x] :: [%e acc]] xs - in let ret = - let style = Json_config.get_tuple_style configs in - ts - |> List.mapi (fun i t -> - match style with - | `obj `default -> - let label = estring ~loc (tuple_index_to_field_name i) in - [%expr ([%e label], [%e go t] [%e evari i])] - | `arr -> [%expr [%e go t] [%e evari i]]) - |> List.rev |> mk_list [%expr []] - |> (fun ret -> - match style with - | `obj `default -> [%expr `obj [%e ret]] - | `arr -> [%expr `arr [%e ret]]) + match Json_config.get_tuple_style configs with + | `obj `default -> + let fields = + encoder_of_objtuple ~loc (fun i -> function + | Option (Option _) -> failwith "Nested option cannot be json fields." + | Option t -> + [%expr [%e go t] [%e evari i]], true + | t -> + [%expr [%e go t] [%e evari i]], false + ) ts + in + [%expr `obj [%e fields] ] + | `arr -> + [%expr `arr [%e + ts |> List.mapi (fun i t -> [%expr [%e go t] [%e evari i]]) + |> elist ~loc ]] in [%expr fun [%p args] -> ([%e ret] : Kxclib.Json.jv)] in @@ -324,32 +402,29 @@ let decoder_of_coretype = let evari i = evar (vari i) in let pvari i = pvar (vari i) in let tuple_case (configs: [`coretype] configs) (go: desc -> expression) (ts: desc list) = - let rec mk_list acc = function - | [] -> acc - | x :: xs -> mk_list [%pat? [%p x] :: [%p acc]] xs - in - let ret to_path = - let bindings = - ts |> List.mapi (fun i t -> - [%pat? [%p pvari i]], [%expr [%e go t] ([%e to_path i] :: path) [%e evari i]] - ) - in - let ret = - ts |> List.mapi (fun i _ -> [%expr [%e evari i]]) |> Exp.tuple - in - bind_results bindings [%expr Ok [%e ret]] + let ret = + ts |> List.mapi (fun i _ -> [%expr [%e evari i]]) + |> Exp.tuple + |> fun e -> [%expr Ok [%e e]] in match Json_config.get_tuple_style configs with | `arr -> let args = ts |> List.mapi (fun i _ -> pvari i) - |> List.rev |> mk_list [%pat? []] + |> plist ~loc in let tuple_length_error_message = sprintf "expecting a tuple of length %d, but the given has a length of %%d" (List.length ts) in [%expr fun path -> function - | (`arr [%p args] : Kxclib.Json.jv) -> [%e ret (fun i -> [%expr `i [%e eint ~loc i]])] + | (`arr [%p args] : Kxclib.Json.jv) -> [%e + let bindings = + ts |> List.mapi (fun i t -> + pvari i, [%expr [%e go t] (`i [%e eint ~loc i] :: path) [%e evari i]] + ) + in + + bind_results bindings ret] | `arr xs -> Error ( Printf.sprintf @@ -366,21 +441,25 @@ let decoder_of_coretype = | `obj `default -> [%expr fun path -> function | (`obj fields : Kxclib.Json.jv) -> - let fields = Bindoj_runtime.StringMap.of_list fields in [%e ts - |> List.mapi (fun i _ -> + |> List.mapi (fun i t -> let label_name = tuple_index_to_field_name i in let label = estring ~loc label_name in let error_message = sprintf "mandatory field '%s' does not exist" label_name in - pvari i, [%expr - Bindoj_runtime.StringMap.find_opt [%e label] fields - |> [%e opt_to_result [%expr ([%e estring ~loc error_message], path)]] - ]) - |> Fn.flip bind_results (ret (fun i -> - let label_name = tuple_index_to_field_name i in - let label = estring ~loc label_name in - [%expr `f [%e label]])) + match t with + | Option _ -> pvari i, [%expr + List.assoc_opt [%e label] fields + |> Option.value ~default:`null + |> [%e go t] (`f [%e label] :: path) + ] + | _ -> pvari i, [%expr + List.assoc_opt [%e label] fields + |> [%e opt_to_result ~loc [%expr ([%e estring ~loc error_message], path)]] + >>= [%e go t] (`f [%e label] :: path) + ] + ) + |> Fn.flip bind_results ret ] | jv -> Error ( @@ -437,19 +516,23 @@ let decoder_of_coretype = ~wrap_ident e ct -let gen_builtin_codecs ?attrs ~get_name ~get_codec (td: type_decl) = +let gen_builtin_codecs ?attrs ~including_optional_fields ~get_name ~get_codec (td: type_decl) = let loc = Location.none in - let coders = collect_builtin_codecs td in + let coders = collect_builtin_codecs ~including_optional_fields td in let bind (_, name) expr = Vb.mk ~loc ?attrs (Pat.var (strloc name)) expr in StringMap.fold (fun label coder state -> bind (get_name label `default) (get_codec coder) :: state ) coders [] let gen_builtin_encoders : ?attrs:attrs -> type_decl -> value_binding list = - gen_builtin_codecs ~get_name:get_encoder_name ~get_codec:(fun x -> x.encoder) + gen_builtin_codecs + ~including_optional_fields:false + ~get_name:get_encoder_name ~get_codec:(fun x -> x.encoder) let gen_builtin_decoders : ?attrs:attrs -> type_decl -> value_binding list = - gen_builtin_codecs ~get_name:get_decoder_name ~get_codec:(fun x -> x.decoder) + gen_builtin_codecs + ~including_optional_fields:true + ~get_name:get_decoder_name ~get_codec:(fun x -> x.decoder) type json_shape_explanation_resolution = string -> [ @@ -642,25 +725,35 @@ let gen_json_encoder : | `open_ m | `in_module m -> String.lowercase_ascii m ^ "__") ^ json_encoder_name td ^ "_nested" in - let get_encoder ~inherited_codec ~nested ~spreading base_mangling_style self_ename ty arg = + let get_encoder ?(is_field=false) ~inherited_codec ~nested ~spreading base_mangling_style self_ename ty arg = let wrap_obj cond = if cond then (fun e -> [%expr `obj ([%e e] [%e arg])]) else (fun e -> [%expr ([%e e] [%e arg])]) in + let unwrap_option (ct: coretype) = + if is_field then + (match ct.ct_desc with + | Option (Option _) when is_field -> failwith "Nested option types cannot be json fields." + | Option d -> { ct with ct_desc = d }, true + | _ -> ct, false) + else ct, false + in match ty with | `direct ct -> + let ct, is_option = unwrap_option ct in let e = [%expr [%e encoder_of_coretype inherited_codec base_mangling_style self_ename ct]] in - wrap_obj (nested && ct.ct_desc = Coretype.Self) e - | `nested ({ td_kind = Alias_decl ct; _ }, codec) -> + wrap_obj (nested && ct.ct_desc = Coretype.Self) e, is_option + | `nested ({ td_kind = Alias_decl ct; _ }, _) -> + let ct, is_option = unwrap_option ct in let inherited_codec = inherit_codec inherited_codec codec in let e = [%expr [%e encoder_of_coretype inherited_codec base_mangling_style self_ename ct]] in - wrap_obj (nested && ct.ct_desc = Coretype.Self) e + wrap_obj (nested && ct.ct_desc = Coretype.Self) e, is_option | `nested (td, codec) -> let inherited_codec = inherit_codec inherited_codec codec in let e = evar ~loc (nested_encoder_name inherited_codec td) in - wrap_obj (not spreading) e + wrap_obj (not spreading) e, false in let record_params : record_field list -> pattern = fun fields -> ppat_record ~loc @@ -670,11 +763,17 @@ let gen_json_encoder : Closed in let record_to_json_fields ~inherited_codec ~nested ~self_ename base_mangling_style fields = - let rec go (i, current, state) = + let rec go i (current, state) = let update_state () = match current with - | [] -> state - | current -> (elist ~loc @@ List.rev current) :: state + | `mandatory [] | `optional [] -> state + | `mandatory current -> + (elist ~loc @@ List.rev current) :: state + | `optional current -> + [%expr + List.filter_map (fun x -> x) [%e + elist ~loc @@ List.rev current + ]] :: state in function | [] -> update_state () @@ -684,29 +783,41 @@ let gen_json_encoder : in let json_field_name = estring ~loc json_field_name in let nested_style = Json_config.get_nested_field_style field.rf_configs in - let encoder ~spreading = get_encoder ~inherited_codec ~nested ~spreading base_mangling_style self_ename field.rf_type in + let get_encoder ?is_field ~spreading = get_encoder ?is_field ~inherited_codec ~nested ~spreading base_mangling_style self_ename in match nested_style with | `spreading -> begin match validate_spreading_type field.rf_type with | `record_decl _ | `variant_decl _ -> - let efields = encoder ~spreading:true (evari i) in - let state = update_state () in - go (i + 1, [], efields :: state) fields + let efields, _ = get_encoder ~spreading:true field.rf_type (evari i) in + go (i + 1) (`mandatory [], efields :: update_state ()) fields end | `nested -> + let encoded, is_optional = get_encoder ~is_field:true ~spreading:false field.rf_type (evari i) in + let efield = [%expr ([%e json_field_name], [%e encoded])] in let efield = - [%expr ([%e json_field_name], - [%e encoder ~spreading:false (evari i)])] in - go (i + 1, efield::current, state) fields + if is_optional then + [%expr Option.map (fun [%p pvari i] -> [%e efield]) [%e evari i] ] + else efield + in + fields |> go (i + 1) (match is_optional, current with + | false, `mandatory current -> + (`mandatory (efield::current), state) + | false, `optional _ -> + (`mandatory [ efield ], update_state ()) + | true, `optional current -> + (`optional (efield::current), state) + | true, `mandatory _ -> + (`optional [ efield ], update_state ()) + ) in - go (0, [], []) fields + go 0 (`mandatory [], []) fields |> function | [] -> failwith "A record must have at least one field." | hd :: tl -> List.fold_left (fun es e -> [%expr [%e e] @ [%e es]]) hd tl in let variant_params : [`type_decl] configs -> variant_constructor list -> pattern list = fun td_configs constrs -> - constrs |&> fun { vc_name; vc_param; _ } -> + constrs |&>> fun { vc_name; vc_param; _ } -> let of_record_fields ~label fields = match Caml_config.get_variant_type td_configs with | `regular -> @@ -716,25 +827,37 @@ let gen_json_encoder : | `polymorphic -> failwith' "case '%s' with an %s cannot be used in a polymorphic variant" vc_name label in - match vc_param with - | `no_param -> - begin match Caml_config.get_variant_type td_configs with - | `regular -> Pat.construct (lidloc vc_name) None - | `polymorphic -> Pat.variant vc_name None - end - | `tuple_like args -> - let inner = Some (Pat.tuple (List.mapi (fun i _ -> pvari i) args)) in + let construct inner = begin match Caml_config.get_variant_type td_configs with | `regular -> Pat.construct (lidloc vc_name) inner | `polymorphic -> Pat.variant vc_name inner end - | `inline_record fields -> of_record_fields ~label:"inline record" fields + in + match vc_param with + | `no_param -> [ construct None ] + | `tuple_like [ arg ] -> + let nested_style = Json_config.get_nested_field_style arg.va_configs in + begin match nested_style, arg.va_type with + | `nested, (`direct ct | `nested({ td_kind = Alias_decl ct; _}, _)) when Coretype.is_option ct -> + [ construct (Some [%pat? None]); + construct (Some [%pat? Some [%p pvari 0]]); + ] + | _ -> construct (Some (pvari 0)) |> List.return + end + | `tuple_like args -> + Some (Pat.tuple (List.mapi (fun i _ -> pvari i) args)) + |> construct + |> List.return + | `inline_record fields -> + of_record_fields ~label:"inline record" fields + |> List.return | `reused_inline_record decl -> let fields = decl.td_kind |> function | Record_decl fields -> fields | _ -> failwith' "panic - type decl of reused inline record '%s' muts be record decl." vc_name in of_record_fields ~label:"reused inline record" fields + |> List.return in let variant_body : nested:bool -> self_ename:expression -> inherited_codec:Coretype.codec -> [`type_decl] configs -> Json_config.json_mangling_style -> variant_constructor list -> expression list = fun ~nested ~self_ename ~inherited_codec td_configs base_mangling_style cnstrs -> @@ -742,7 +865,7 @@ let gen_json_encoder : Json_config.get_variant_discriminator td_configs |> Json_config.mangled `field_name base_mangling_style in - cnstrs |&> fun ({ vc_name; vc_param; vc_configs; _ } as ctor) -> + cnstrs |&>> fun ({ vc_name; vc_param; vc_configs; _ } as ctor) -> let (discriminator_value, base_mangling_style) = Json_config.get_mangled_name_of_discriminator ~inherited:base_mangling_style ctor in @@ -759,37 +882,50 @@ let gen_json_encoder : | `flatten -> begin match vc_param with | `no_param -> - [%expr [ [%e cstr]]] + List.return [%expr [ [%e cstr]]] | `tuple_like [ va ] when Json_config.get_nested_field_style va.va_configs = `spreading -> let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in begin match validate_spreading_type va.va_type with - | `record_decl _| `variant_decl _-> - let encoder = get_encoder ~inherited_codec ~nested ~spreading:true base_mangling_style self_ename va.va_type in - [%expr ([%e cstr] :: [%e encoder (evari 0)])] + | `record_decl _ | `variant_decl _-> + let encoder expr = + expr + |> get_encoder + ~inherited_codec ~nested ~spreading:true + base_mangling_style self_ename va.va_type + |> fst + in + List.return [%expr ([%e cstr] :: [%e encoder (evari 0)])] end | `tuple_like args -> let arg_fname = estring ~loc arg_fname in - let args = - List.mapi (fun i va -> - let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in - let encoder = get_encoder ~inherited_codec ~nested ~spreading:false base_mangling_style self_ename va.va_type in - encoder (evari i)) - args + let expr_of_arg ?is_field i va = + let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in + let encoder = get_encoder ?is_field ~inherited_codec ~nested ~spreading:false base_mangling_style self_ename va.va_type in + encoder (evari i) in begin match args, Json_config.get_tuple_style vc_configs with - | [], _ -> [%expr [[%e cstr]]] - | [arg], _ -> [%expr [[%e cstr]; ([%e arg_fname], [%e arg])]] - | _, `arr -> [%expr [[%e cstr]; ([%e arg_fname], `arr [%e elist ~loc args])]] + | [], _ -> List.return [%expr [[%e cstr]]] + | [arg], _ -> + let expr, is_optional = expr_of_arg ~is_field:true 0 arg in + if is_optional then + [ [%expr [[%e cstr]]]; [%expr [[%e cstr]; ([%e arg_fname], [%e expr])]] ] + else + [ [%expr [[%e cstr]; ([%e arg_fname], [%e expr])]] ] + + | _, `arr -> + let args = args |> List.mapi (fun i arg -> expr_of_arg i arg |> fst) in + List.return [%expr + [[%e cstr]; ([%e arg_fname], `arr [%e elist ~loc args])] + ] | _, `obj `default -> - let fields = - args |> List.mapi (fun i arg -> - let label = estring ~loc (tuple_index_to_field_name i) in - [%expr ([%e label], [%e arg])]) - in - [%expr ([%e elist ~loc @@ cstr :: fields])] + args + |> encoder_of_objtuple ~loc ~additional_field:cstr (expr_of_arg ~is_field:true) + |> List.return end - | `inline_record fields -> of_record_fields base_mangling_style fields + | `inline_record fields -> + of_record_fields base_mangling_style fields + |> List.return | `reused_inline_record { td_kind; td_configs; _ } -> let base_mangling_style = Json_config.(get_mangling_style_opt td_configs |? default_mangling_style) @@ -799,6 +935,7 @@ let gen_json_encoder : | _ -> failwith' "panic - type decl of reused inline record '%s' muts be record decl." vc_name in of_record_fields base_mangling_style fields + |> List.return end in let encoder_of_type_decl = @@ -917,7 +1054,7 @@ let gen_json_decoder_impl : let error_message = sprintf "mandatory field '%s' does not exist" json_field_name in [%expr List.assoc_opt [%e json_field] [%e param_e] - |> [%e opt_to_result [%expr ([%e estring ~loc error_message], path)]] + |> [%e opt_to_result ~loc [%expr ([%e estring ~loc error_message], path)]] >>= [%e decoder] (`f [%e json_field] :: path) ])) in @@ -947,8 +1084,7 @@ let gen_json_decoder_impl : |> Json_config.mangled `field_name base_mangling_style in let discriminator_fname_p = pstring ~loc discriminator_fname in - cstrs - |&> (fun ({ vc_name; vc_param; vc_configs; _ } as ctor) -> + cstrs |&> (fun ({ vc_name; vc_param; vc_configs; _ } as ctor) -> let (discriminator_value, base_mangling_style) = Json_config.get_mangled_name_of_discriminator ~inherited:base_mangling_style ctor in @@ -986,7 +1122,7 @@ let gen_json_decoder_impl : | `regular -> record_body ~gen_typcons:false ~inherited_codec td fields | `polymorphic -> failwith' "case '%s' with an %s cannot be used in a polymorphic variant" vc_name label in - cstr_p(fields + cstr_p (fields |> List.for_all (fun { rf_configs; _ } -> Json_config.get_nested_field_style rf_configs = `spreading) |> function | true -> [%pat? _] | false -> param_p @@ -1008,43 +1144,65 @@ let gen_json_decoder_impl : end | `tuple_like args -> let body = tuple_like_body args in - let decoders_of_args = - args |> List.map (fun va -> - let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in - get_decoder ~inherited_codec base_mangling_style self_ename va.va_type - ) + let arg_to_decoder va = + let base_mangling_style = Json_config.get_mangling_style_opt va.va_configs |? base_mangling_style in + get_decoder ~inherited_codec base_mangling_style self_ename va.va_type in + let is_optional = function + | { va_type = `direct ct + | `nested ({ td_kind = Alias_decl ct; _ }, _); _ } -> + Coretype.is_option ct + | _ -> false + in + let path_arg = [%expr `f [%e estring ~loc arg_fname] :: path ] in begin match Json_config.get_tuple_style vc_configs, args with | _, [] -> cstr_p [%pat? _], [%expr Ok [%e construct vc_name None]] | `obj `default, _ :: _ :: _ -> let bindings = - decoders_of_args |> List.mapi (fun i decoder -> + args |> List.mapi (fun i arg -> let label_name = tuple_index_to_field_name i in let label_name_e = estring ~loc label_name in - let error_message = sprintf "mandatory field '%s' does not exist" label_name in - pvari i, [%expr - List.assoc_opt [%e label_name_e] [%e param_e] - |> [%e opt_to_result [%expr ([%e estring ~loc error_message], path)]] - >>= ([%e decoder] (`f [%e label_name_e] :: path)) - ]) + 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 + pvari i, ( + if is_optional arg then + [%expr + [%e assoc_opt] + |> Option.value ~default:`null + |> [%e decoder]] + else + let error_message = sprintf "mandatory field '%s' does not exist" label_name in + [%expr + [%e assoc_opt] + |> [%e opt_to_result ~loc [%expr ([%e estring ~loc error_message], path)]] + >>= [%e decoder]] + )) in - cstr_p param_p, [%expr [%e bind_results bindings body]] + cstr_p param_p, bind_results bindings body + | _, [ va ] when is_optional va -> + cstr_p param_p, bind_results [ + pvari 0, [%expr + List.assoc_opt [%e estring ~loc arg_fname] [%e param_e] + |> Option.value ~default:`null + |> [%e arg_to_decoder va] [%e path_arg]] + ] [%expr + Ok ([%e construct vc_name (Some (evari 0))]) + ] | _, _ -> cstr_p param_p, ( - let path_arg = [%expr `f [%e estring ~loc arg_fname] :: path ] in - match decoders_of_args with - | [ decoder ] -> + match args with + | [ arg ] -> [ [%pat? Some arg], bind_results - [ pvari 0, [%expr [%e decoder] [%e path_arg] arg]] + [ pvari 0, [%expr [%e arg_to_decoder arg] [%e path_arg] arg]] body; ] | _ -> [ [%pat? Some (`arr [%p plist ~loc (List.mapi (fun i _ -> pvari i) args)])], bind_results - (List.mapi (fun i decoder -> pvari i, [%expr - [%e decoder] + (args |> List.mapi (fun i arg -> pvari i, [%expr + [%e arg_to_decoder arg] (`i [%e eint ~loc i] :: [%e path_arg]) - [%e evari i]]) decoders_of_args) + [%e evari i]])) body; [%pat? Some (`arr xs)], @@ -1502,7 +1660,7 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t = ?id in let rec fields_to_t ~self_name ~self_mangled_type_name base_mangling_style fields = - let field_to_t field = + fields |&> (fun field -> let field_name, base_mangling_style = Json_config.get_mangled_name_of_field ~inherited:base_mangling_style field in @@ -1525,8 +1683,7 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t = variant_to_t' ~self_name ~self_mangled_type_name base_mangling_style td_configs ctors |&> (fun (_, _, x) -> x) end - in - fields |&> field_to_t |> List.fold_left (fun result -> + ) |> List.fold_left (fun result -> List.fmap (fun fields -> result |&> List.rev_append fields) ) [ [] ] |&> List.rev diff --git a/src/lib_gen/unit_test/gen/output/dune b/src/lib_gen/unit_test/gen/output/dune index 82cef02..84020c7 100644 --- a/src/lib_gen/unit_test/gen/output/dune +++ b/src/lib_gen/unit_test/gen/output/dune @@ -378,3 +378,37 @@ (target ex16_docstr_gen.mli) (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) (mode (promote (until-clean)))) + +(rule + (target ex17_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex17_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex17_docstr_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex17_docstr_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) + +(rule + (target ex18_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex18_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex18_docstr_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (target ex18_docstr_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target}))) + (mode (promote (until-clean)))) diff --git a/src/lib_gen/unit_test/gen/output_embed_full_impl/dune b/src/lib_gen/unit_test/gen/output_embed_full_impl/dune index f47013c..1d6a51a 100644 --- a/src/lib_gen/unit_test/gen/output_embed_full_impl/dune +++ b/src/lib_gen/unit_test/gen/output_embed_full_impl/dune @@ -202,3 +202,21 @@ (target ex16_gen.mli) (action (with-stdout-to %{target} (run %{exe:../gen_embed_full_impl.exe} %{target} -gen-type-decl))) (mode (promote (until-clean)))) + +(rule + (target ex17_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen_embed_full_impl.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) +(rule + (target ex17_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen_embed_full_impl.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) + +(rule + (target ex18_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen_embed_full_impl.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) +(rule + (target ex18_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen_embed_full_impl.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) diff --git a/src/lib_gen/unit_test/gen/output_with_decl/dune b/src/lib_gen/unit_test/gen/output_with_decl/dune index ad0a874..d53230e 100644 --- a/src/lib_gen/unit_test/gen/output_with_decl/dune +++ b/src/lib_gen/unit_test/gen/output_with_decl/dune @@ -202,3 +202,21 @@ (target ex16_gen.mli) (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target} -gen-type-decl))) (mode (promote (until-clean)))) + +(rule + (target ex17_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) +(rule + (target ex17_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) + +(rule + (target ex18_gen.ml) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) +(rule + (target ex18_gen.mli) + (action (with-stdout-to %{target} (run %{exe:../gen.exe} %{target} -gen-type-decl))) + (mode (promote (until-clean)))) diff --git a/src/lib_gen/utils.ml b/src/lib_gen/utils.ml index 9b7d8ae..5b4859f 100644 --- a/src/lib_gen/utils.ml +++ b/src/lib_gen/utils.ml @@ -73,15 +73,6 @@ let to_rec_flag { td_kind; _ } = | Alias_decl _ -> Nonrecursive | Record_decl _ | Variant_decl _ -> Recursive -let nested_type_to_coretype' = function - | `direct ct -> ct, Coretype.is_option ct - | `nested ({ td_name; td_kind = Alias_decl ct; _ }, codec) -> - Coretype.mk_ident ~codec td_name, Coretype.is_option ct - | `nested ({ td_name; _ }, codec) -> - Coretype.mk_ident ~codec td_name, false - -let nested_type_to_coretype ty = nested_type_to_coretype' ty |> fst - let type_name_with_codec : ?codec:Coretype.codec -> string -> string = fun ?(codec=`default) name -> match codec with diff --git a/src/lib_gen_ts/config/bindoj_gen_ts_config.ml b/src/lib_gen_ts/config/bindoj_gen_ts_config.ml index 1755432..e330026 100644 --- a/src/lib_gen_ts/config/bindoj_gen_ts_config.ml +++ b/src/lib_gen_ts/config/bindoj_gen_ts_config.ml @@ -88,6 +88,7 @@ and ts_type_desc = [ and ts_property_signature = { tsps_modifiers : [ `readonly ] ignore_order_list; tsps_name : string; + tsps_optional : bool; tsps_type_desc : ts_type_desc; } diff --git a/src/lib_gen_ts/config/bindoj_gen_ts_config.mli b/src/lib_gen_ts/config/bindoj_gen_ts_config.mli index da65156..1843c94 100644 --- a/src/lib_gen_ts/config/bindoj_gen_ts_config.mli +++ b/src/lib_gen_ts/config/bindoj_gen_ts_config.mli @@ -89,6 +89,7 @@ and ts_type_desc = [ and ts_property_signature = { tsps_modifiers : [ `readonly ] ignore_order_list; tsps_name : string; + tsps_optional : bool; tsps_type_desc : ts_type_desc; } [@@deriving show, eq] diff --git a/src/lib_gen_ts/typescript_datatype.ml b/src/lib_gen_ts/typescript_datatype.ml index 23a58a8..847cfc5 100644 --- a/src/lib_gen_ts/typescript_datatype.ml +++ b/src/lib_gen_ts/typescript_datatype.ml @@ -40,11 +40,11 @@ let type_of_prim : Coretype.prim -> ts_type_desc = function | `string | `uchar -> `type_reference "string" | `bytes -> `type_reference "string" (* base64 *) -let type_of_coretype : +let property_type_of_coretype : ?definitive:bool -> self_json_name:string -> Json_config.json_mangling_style - -> coretype -> ts_type_desc = + -> coretype -> [`optional_property of bool]*ts_type_desc = fun ?(definitive = false) ~self_json_name base_mangling_style { ct_desc; ct_configs; _ } -> let base_mangling_style = Json_config.get_mangling_style_opt ct_configs @@ -61,6 +61,7 @@ let type_of_coretype : |> Json_config.get_name_opt |? id_name in `type_reference (Json_config.mangled `type_name base_mangling_style name) + | Option ((Option _) as t) -> go t | Option t -> `union [go t; `type_reference "null"; `type_reference "undefined"] | List t -> `array (go t) | Tuple ts -> @@ -68,11 +69,16 @@ let type_of_coretype : | `arr -> `tuple (ts |> List.map go) | `obj `default -> let fields = - ts |> List.mapi (fun i t -> { - tsps_modifiers = []; - tsps_name = Json_config.tuple_index_to_field_name i; - tsps_type_desc = go t - }) + ts |> List.mapi (fun i t -> + let tsps_optional, tsps_type_desc = + match go_property t with + | `optional t -> (true, t) + | `mandatory t -> (false, t) + in + { tsps_modifiers = []; + tsps_name = Json_config.tuple_index_to_field_name i; + tsps_optional; tsps_type_desc; + }) in `type_literal fields end @@ -87,6 +93,9 @@ let type_of_coretype : `union (cs |&> ( Json_config.get_mangled_name_of_string_enum_case ~inherited:base_mangling_style &> (fun c -> `literal_type (`string_literal c)))) + and go_property = function + | Option t -> `optional (go t) + | t -> `mandatory (go t) in let definitive = let classify = Coretype.(function @@ -98,9 +107,21 @@ let type_of_coretype : | _ -> .) in definitive || (classify ct_desc) in - if definitive then - ct_configs |> Configs.find_foreign_type_expr typescript |? go ct_desc - else go ct_desc + (if definitive then + ct_configs |> Configs.find_foreign_type_expr typescript + >? (fun t -> `mandatory t) + |? go_property ct_desc + else go_property ct_desc) + |> function + | `optional t -> (`optional_property true, t) + | `mandatory t -> (`optional_property false, t) + +let type_of_coretype = + fun ?definitive ~self_json_name base_mangling_style ct -> + property_type_of_coretype ?definitive ~self_json_name base_mangling_style ct + |> function + | `optional_property true, t -> `union [t; `type_reference "null"; `type_reference "undefined"] + | `optional_property false, t -> t let get_name_of_fwrt_desc : default:string -> Json_config.json_mangling_style -> ('ann_d, 'ann_f, 'ann_va, 'ann_k) fwrt_desc -> string * Json_config.json_mangling_style = fun ~default base_mangling_style desc -> @@ -114,12 +135,23 @@ let get_name_of_fwrt_desc : default:string -> Json_config.json_mangling_style -> | Fwrt_alias { fa_configs; _ } -> get_mangled_name `type_name fa_configs | Fwrt_constructor { fc_configs; _ } -> get_mangled_name `discriminator_value fc_configs -let type_of_nested env name = - let name, _ = - FwrtTypeEnv.lookup name env - |> get_name_of_fwrt_desc ~default:name Json_config.default_mangling_style - in - `type_reference name +let type_of_nested env name : ts_type_desc = + let codec = FwrtTypeEnv.lookup name env in + let name, _ = get_name_of_fwrt_desc ~default:name Json_config.default_mangling_style codec in + match codec.fd_kind with + | Fwrt_constructor _ -> failwith "Constructor cannot be nested." + | _ -> `type_reference name + +let property_type_of_nested ?definitive ~self_json_name env name : [`optional_property of bool] * ts_type_desc = + let codec = FwrtTypeEnv.lookup name env in + let name, mangling_style = get_name_of_fwrt_desc ~default:name Json_config.default_mangling_style codec in + match codec.fd_kind with + | Fwrt_constructor _ -> failwith "Constructor cannot be nested." + | Fwrt_alias { fa_type = { ct_desc = Option (Option _); _}; _ } -> + failwith "Nested option types cannot be fields." + | Fwrt_alias { fa_type = ct; _ } when Coretype.is_option ct -> + property_type_of_coretype ?definitive ~self_json_name mangling_style ct + | _ -> `optional_property false, `type_reference name type ('ann_d, 'ann_f, 'ann_va) ts_fwrt_decl = ('ann_d, 'ann_f, 'ann_va, unit*unit*ts_fwrt_constructor_kind_annot) fwrt_decl type fwrt_decl_of_ts = (ts_modifier list, [`readonly] list, [`readonly] list) ts_fwrt_decl @@ -153,6 +185,13 @@ let ts_fwrt_decl_of_type_decl : ); } decl +let add_kind_field kind_field = function + | `type_literal fields -> `type_literal (kind_field :: fields) + | `intersection ((`type_literal fields) :: typs) -> + `intersection (`type_literal (kind_field :: fields) :: typs) + | `intersection typs -> `intersection (`type_literal [ kind_field ] :: typs) + | desc -> `intersection [ `type_literal [ kind_field ]; desc] + let rec ts_ast_of_fwrt_decl : fwrt_decl_of_ts -> ts_ast = fun fwrt_decl -> let type_alias_decl = @@ -172,9 +211,8 @@ and ts_type_alias_decl_of_fwrt_decl' : assert (name = fd_name); let (mangled_name, base_mangling_style) = get_name_of_fwrt_desc ~default:name base_mangling_style desc in let self_json_name = self_json_name |? mangled_name in - let ts_props_and_nested_types_of_fields base_mangling_style fields: ts_property_signature ignore_order_list * _ ignore_order_list = - List.fold_right (fun ({ ff_name; ff_type - ; ff_annot; ff_configs; _}) (members, nested) -> + let ts_props_and_nested_types_of_fields base_mangling_style fields: ts_property_signature ignore_order_list * ts_type_desc ignore_order_list = + List.fold_right (fun ({ ff_name; ff_type; ff_annot; ff_configs; _}) (members, nested) -> let base_mangling_style = Json_config.get_mangling_style_opt ff_configs |? base_mangling_style in let nested_style = Json_config.get_nested_field_style ff_configs in match nested_style, ff_type with @@ -182,9 +220,9 @@ and ts_type_alias_decl_of_fwrt_decl' : | `spreading, `nested (name, _) -> members, type_of_nested env name :: nested | `nested, _ -> - let tsps_type_desc = match ff_type with - | `direct ct -> type_of_coretype ~self_json_name base_mangling_style ct - | `nested (name, _) -> type_of_nested env name + let (`optional_property tsps_optional), tsps_type_desc = match ff_type with + | `direct ct -> property_type_of_coretype ~self_json_name base_mangling_style ct + | `nested (name, _) -> property_type_of_nested ~self_json_name env name in let field_name = Json_config.( ff_configs @@ -194,18 +232,19 @@ and ts_type_alias_decl_of_fwrt_decl' : let member = { tsps_modifiers = ff_annot; tsps_name = field_name; + tsps_optional; tsps_type_desc; } in member :: members, nested ) fields ([], []) in let when_not_empty f = function | [] -> None | xs -> Some (f xs) in - let desc = + let desc: ts_type_desc = match fd_kind with | Fwrt_object { fo_fields; fo_children; fo_configs; fo_annot=() } -> let members, nested = ts_props_and_nested_types_of_fields base_mangling_style fo_fields in let discriminator_name = fo_configs |> Ts_config.get_variant_discriminator in - let children = + let children: ts_type_desc ignore_order_list = fo_children |&> fun child -> let { tsa_name; tsa_type_desc; _; } = ts_type_alias_decl_of_fwrt_decl' ~self_json_name ~base_mangling_style (child, env) in @@ -216,12 +255,9 @@ and ts_type_alias_decl_of_fwrt_decl' : let kind_field = { tsps_modifiers = []; tsps_name = discriminator_name; + tsps_optional = false; tsps_type_desc = `literal_type (`string_literal discriminator_value); } in - begin match tsa_type_desc with - | `type_literal fields -> `type_literal (kind_field :: fields) - | `intersection typs -> `intersection (`type_literal [ kind_field ] :: typs) - | _ -> `intersection [ `type_literal [ kind_field ]; tsa_type_desc] - end + add_kind_field kind_field tsa_type_desc in ([ when_not_empty (fun x -> `type_literal x) members; when_not_empty (fun x -> `union x) children; @@ -246,45 +282,51 @@ and ts_type_alias_decl_of_fwrt_decl' : in let arg_name = Json_config.(get_name_of_variant_arg default_name_of_variant_arg fc_configs) in let members, nested = - let tmp, nested = + let members, nested = ts_props_and_nested_types_of_fields base_mangling_style fc_fields in - let type_of_variant_argument base_mangling_style arg = - let base_mangling_style = Json_config.get_mangling_style_opt arg.fva_configs |? base_mangling_style in - match arg.fva_type with - | `direct ct -> type_of_coretype ~self_json_name base_mangling_style ct - | `nested (name, _) -> type_of_nested env name + let property_type_of_variant_argument, type_of_variant_argument = + let type_of_variant_argument' type_of_coretype type_of_nested base_mangling_style arg = + let base_mangling_style = Json_config.get_mangling_style_opt arg.fva_configs |? base_mangling_style in + match arg.fva_type with + | `direct ct -> type_of_coretype ?definitive:None ~self_json_name base_mangling_style ct + | `nested (name, _) -> type_of_nested env name + in + type_of_variant_argument' property_type_of_coretype (property_type_of_nested ?definitive:None ~self_json_name), + type_of_variant_argument' type_of_coretype type_of_nested in match fc_args, Json_config.get_tuple_style fc_configs with - | [], _ -> tmp, nested + | [], _ -> members, nested | [arg], _ when Json_config.get_nested_field_style arg.fva_configs = `spreading -> begin match arg.fva_type with | `direct _ -> failwith "non-nested argument/field cannot be spread." | `nested (name, _) -> - tmp, (type_of_nested env name :: nested) + members, (type_of_nested env name :: nested) end | [arg], _ -> let base_mangling_style = Json_config.get_mangling_style_opt arg.fva_configs |? base_mangling_style in + 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 = arg_name; - tsps_type_desc = type_of_variant_argument base_mangling_style arg } :: tmp, nested + tsps_optional; tsps_type_desc } :: members, nested | args, `arr -> let desc = `tuple (args |&> type_of_variant_argument base_mangling_style) in { tsps_modifiers = args |&>> (fun { fva_annot; _ } -> fva_annot); tsps_name = arg_name; - tsps_type_desc = desc } :: tmp, nested + tsps_optional = false; + tsps_type_desc = desc } :: members, nested | args, `obj `default -> let fields = 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_type_desc = type_of_variant_argument base_mangling_style arg - }) + tsps_optional; tsps_type_desc }) in - tmp @ fields, nested + members @ fields, nested in match members, nested with | ps, [] -> `type_literal ps @@ -325,15 +367,12 @@ and ts_func_decl_of_fwrt_decl : fwrt_decl_of_ts -> ts_func_decl = let kind_field = { tsps_modifiers = []; tsps_name = discriminator_name; + tsps_optional = false; tsps_type_desc = `literal_type (`string_literal discriminator_value); } in - let desc = - match decl.tsa_type_desc with - | `type_literal fields -> `type_literal (kind_field :: fields) - | `intersection typs -> `intersection (`type_literal [ kind_field ] :: typs) - | desc -> `intersection [ `type_literal [ kind_field]; desc] - in + let desc = add_kind_field kind_field decl.tsa_type_desc in { tsps_modifiers = []; tsps_name = discriminator_value; + tsps_optional = false; tsps_type_desc = (`func_type { tsft_parameters = [{ tsp_name = var_v; tsp_type_desc = desc }]; @@ -572,7 +611,7 @@ and rope_of_ts_type_desc : ts_type_desc -> Rope.t = |> concat_str ", " |> between "<" ">") | `type_literal members -> - (members |&> fun { tsps_modifiers; tsps_name; tsps_type_desc; } -> + (members |&> fun { tsps_modifiers; tsps_name; tsps_optional; tsps_type_desc; } -> let readonly = if List.exists (( = ) `readonly) tsps_modifiers then rope "readonly " @@ -583,9 +622,10 @@ and rope_of_ts_type_desc : ts_type_desc -> Rope.t = tsps_name else sprintf "\"%s\"" tsps_name) - |> rope in + in + let optional = if tsps_optional then "?" else "" in let type_desc = rope_of_ts_type_desc tsps_type_desc in - readonly ++ (name +@ " : ") ++ type_desc) + readonly +@ name +@ optional +@ " : " ++ type_desc) |> comma_separated_list |> between "{ " " }" | `literal_type (`numeric_literal f) -> diff --git a/src/lib_gen_ts/unit_test/lib_gen_ts_test.ml b/src/lib_gen_ts/unit_test/lib_gen_ts_test.ml index c74a245..13e40fe 100644 --- a/src/lib_gen_ts/unit_test/lib_gen_ts_test.ml +++ b/src/lib_gen_ts/unit_test/lib_gen_ts_test.ml @@ -323,13 +323,19 @@ module Code = struct |> Rope.to_string); test_case' "rope_of_ts_type_desc" - ("{ " ^ var_x ^ " : " ^ number ^ " , " ^ var_y ^ " : " ^ number ^ " }" ) + ("{ " ^ var_x ^ " : " ^ number ^ " , " ^ var_y ^ " : " ^ number ^ " , " ^ var_z ^ "? :" ^ number ^ " }" ) (`type_literal [ { tsps_modifiers = []; tsps_name = var_x; + tsps_optional = false; tsps_type_desc = `type_reference number; }; { tsps_modifiers = []; tsps_name = var_y; + tsps_optional = false; + tsps_type_desc = `type_reference number; }; + { tsps_modifiers = []; + tsps_name = var_z; + tsps_optional = true; tsps_type_desc = `type_reference number; }; ] |> rope_of_ts_type_desc @@ -447,7 +453,7 @@ module Code = struct let statement_case = [ test_case' "rope_of_ts_statement" - ("type " ^ type_A ^ " = { " ^ var_x ^ ": " ^ number ^ ", " ^ var_y ^ ": " ^ string ^ " }") + ("type " ^ type_A ^ " = { " ^ var_x ^ ": " ^ number ^ ", " ^ var_y ^ ": " ^ string ^ ", " ^ var_z ^ "?: " ^ string ^ " }") (`type_alias_declaration { tsa_modifiers = []; tsa_name = type_A; @@ -455,9 +461,15 @@ module Code = struct tsa_type_desc = `type_literal [ { tsps_modifiers = []; tsps_name = var_x; + tsps_optional = false; tsps_type_desc = `type_reference number; }; { tsps_modifiers = []; tsps_name = var_y; + tsps_optional = false; + tsps_type_desc = `type_reference string; }; + { tsps_modifiers = []; + tsps_name = var_z; + tsps_optional = true; tsps_type_desc = `type_reference string; }; ]; } diff --git a/src/lib_test_common/of_json_error_examples.ml b/src/lib_test_common/of_json_error_examples.ml index a9ebf15..9fdbc45 100644 --- a/src/lib_test_common/of_json_error_examples.ml +++ b/src/lib_test_common/of_json_error_examples.ml @@ -273,7 +273,6 @@ module SampleEx05 : SampleGenerated = struct "incorrect list length in nested field", `obj [ - "option", `num 42.; "list", `arr [ ]; "tuple", `arr [ `num 4.; `num 2. ]; "objtuple", `obj ["_0", `num 4.; "_1", `num 2.]; @@ -532,6 +531,56 @@ module SampleEx16 : SampleGenerated = struct ] end +module SampleEx17 : SampleGenerated = struct + include Ex17 + let name = "SampleEx17" + let expected_json_shape_explanation = Typedesc_examples.Ex17.expected_json_shape_explanation + let samples = [ + "not integer", `num 12.3, (not_integer 12.3, []); + "type mismatch", `str "test", (type_mismatch "int" "string", []); + ] +end + +module SampleEx18 : SampleGenerated = struct + include Ex18 + let name = "SampleEx18" + let expected_json_shape_explanation = Typedesc_examples.Ex18.expected_json_shape_explanation + let samples = [ + "discriminator not found", `obj [], (discriminator_not_found "tag", []); + "discriminator not string", `obj [ ("tag", `null)], (discriminator_not_string "null", [ `f "tag" ]); + + "invalid constructor", ctor0 ~discriminator:"tag" "Tuple_like", + ("given discriminator field value 'Tuple_like' is not one of [ 'tuple-like', 'tuple-like-alias', 'tuple-like-obj', 'tuple-like-spreading', 'inline-record', 'inline-record-spreading', 'reused-inline-record' ]", [ `f "tag" ]); + + "type mismatch", `obj [ ("tag", `str "tuple-like"); ("value", `obj []); ], + (type_mismatch "int" "object", [ `f "value" ]); + + "not integer", `obj [ ("tag", `str "tuple-like"); ("value", `num 12.3); ], + (not_integer 12.3, [ `f "value" ]); + + "type mismatch", `obj [ ("tag", `str "tuple-like-alias"); ("value", `arr [ `null; `num 1. ]); ], + (type_mismatch "int" "array", [ `f "value" ]); + + "not integer", `obj [ ("tag", `str "tuple-like-alias"); ("value", `num 12.3); ], + (not_integer 12.3, [ `f "value" ]); + + "type mismatch", `obj [ ("tag", `str "tuple-like-spreading"); ("xOpt", `bool false) ], + (type_mismatch "int" "bool", [ `f "xOpt" ]); + + "type mismatch", `obj [ ("tag", `str "tuple-like-spreading"); ("yOpt", `str "foobar") ], + (type_mismatch "int" "string", [ `f "yOpt" ]); + + "type mismatch", `obj [ ("tag", `str "inline-record"); ("yOpt", `str "foobar") ], + (type_mismatch "int" "string", [ `f "yOpt" ]); + + "type mismatch", `obj [ ("tag", `str "inline-record-spreading"); ("yOpt", `str "foobar") ], + (type_mismatch "int" "string", [ `f "yOpt" ]); + + "type mismatch", `obj [ ("tag", `str "reused-inline-record"); ("yOpt", `str "foobar") ], + (type_mismatch "int" "string", [ `f "yOpt" ]); + ] +end + let ttd_name (type t) ((module Td) : t Typed_type_desc.typed_type_decl) = Td.decl.td_name @@ -727,6 +776,8 @@ let all_generated : (module SampleGenerated) list = [ (module SampleEx14); (module SampleEx15); (module SampleEx16); + (module SampleEx17); + (module SampleEx18); ] let all : (module Sample) list = [ @@ -749,6 +800,8 @@ let all : (module Sample) list = [ (module SampleEx14); (module SampleEx15); (module SampleEx16); + (module SampleEx17); + (module SampleEx18); (module SampleIdentInt_Refl); (module SampleIdentInt_Coretypes); (module SampleIdentIntOption_Coretypes); diff --git a/src/lib_test_common/typedesc_examples/all.ml b/src/lib_test_common/typedesc_examples/all.ml index d9320bb..70428b0 100644 --- a/src/lib_test_common/typedesc_examples/all.ml +++ b/src/lib_test_common/typedesc_examples/all.ml @@ -58,4 +58,6 @@ let all : (string * (module T)) list = [ "ex14", (module Ex14); "ex15", (module Ex15); "ex16", (module Ex16); + "ex17", (module Ex17); + "ex18", (module Ex18); ] diff --git a/src/lib_test_common/typedesc_examples/ex01.ml b/src/lib_test_common/typedesc_examples/ex01.ml index 5e18620..a16657e 100644 --- a/src/lib_test_common/typedesc_examples/ex01.ml +++ b/src/lib_test_common/typedesc_examples/ex01.ml @@ -53,12 +53,9 @@ let ts_ast : ts_ast option = tsa_type_parameters = []; tsa_type_desc = `type_literal - [ { tsps_modifiers = []; - tsps_name = "admissionYear"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; ]; } ] + Util.Ts_ast.[ + property "admissionYear" (`type_reference "number"); + property "name" (`type_reference "string") ]; } ] let expected_json_shape_explanation = Some ( diff --git a/src/lib_test_common/typedesc_examples/ex01_inherited_mangling.ml b/src/lib_test_common/typedesc_examples/ex01_inherited_mangling.ml index 3292469..4bafe56 100644 --- a/src/lib_test_common/typedesc_examples/ex01_inherited_mangling.ml +++ b/src/lib_test_common/typedesc_examples/ex01_inherited_mangling.ml @@ -76,18 +76,13 @@ let ts_ast : ts_ast option = tsa_type_parameters = []; tsa_type_desc = `type_literal - [ { tsps_modifiers = []; - tsps_name = "admission_year"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; - { tsps_modifiers = []; - tsps_name = "caseValue"; - tsps_type_desc = `union [ + Util.Ts_ast.[ + property "admission_year" (`type_reference "number"); + property "name" (`type_reference "string"); + property "caseValue" (`union [ `literal_type (`string_literal "Case-at0"); `literal_type (`string_literal "case_at1"); - ]; }; + ]); ]; } ] let expected_json_shape_explanation = diff --git a/src/lib_test_common/typedesc_examples/ex02.ml b/src/lib_test_common/typedesc_examples/ex02.ml index b1accdf..00fc261 100644 --- a/src/lib_test_common/typedesc_examples/ex02.ml +++ b/src/lib_test_common/typedesc_examples/ex02.ml @@ -87,44 +87,29 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = let ts_ast : ts_ast option = let discriminator = "kind" in let arg_fname = "arg" in + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let anonymous = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "anonymous"); } ] in + [ discriminator_value "anonymous"; ] in let with_id = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "with-id"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "number"; }; ] in + [ discriminator_value "with-id"; + Util.Ts_ast.property arg_fname (`type_reference "number") ] in let student = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student"); }; - { tsps_modifiers = []; - tsps_name = "studentId"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; } ] in + Util.Ts_ast.[ + discriminator_value "student"; + property "studentId" (`type_reference "number"); + property "name" (`type_reference "string") ] in let teacher = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "teacher"); }; - { tsps_modifiers = []; - tsps_name = "facultyId"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; - { tsps_modifiers = []; - tsps_name = "department"; - tsps_type_desc = `type_reference "string"; } ] in + Util.Ts_ast.[ + discriminator_value "teacher"; + property "facultyId" (`type_reference "number"); + property "name" (`type_reference "string"); + property "department" (`type_reference "string") ] in let person = [ "With_id", with_id; "Teacher", teacher; @@ -156,7 +141,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "anonymous")))]; `object_of [`mandatory_field ("kind", (`exactly (`str "with-id"))); - `mandatory_field ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "student"))); `mandatory_field ("studentId", `integral); diff --git a/src/lib_test_common/typedesc_examples/ex02_inherited_mangling.ml b/src/lib_test_common/typedesc_examples/ex02_inherited_mangling.ml index b8aa10c..1278f33 100644 --- a/src/lib_test_common/typedesc_examples/ex02_inherited_mangling.ml +++ b/src/lib_test_common/typedesc_examples/ex02_inherited_mangling.ml @@ -135,52 +135,35 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = let ts_ast : ts_ast option = let discriminator = "kind" in let arg_fname = "arg" in + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let anonymous = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "Anonymous"); } ] in + [ discriminator_value "Anonymous" ] in let with_id = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "With_id"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "number"; }; ] in + [ discriminator_value "With_id"; + Util.Ts_ast.property arg_fname (`type_reference "number") ] in let student = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student"); }; - { tsps_modifiers = []; - tsps_name = "caseValue"; - tsps_type_desc = `union [ + Util.Ts_ast.[ + discriminator_value "student"; + property "caseValue" (`union [ `literal_type (`string_literal "Case_at0"); `literal_type (`string_literal "case-at1"); - ]; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; - { tsps_modifiers = []; - tsps_name = "student_id"; - tsps_type_desc = `type_reference "number"; }; + ]); + property "name" (`type_reference "string"); + property "student_id" (`type_reference "number"); ] in let teacher = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "Teacher"); }; - { tsps_modifiers = []; - tsps_name = "department"; - tsps_type_desc = `type_reference "string"; }; - { tsps_modifiers = []; - tsps_name = "facultyId"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; + Util.Ts_ast.[ + discriminator_value "Teacher"; + property "department" (`type_reference "string"); + property "facultyId" (`type_reference "number"); + property "name" (`type_reference "string"); ] in let person = [ "With_id", with_id; @@ -213,7 +196,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "Anonymous")))]; `object_of [`mandatory_field ("kind", (`exactly (`str "With_id"))); - `mandatory_field ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "student"))); `mandatory_field ("student_id", `integral); diff --git a/src/lib_test_common/typedesc_examples/ex02_no_mangling.ml b/src/lib_test_common/typedesc_examples/ex02_no_mangling.ml index d690dba..ccb2182 100644 --- a/src/lib_test_common/typedesc_examples/ex02_no_mangling.ml +++ b/src/lib_test_common/typedesc_examples/ex02_no_mangling.ml @@ -101,44 +101,29 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = let ts_ast : ts_ast option = let discriminator = "kind" in let arg_fname = "arg" in + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let anonymous = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "Anonymous"); } ] in + [ discriminator_value "Anonymous" ] in let with_id = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "With_id"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "number"; }; ] in + [ discriminator_value "With_id"; + Util.Ts_ast.property arg_fname (`type_reference "number") ] in let student = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "Student"); }; - { tsps_modifiers = []; - tsps_name = "student_id"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; } ] in + Util.Ts_ast.[ + discriminator_value "Student"; + property "student_id" (`type_reference "number"); + property "name" (`type_reference "string") ] in let teacher = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "Teacher"); }; - { tsps_modifiers = []; - tsps_name = "faculty_id"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; - { tsps_modifiers = []; - tsps_name = "department"; - tsps_type_desc = `type_reference "string"; } ] in + Util.Ts_ast.[ + discriminator_value "Teacher"; + property "faculty_id" (`type_reference "number"); + property"name" (`type_reference "string"); + property"department" (`type_reference "string") ] in let person = [ "With_id", with_id; "Teacher", teacher; @@ -170,7 +155,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "Anonymous")))]; `object_of [`mandatory_field ("kind", (`exactly (`str "With_id"))); - `mandatory_field ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "Student"))); `mandatory_field ("student_id", `integral); diff --git a/src/lib_test_common/typedesc_examples/ex02_reused.ml b/src/lib_test_common/typedesc_examples/ex02_reused.ml index b094e79..a3fb804 100644 --- a/src/lib_test_common/typedesc_examples/ex02_reused.ml +++ b/src/lib_test_common/typedesc_examples/ex02_reused.ml @@ -104,38 +104,26 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = let ts_ast : ts_ast option = let discriminator = "kind" in let arg_fname = "arg" in + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let anonymous = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "anonymous"); } ] in + [ discriminator_value "anonymous"; ] in let with_id = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "with-id"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "number"; }; ] in + [ discriminator_value "with-id"; + Util.Ts_ast.property arg_fname (`type_reference "number") ] in let student = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student"); }; - { tsps_modifiers = []; - tsps_name = "studentId"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; } ] in + Util.Ts_ast.[ + discriminator_value "student"; + property "studentId" (`type_reference "number"); + property "name" (`type_reference "string") ] in let teacher = `intersection - [`type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "teacher"); }]; - `type_reference "Teacher" - ] in + [`type_literal [ discriminator_value "teacher" ]; + `type_reference "Teacher" ] in let person = [ "With_id", with_id; "Teacher", teacher; diff --git a/src/lib_test_common/typedesc_examples/ex03.ml b/src/lib_test_common/typedesc_examples/ex03.ml index a794a7f..af69d6c 100644 --- a/src/lib_test_common/typedesc_examples/ex03.ml +++ b/src/lib_test_common/typedesc_examples/ex03.ml @@ -60,17 +60,13 @@ let ts_ast : ts_ast option = let arg_fname = "arg" in let int_nil = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "intnil"); } ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "intnil")) ] in let int_cons = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "intcons"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `tuple [ `type_reference "number"; `type_reference "IntList"; ]; } ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "intcons")); + property arg_fname (`tuple [ `type_reference "number"; `type_reference "IntList"; ]) ] in let cstrs = ["IntNil", int_nil; "IntCons", int_cons] in let options : Util.Ts_ast.options = { discriminator; diff --git a/src/lib_test_common/typedesc_examples/ex03_objtuple.ml b/src/lib_test_common/typedesc_examples/ex03_objtuple.ml index 3393090..fe65f40 100644 --- a/src/lib_test_common/typedesc_examples/ex03_objtuple.ml +++ b/src/lib_test_common/typedesc_examples/ex03_objtuple.ml @@ -68,20 +68,14 @@ let ts_ast : ts_ast option = let discriminator = "kind" in let int_nil = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "intnil"); } ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "intnil"))] in let int_cons = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "intcons"); }; - { tsps_modifiers = []; - tsps_name = "_0"; - tsps_type_desc = `type_reference "number" }; - { tsps_modifiers = []; - tsps_name = "_1"; - tsps_type_desc = `type_reference mangled_json_name } ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "intcons")); + property "_0" (`type_reference "number"); + property "_1" (`type_reference mangled_json_name) ] in let cstrs = ["IntNil", int_nil; "IntCons", int_cons] in let options : Util.Ts_ast.options = { discriminator; diff --git a/src/lib_test_common/typedesc_examples/ex04.ml b/src/lib_test_common/typedesc_examples/ex04.ml index 708ad0d..1eb6c86 100644 --- a/src/lib_test_common/typedesc_examples/ex04.ml +++ b/src/lib_test_common/typedesc_examples/ex04.ml @@ -59,27 +59,20 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = let ts_ast : ts_ast option = let discriminator = "kind" in let arg_fname = "arg" in + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let foo0 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "foo0"); } ] in + [ discriminator_value "foo0" ] in let foo1 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "foo1"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "number"; } ] in + [ discriminator_value "foo1"; + Util.Ts_ast.property arg_fname (`type_reference "number") ] in let foo2 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "foo2"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `tuple [`type_reference "number"; `type_reference "number"]; } ] in + [ discriminator_value "foo2"; + Util.Ts_ast.property arg_fname (`tuple [`type_reference "number"; `type_reference "number"]) ] in let foos = ["Foo0", foo0; "Foo1", foo1; "Foo2", foo2] in let options : Util.Ts_ast.options = { discriminator; @@ -106,7 +99,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "foo0")))]; `object_of [`mandatory_field ("kind", (`exactly (`str "foo1"))); - `mandatory_field ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "foo2"))); `mandatory_field ("arg", (`tuple_of [`integral; `integral]))]])))) diff --git a/src/lib_test_common/typedesc_examples/ex05.ml b/src/lib_test_common/typedesc_examples/ex05.ml index 0db10e1..f46df1c 100644 --- a/src/lib_test_common/typedesc_examples/ex05.ml +++ b/src/lib_test_common/typedesc_examples/ex05.ml @@ -42,40 +42,40 @@ let decl : type_decl = record_field "objtuple" cty_int_obt; - record_field "nested" (Coretype.( - mk_tuple [ + record_field "nested" ( + Coretype.mk_tuple [ cty_int_opt.ct_desc; cty_int_lst.ct_desc; cty_int_tpl.ct_desc; ] - )); + ); record_field "map" cty_int_map; ] let decl_with_docstr : type_decl = record_decl "complex_types" [ - record_field "option" (Coretype.(mk_option (prim `int))) + record_field "option" cty_int_opt ~doc:(`docstr "int option"); - record_field "list" (Coretype.(mk_list (prim `int))) + record_field "list" cty_int_lst ~doc:(`docstr "int list"); - record_field "tuple" (Coretype.(mk_tuple [prim `int; prim `int])) + record_field "tuple" cty_int_tpl ~doc:(`docstr "(int * int)"); - record_field "objtuple" (Coretype.(mk_tuple ~configs:tuple_configs [prim `int; prim `int])) + record_field "objtuple" cty_int_obt ~doc:(`docstr "(int * int) (as object)"); - record_field "nested" (Coretype.( - mk_tuple [ - option (prim `int); - list (prim `int); - tuple [prim `int; prim `int]; + record_field "nested" ( + Coretype.mk_tuple [ + cty_int_opt.ct_desc; + cty_int_lst.ct_desc; + cty_int_tpl.ct_desc; ] - )) ~doc:(`docstr "(int option * int list * (int * int))"); + ) ~doc:(`docstr "(int option * int list * (int * int))"); - record_field "map" (Coretype.(mk_map `string (prim `int))) + record_field "map" cty_int_map ~doc:(`docstr "map"); ] ~doc:(`docstr "collection of complex types") @@ -100,26 +100,55 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = ] ) -let ts_ast : ts_ast option = None +let ts_ast : ts_ast option = + Some [ + `type_alias_declaration + { tsa_modifiers = [`export]; + tsa_name = "ComplexTypes"; + tsa_type_parameters = []; + tsa_type_desc = + let ts_number = `type_reference "number" in + `type_literal + Util.Ts_ast.[ + property ~optional:true "option" ts_number; + property "list" (`array ts_number); + property "tuple" (`tuple [ ts_number; ts_number ]); + property "objtuple" (`type_literal [ + property "_0" ts_number; + property "_1" ts_number; + ]); + property "nested" (`tuple + [ `union [ts_number; `type_reference "null"; `type_reference "undefined" ]; + `array ts_number; + `tuple [ ts_number; ts_number ]; + ]); + property "map" (`record (`type_reference "string", ts_number)); + + ] + } + ] let expected_json_shape_explanation = Some ( `with_warning ("not considering any config if exists", (`named - ("ComplexTypes", - (`object_of + ("ComplexTypes", + (`object_of [`optional_field ("option", `integral); `mandatory_field ("list", (`array_of `integral)); `mandatory_field ("tuple", (`tuple_of [`integral; `integral])); `mandatory_field - ("objtuple", (`tuple_of [`integral; `integral])); + ("objtuple", + (`object_of + [`mandatory_field ("_0", `integral); + `mandatory_field ("_1", `integral)])); `mandatory_field ("nested", (`tuple_of - [`nullable `integral; - `array_of `integral; - `tuple_of [`integral; `integral]])); + [`nullable `integral; + `array_of `integral; + `tuple_of [`integral; `integral]])); `mandatory_field ("map", (`record_of `integral))])))) ) diff --git a/src/lib_test_common/typedesc_examples/ex06.ml b/src/lib_test_common/typedesc_examples/ex06.ml index bfb11b9..74816c0 100644 --- a/src/lib_test_common/typedesc_examples/ex06.ml +++ b/src/lib_test_common/typedesc_examples/ex06.ml @@ -46,20 +46,16 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = ) let ts_ast : ts_ast option = - let make_case tsps_name tsps_type_desc = - { tsps_modifiers = []; - tsps_name; - tsps_type_desc; } in let lit = - `type_literal [ - make_case "unit" (`literal_type (`numeric_literal 1.)); - make_case "bool" (`type_reference "boolean"); - make_case "int" (`type_reference "number"); - make_case "float" (`type_reference "number"); - make_case "string" (`type_reference "string"); - make_case "uchar" (`type_reference "string"); - make_case "byte" (`type_reference "number"); - make_case "bytes" (`type_reference "string"); + `type_literal Util.Ts_ast.[ + property "unit" (`literal_type (`numeric_literal 1.)); + property "bool" (`type_reference "boolean"); + property "int" (`type_reference "number"); + property "float" (`type_reference "number"); + property "string" (`type_reference "string"); + property "uchar" (`type_reference "string"); + property "byte" (`type_reference "number"); + property "bytes" (`type_reference "string"); ] in [ `type_alias_declaration { tsa_modifiers = [`export]; diff --git a/src/lib_test_common/typedesc_examples/ex07.ml b/src/lib_test_common/typedesc_examples/ex07.ml index 47465fa..6efcac5 100644 --- a/src/lib_test_common/typedesc_examples/ex07.ml +++ b/src/lib_test_common/typedesc_examples/ex07.ml @@ -95,23 +95,15 @@ let ts_ast : ts_ast option = let discriminator = "tag" in let case1 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "case1'"); }; - { tsps_modifiers = []; - tsps_name = "value"; - tsps_type_desc = `type_reference "number"; }; ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "case1'")); + property "value" (`type_reference "number"); ] in let case2 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "case2'"); }; - { tsps_modifiers = []; - tsps_name = "x'"; - tsps_type_desc = `type_reference "number"; }; - { tsps_modifiers = []; - tsps_name = "y'"; - tsps_type_desc = `type_reference "number"; }; ] in + Util.Ts_ast.[ + property discriminator (`literal_type (`string_literal "case2'")); + property "x'" (`type_reference "number"); + property "y'" (`type_reference "number"); ] in let customized_union = [ "Case1'", case1; "Case2'", case2; @@ -139,7 +131,7 @@ let expected_json_shape_explanation = (`anyone_of [`object_of [`mandatory_field ("tag", (`exactly (`str "case1'"))); - `mandatory_field ("value", (`tuple_of [`integral]))]; + `mandatory_field ("value", `integral)]; `object_of [`mandatory_field ("tag", (`exactly (`str "case2'"))); `mandatory_field ("x'", `integral); diff --git a/src/lib_test_common/typedesc_examples/ex08.ml b/src/lib_test_common/typedesc_examples/ex08.ml index 802e0df..4cb4675 100644 --- a/src/lib_test_common/typedesc_examples/ex08.ml +++ b/src/lib_test_common/typedesc_examples/ex08.ml @@ -51,13 +51,9 @@ let ts_ast : ts_ast option = Some [ tsa_name = "NamedJson"; tsa_type_parameters = []; tsa_type_desc = - `type_literal [ - { tsps_modifiers = []; - tsps_name = "json"; - tsps_type_desc = `type_reference "json_value"; }; - { tsps_modifiers = []; - tsps_name = "name"; - tsps_type_desc = `type_reference "string"; }; + `type_literal Util.Ts_ast.[ + property "json" (`type_reference "json_value"); + property "name" (`type_reference "string"); ];}; ] diff --git a/src/lib_test_common/typedesc_examples/ex09.ml b/src/lib_test_common/typedesc_examples/ex09.ml index 329363a..507deb3 100644 --- a/src/lib_test_common/typedesc_examples/ex09.ml +++ b/src/lib_test_common/typedesc_examples/ex09.ml @@ -48,9 +48,7 @@ let ts_ast : ts_ast option = Some [ tsa_type_parameters = []; tsa_type_desc = `type_literal [ - { tsps_modifiers = []; - tsps_name = "value"; - tsps_type_desc = `type_reference "number"; }; + Util.Ts_ast.property "value" (`type_reference "number") ];}; ] diff --git a/src/lib_test_common/typedesc_examples/ex10.ml b/src/lib_test_common/typedesc_examples/ex10.ml index 1f4a36e..8a8f508 100644 --- a/src/lib_test_common/typedesc_examples/ex10.ml +++ b/src/lib_test_common/typedesc_examples/ex10.ml @@ -44,7 +44,18 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = field "y_opt" cty_int_opt; ] ) -let ts_ast : ts_ast option = None +let ts_ast : ts_ast option = + Some + [ `type_alias_declaration + { tsa_modifiers = [`export]; + tsa_name = "XyOpt"; + tsa_type_parameters = []; + tsa_type_desc = + `type_literal + Util.Ts_ast.[ + property ~optional:true "xOpt" (`type_reference "number"); + property ~optional:true "yOpt" (`type_reference "number"); + ]}] let expected_json_shape_explanation = Some ( diff --git a/src/lib_test_common/typedesc_examples/ex13.ml b/src/lib_test_common/typedesc_examples/ex13.ml index 823647f..16aa1a1 100644 --- a/src/lib_test_common/typedesc_examples/ex13.ml +++ b/src/lib_test_common/typedesc_examples/ex13.ml @@ -55,12 +55,11 @@ let ts_ast : ts_ast option = tsa_type_parameters = []; tsa_type_desc = `type_literal - [ { tsps_modifiers = []; - tsps_name = "student1"; - tsps_type_desc = `type_reference "Student"; }; - { tsps_modifiers = []; - tsps_name = "student2"; - tsps_type_desc = `type_reference "Student"; }; ]; } ] + Util.Ts_ast.[ + property "student1" (`type_reference "Student"); + property "student2" (`type_reference "Student"); + ]; + } ] let expected_json_shape_explanation = Some ( diff --git a/src/lib_test_common/typedesc_examples/ex14.ml b/src/lib_test_common/typedesc_examples/ex14.ml index f8ca536..d8eaed0 100644 --- a/src/lib_test_common/typedesc_examples/ex14.ml +++ b/src/lib_test_common/typedesc_examples/ex14.ml @@ -49,14 +49,9 @@ let ts_ast : ts_ast option = Some [ tsa_name = "Objtuple"; tsa_type_parameters = []; tsa_type_desc = - `type_literal [ - { tsps_modifiers = []; - tsps_name = "_0"; - tsps_type_desc = `type_reference "number" }; - { tsps_modifiers = []; - tsps_name = "_1"; - tsps_type_desc = - `type_reference "string" }; ] + `type_literal Util.Ts_ast.[ + property "_0" (`type_reference "number"); + property "_1" (`type_reference "string"); ] } ] @@ -64,7 +59,11 @@ let expected_json_shape_explanation = Some ( `with_warning ("not considering any config if exists", - (`named ("Objtuple", (`tuple_of [`proper_float; `string])))) + (`named + ("Objtuple", + (`object_of + [`mandatory_field ("_0", `proper_float); + `mandatory_field ("_1", `string)])))) ) open Bindoj_openapi.V3 diff --git a/src/lib_test_common/typedesc_examples/ex15.ml b/src/lib_test_common/typedesc_examples/ex15.ml index 86e6a11..b88e7ca 100644 --- a/src/lib_test_common/typedesc_examples/ex15.ml +++ b/src/lib_test_common/typedesc_examples/ex15.ml @@ -142,57 +142,42 @@ let fwrt : (unit, unit, unit) ts_fwrt_decl = ) let ts_ast : ts_ast option = + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in let student1 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student1"); }; - { tsps_modifiers = []; - tsps_name = "student"; - tsps_type_desc = `type_reference "Student"; }; ] + [ discriminator_value "student1"; + Util.Ts_ast.property "student" (`type_reference "Student"); ] in let student2 = `intersection [ `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student2"); } ]; + [ discriminator_value "student2"; ]; `type_reference "Student"; ] in let student3 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student3"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "Student"; }; ] + [ discriminator_value "student3"; + Util.Ts_ast.property arg_fname (`type_reference "Student"); ] in let student4 = `intersection [ `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "student4"); } ]; + [ discriminator_value "student4"; ]; `type_reference "Student"; ] in let int_list1 = `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "int-list1"); }; - { tsps_modifiers = []; - tsps_name = arg_fname; - tsps_type_desc = `type_reference "IntList"; }; ] + [ discriminator_value "int-list1"; + Util.Ts_ast.property arg_fname (`type_reference "IntList") ] in let int_list2 = `intersection [ `type_literal - [ { tsps_modifiers = []; - tsps_name = discriminator; - tsps_type_desc = `literal_type (`string_literal "int-list2"); } ]; + [ discriminator_value "int-list2" ]; `type_reference "IntList"; ] in @@ -242,13 +227,11 @@ let expected_json_shape_explanation = [`mandatory_field ("tag", (`exactly (`str "student3"))); `mandatory_field ("value", - (`tuple_of - [`named - ("Student", - (`object_of - [`mandatory_field - ("admissionYear", `integral); - `mandatory_field ("name", `string)]))]))]; + (`named + ("Student", + (`object_of + [`mandatory_field ("admissionYear", `integral); + `mandatory_field ("name", `string)]))))]; `object_of [`mandatory_field ("tag", (`exactly (`str "student4"))); `mandatory_field ("admissionYear", `integral); @@ -257,18 +240,17 @@ let expected_json_shape_explanation = [`mandatory_field ("tag", (`exactly (`str "int-list1"))); `mandatory_field ("value", - (`tuple_of - [`named - ("IntList", - (`anyone_of - [`object_of - [`mandatory_field - ("kind", (`exactly (`str "intnil")))]; - `object_of - [`mandatory_field - ("kind", (`exactly (`str "intcons"))); - `mandatory_field - ("arg", (`tuple_of [`integral; `self]))]]))]))]; + (`named + ("IntList", + (`anyone_of + [`object_of + [`mandatory_field + ("kind", (`exactly (`str "intnil")))]; + `object_of + [`mandatory_field + ("kind", (`exactly (`str "intcons"))); + `mandatory_field + ("arg", (`tuple_of [`integral; `self]))]]))))]; `object_of [`mandatory_field ("tag", (`exactly (`str "int-list2"))); `mandatory_field ("kind", (`exactly (`str "intnil")))]; diff --git a/src/lib_test_common/typedesc_examples/ex16.ml b/src/lib_test_common/typedesc_examples/ex16.ml index 79b695f..a6e0f8c 100644 --- a/src/lib_test_common/typedesc_examples/ex16.ml +++ b/src/lib_test_common/typedesc_examples/ex16.ml @@ -115,16 +115,10 @@ let ts_ast : ts_ast option = tsa_name = "NestedRecord"; tsa_type_parameters = []; tsa_type_desc = `intersection [ - `type_literal [ - { tsps_modifiers = []; - tsps_name = "unit"; - tsps_type_desc = `type_reference "Unit"; }; - { tsps_modifiers = []; - tsps_name = "student"; - tsps_type_desc = `type_reference "Student"; }; - { tsps_modifiers = []; - tsps_name = "person1"; - tsps_type_desc = `type_reference "person_no_mangling"; }; + `type_literal Util.Ts_ast.[ + property "unit" (`type_reference "Unit"); + property "student" (`type_reference "Student"); + property "person1" (`type_reference "person_no_mangling"); ]; `type_reference "WithInt53p"; `type_reference "person_no_mangling"; @@ -163,7 +157,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "With_id"))); `mandatory_field - ("arg", (`tuple_of [`integral]))]; + ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "Student"))); @@ -200,7 +194,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "With_id"))); `mandatory_field - ("arg", (`tuple_of [`integral]))]; + ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "Student"))); @@ -213,7 +207,7 @@ let expected_json_shape_explanation = `mandatory_field ("name", `string); `mandatory_field ("department", `string)]])))); `mandatory_field ("kind", (`exactly (`str "With_id"))); - `mandatory_field ("arg", (`tuple_of [`integral]))]; + `mandatory_field ("arg", `integral)]; `object_of [`mandatory_field ("unit", @@ -238,7 +232,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "With_id"))); `mandatory_field - ("arg", (`tuple_of [`integral]))]; + ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "Student"))); @@ -277,7 +271,7 @@ let expected_json_shape_explanation = [`mandatory_field ("kind", (`exactly (`str "With_id"))); `mandatory_field - ("arg", (`tuple_of [`integral]))]; + ("arg", `integral)]; `object_of [`mandatory_field ("kind", (`exactly (`str "Student"))); diff --git a/src/lib_test_common/typedesc_examples/ex17.ml b/src/lib_test_common/typedesc_examples/ex17.ml new file mode 100644 index 0000000..166f8c9 --- /dev/null +++ b/src/lib_test_common/typedesc_examples/ex17.ml @@ -0,0 +1,65 @@ +(* Copyright 2022-2023 Kotoi-Xie Consultancy, Inc. This file is a part of the + +==== Bindoj (https://kxc.dev/bindoj) ==== + +software project that is developed, maintained, and distributed by +Kotoi-Xie Consultancy, Inc. (https://kxc.inc) which is also known as KXC. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not +use this file except in compliance with the License. You may obtain a copy +of the License at http://www.apache.org/licenses/LICENSE-2.0. Unless required +by applicable law or agreed to in writing, software distributed under the +License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS +OF ANY KIND, either express or implied. See the License for the specific +language governing permissions and limitations under the License. + *) +(* Acknowledgements --- AnchorZ Inc. --- The current/initial version or a +significant portion of this file is developed under the funding provided by +AnchorZ Inc. to satisfy its needs in its product development workflow. + *) +open Bindoj_base.Type_desc +open Bindoj_gen_ts.Typescript_datatype + +let example_module_path = "Bindoj_test_common_typedesc_examples.Ex11" + +let cty_int_opt = Coretype.(mk_option % prim) `int + +let decl : type_decl = + alias_decl "int_opt" cty_int_opt + +let decl_with_docstr : type_decl = + alias_decl "int_opt" cty_int_opt + ~doc:(`docstr "alias of int option type") + +let fwrt : (unit, unit, unit) ts_fwrt_decl = + "int_opt", Util.FwrtTypeEnv.( + init + |> bind_alias "int_opt" cty_int_opt + ) + +let ts_ast : ts_ast option = Some [ + `type_alias_declaration { + tsa_modifiers = [`export]; + tsa_name = "IntOpt"; + tsa_type_parameters = []; + tsa_type_desc = `union [ `type_reference "number"; `type_reference "null"; `type_reference "undefined"]; + } +] + +let expected_json_shape_explanation = + Some ( + `with_warning + ("not considering any config if exists", + (`named ("IntOpt", `nullable `integral))) + ) + +open Bindoj_openapi.V3 + +let schema_object : Schema_object.t option = + Schema_object.( + option ( + integer () ~schema + ~title:"IntOpt" + ~id:"#IntOpt" + )) + |> Option.some diff --git a/src/lib_test_common/typedesc_examples/ex18.ml b/src/lib_test_common/typedesc_examples/ex18.ml new file mode 100644 index 0000000..1fb2449 --- /dev/null +++ b/src/lib_test_common/typedesc_examples/ex18.ml @@ -0,0 +1,294 @@ +(* Copyright 2022-2023 Kotoi-Xie Consultancy, Inc. This file is a part of the + +==== Bindoj (https://kxc.dev/bindoj) ==== + +software project that is developed, maintained, and distributed by +Kotoi-Xie Consultancy, Inc. (https://kxc.inc) which is also known as KXC. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not +use this file except in compliance with the License. You may obtain a copy +of the License at http://www.apache.org/licenses/LICENSE-2.0. Unless required +by applicable law or agreed to in writing, software distributed under the +License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS +OF ANY KIND, either express or implied. See the License for the specific +language governing permissions and limitations under the License. + *) +(* Acknowledgements --- AnchorZ Inc. --- The current/initial version or a +significant portion of this file is developed under the funding provided by +AnchorZ Inc. to satisfy its needs in its product development workflow. + *) +open Bindoj_base.Type_desc +open Bindoj_codec_config +open Bindoj_gen_ts.Typescript_datatype + +let example_module_path = "Bindoj_test_common_typedesc_examples.Ex18" + +let discriminator = "tag" +let arg_fname = "value" + +let variant_configs : [`type_decl] configs = [ + Json_config.variant_discriminator discriminator; +] + +let constructor_configs: [`variant_constructor] configs = [ + Json_config.name_of_variant_arg arg_fname +] + +let cty_int_opt = Coretype.(mk_option % prim) `int + +let cty_tuple = Coretype.(mk_tuple [ + option @@ prim `int; + option @@ prim `int ] + ~configs:[ Json_config.tuple_style (`obj `default) ]) + +open struct + module type Ex = sig val decl: type_decl val decl_with_docstr: type_decl end + let make_decl with_doc + : type_decl = + let decl, doc, open_ = + if with_doc then + (fun (module E: Ex) -> E.decl_with_docstr), + (fun s -> `docstr s), + (fun s -> `open_ (s ^ "_docstr_gen")) + else + (fun (module E: Ex) -> E.decl), + constant `nodoc, + (fun s -> `open_ (s ^ "_gen")) + in + variant_decl "optional_variant" [ + variant_constructor "Tuple_like" (`tuple_like [ + variant_argument cty_int_opt + ~doc:(doc "arguemnt in Tuple_like constructor"); + ]) ~configs:constructor_configs + ~doc:(doc "Tuple_like constructor"); + variant_constructor "Tuple_like_alias" (`tuple_like [ + variant_argument_nested ~codec:(open_ "Ex17") (decl (module Ex17)) + ~doc:(doc "arguemnt in Tuple_like_alias constructor"); + ]) ~configs:constructor_configs + ~doc:(doc "Tuple_like_alias constructor"); + variant_constructor "Tuple_like_obj" (`tuple_like [ + variant_argument cty_int_opt + ~doc:(doc "arguemnt at 0 in Tuple_like_obj constructor"); + variant_argument_nested ~codec:(open_ "Ex17") (decl (module Ex17)) + ~doc:(doc "arguemnt at 1 in Tuple_like_obj constructor"); + ]) ~configs:(Json_config.tuple_style (`obj `default) :: constructor_configs) + ~doc:(doc "Tuple_like_obj constructor"); + variant_constructor "Tuple_like_spreading" (`tuple_like [ + variant_argument_nested ~codec:(open_ "Ex10") (decl (module Ex10)) + ~configs:[ + Json_config.nested_field_style `spreading; + ]; + ]) ~configs:constructor_configs ~doc:(doc "tuple_like_spreading constructor"); + variant_constructor "Inline_record" (`inline_record [ + record_field_nested "int_opt" ~codec:(open_ "Ex17") (decl (module Ex17)) + ~doc:(doc "int_opt field in Inline_record constructor"); + record_field "x_opt" cty_int_opt + ~doc:(doc "x_opt field in Inline_record constructor"); + record_field "y_opt" cty_int_opt + ~doc:(doc "y_opt field in Inline_record constructor"); + record_field "objtuple" cty_tuple + ~doc:(doc "objtuple field in Inline_record constructor"); + ]) ~configs:constructor_configs + ~doc:(doc "Inline_record constructor"); + variant_constructor "Inline_record_spreading" (`inline_record [ + record_field_nested "int_opt" ~codec:(open_ "Ex17") (decl (module Ex17)) + ~doc:(doc "int_opt field in Inline_record_spreading constructor"); + record_field_nested "xy_opt" ~codec:(open_ "Ex10") (decl (module Ex10)) + ~configs:[ + Json_config.nested_field_style `spreading; + ] + ~doc:(doc "xy_opt field in inline_record constructor"); + ]) ~configs:constructor_configs + ~doc:(doc "Inline_record_spreading constructor"); + variant_constructor "Reused_inline_record" (`reused_inline_record (decl (module Ex10))) + ~configs:( + Ts_config.reused_variant_inline_record_style `intersection_type + :: constructor_configs) + ~doc:(doc "Reused_inline_record constructor"); + ] ~configs:variant_configs ~doc:(doc "definition of optional_variant type") +end + +let decl: type_decl = make_decl false + +let decl_with_docstr : type_decl = make_decl true + +let fwrt : (unit, unit, unit) ts_fwrt_decl = + let optional_variant = "optional_variant" in + optional_variant, Util.FwrtTypeEnv.( + init + |> bind_alias "int_opt" cty_int_opt + |> bind_object "xy_opt" [ + field "x_opt" cty_int_opt; + field "y_opt" cty_int_opt; ] + |> bind_object optional_variant ~configs:variant_configs [] + |> bind_constructor ~parent:optional_variant "Tuple_like" ~args:[ + variant_argument cty_int_opt + ] ~configs:constructor_configs + |> bind_constructor ~parent:optional_variant "Tuple_like_alias" ~args:[ + variant_argument_nested ~codec:(`open_ "Ex17_gen") "int_opt" + ] ~configs:constructor_configs + |> bind_constructor ~parent:optional_variant "Tuple_like_obj" ~args:[ + variant_argument cty_int_opt; + variant_argument_nested ~codec:(`open_ "Ex17_gen") "int_opt"; + ] ~configs:(Json_config.tuple_style (`obj `default) :: constructor_configs) + |> bind_constructor ~parent:optional_variant "Tuple_like_spreading" ~args:[ + variant_argument_nested ~codec:(`open_ "Ex10_gen") "xy_opt" + ~configs:[ + Json_config.nested_field_style `spreading; + ] + ] ~configs:constructor_configs + |> bind_constructor ~parent:optional_variant "Inline_record" ~fields:[ + field_nested ~codec:(`open_ "Ex17_gen") "int_opt" "int_opt"; + field "x_opt" cty_int_opt; + field "y_opt" cty_int_opt; + field "objtuple" cty_tuple; + ] ~configs:constructor_configs + |> bind_constructor ~parent:optional_variant "Inline_record_spreading" ~fields:[ + field_nested ~codec:(`open_ "Ex17_gen") "int_opt" "int_opt"; + field_nested ~codec:(`open_ "Ex10_gen") "xy_opt" "xy_opt" + ~configs:[ + Json_config.nested_field_style `spreading; + ]; + ] ~configs:constructor_configs + |> bind_constructor ~parent:optional_variant "Reused_inline_record" + ~annot_kc:(Some (Tfcki_reused_variant_inline_record Ex10.decl)) + ~fields:[ + field "x_opt" cty_int_opt; + field "y_opt" cty_int_opt; + ] + ~configs:( + Ts_config.reused_variant_inline_record_style `intersection_type + :: constructor_configs) + ) + +let ts_ast : ts_ast option = + let discriminator_value kind = + Util.Ts_ast.property discriminator (`literal_type (`string_literal kind)) + in + let property_int_opt name = + Util.Ts_ast.property ~optional:true name (`type_reference "number") + in + let tuple_like = + `type_literal [ + discriminator_value "tuple-like"; + property_int_opt arg_fname; + ] + in + let tuple_like_alias = + `type_literal [ + discriminator_value "tuple-like-alias"; + property_int_opt arg_fname; + ] + in + let tuple_like_obj = + `type_literal [ + discriminator_value "tuple-like-obj"; + property_int_opt "_0"; + property_int_opt "_1"; + ] + in + let tuple_like_spreading = + `intersection [ + `type_literal [ discriminator_value "tuple-like-spreading" ]; + `type_reference "XyOpt"; + ] + in + let inline_record = + `type_literal [ + discriminator_value "inline-record"; + property_int_opt "intOpt"; + property_int_opt "xOpt"; + property_int_opt "yOpt"; + Util.Ts_ast.property "objtuple" (`type_literal [ + property_int_opt "_0"; + property_int_opt "_1"; + ]); + ] + in + let inline_record_spreading = + `intersection [ + `type_literal [ + discriminator_value "inline-record-spreading"; + property_int_opt "intOpt"; ]; + `type_reference "XyOpt"; + ] in + let reused_inline_record = + `intersection [ + `type_literal [ discriminator_value "reused-inline-record" ]; + `type_reference "XyOpt"; + ] + in + let optional_variant = [ + "Inline_record", inline_record; + "Inline_record_spreading", inline_record_spreading; + "Reused_inline_record", reused_inline_record; + "Tuple_like", tuple_like; + "Tuple_like_alias", tuple_like_alias; + "Tuple_like_obj", tuple_like_obj; + "Tuple_like_spreading", tuple_like_spreading; + ] in + let options : Util.Ts_ast.options = + { discriminator; + var_v = "__bindoj_v"; + var_x = "__bindoj_x"; + var_fns = "__bindoj_fns"; + ret = "__bindoj_ret" } in + Some [ + `type_alias_declaration + { tsa_modifiers = [`export]; + tsa_name = "OptionalVariant"; + tsa_type_parameters = []; + tsa_type_desc = `union (List.map snd optional_variant); }; + Util.Ts_ast.case_analyzer "OptionalVariant" "analyzeOptionalVariant" options optional_variant; + ] + +let expected_json_shape_explanation = + Some ( + `with_warning + ("not considering any config if exists", + (`named + ("OptionalVariant", + (`anyone_of + [`object_of + [`mandatory_field ("tag", (`exactly (`str "tuple-like"))); + `optional_field ("value", `integral)]; + `object_of + [`mandatory_field + ("tag", (`exactly (`str "tuple-like-alias"))); + `optional_field ("value", `integral)]; + `object_of + [`mandatory_field + ("tag", (`exactly (`str "tuple-like-obj"))); + `optional_field ("_0", `integral); + `optional_field ("_1", `integral)]; + `object_of + [`mandatory_field + ("tag", (`exactly (`str "tuple-like-spreading"))); + `optional_field ("xOpt", `integral); + `optional_field ("yOpt", `integral)]; + `object_of + [`mandatory_field ("tag", (`exactly (`str "inline-record"))); + `optional_field ("intOpt", `integral); + `optional_field ("xOpt", `integral); + `optional_field ("yOpt", `integral); + `mandatory_field + ("objtuple", + (`object_of + [`optional_field ("_0", `integral); + `optional_field ("_1", `integral)]))]; + `object_of + [`mandatory_field + ("tag", (`exactly (`str "inline-record-spreading"))); + `optional_field ("intOpt", `integral); + `optional_field ("xOpt", `integral); + `optional_field ("yOpt", `integral)]; + `object_of + [`mandatory_field + ("tag", (`exactly (`str "reused-inline-record"))); + `optional_field ("xOpt", `integral); + `optional_field ("yOpt", `integral)]])))) + ) + +open Bindoj_openapi.V3 + +let schema_object : Schema_object.t option = None diff --git a/src/lib_test_common/typedesc_examples/util.ml b/src/lib_test_common/typedesc_examples/util.ml index 4ad1072..310d26b 100644 --- a/src/lib_test_common/typedesc_examples/util.ml +++ b/src/lib_test_common/typedesc_examples/util.ml @@ -39,6 +39,9 @@ module Ts_ast = struct type literal = (string * ts_type_desc) let compare_literal (xname, (_: ts_type_desc)) (yname, (_: ts_type_desc)) = String.compare xname yname + let property ?(modifiers=[]) ?(optional=false) tsps_name tsps_type_desc = + { tsps_modifiers=modifiers; tsps_name; tsps_optional=optional; tsps_type_desc } + let case_analyzer_parameters : options -> literal list -> ts_parameter list = fun options cstrs -> @@ -52,6 +55,7 @@ module Ts_ast = struct | Some { tsps_type_desc = `literal_type (`string_literal kind); _; } -> { tsps_modifiers = []; tsps_name = kind; + tsps_optional = false; tsps_type_desc = `func_type { tsft_parameters = diff --git a/src/lib_test_common/typedesc_generated_examples.ml b/src/lib_test_common/typedesc_generated_examples.ml index c80cc89..b12d996 100644 --- a/src/lib_test_common/typedesc_generated_examples.ml +++ b/src/lib_test_common/typedesc_generated_examples.ml @@ -62,4 +62,6 @@ let all : (string * (module T)) list = [ "ex14", (module Ex14); "ex15", (module Ex15); "ex16", (module Ex16); + "ex17", (module Ex17); + "ex18", (module Ex18); ] diff --git a/src/lib_test_common/typedesc_generated_examples/ex05.ml b/src/lib_test_common/typedesc_generated_examples/ex05.ml index aeca936..b341b60 100644 --- a/src/lib_test_common/typedesc_generated_examples/ex05.ml +++ b/src/lib_test_common/typedesc_generated_examples/ex05.ml @@ -73,7 +73,6 @@ let sample_value02 : sample = { map = []; }; jv = `obj [ - "option", `null; "list", `arr []; "tuple", `arr [`num 0.; `num 0.]; "objtuple", `obj ["_0", `num 0.; "_1", `num 0.]; diff --git a/src/lib_test_common/typedesc_generated_examples/ex05_notuple.ml b/src/lib_test_common/typedesc_generated_examples/ex05_notuple.ml index ca1b42f..d63ed3e 100644 --- a/src/lib_test_common/typedesc_generated_examples/ex05_notuple.ml +++ b/src/lib_test_common/typedesc_generated_examples/ex05_notuple.ml @@ -57,7 +57,6 @@ let sample_value02 : sample = { map = []; }; jv = `obj [ - "option", `null; "list", `arr []; "map", `obj []; ] diff --git a/src/lib_test_common/typedesc_generated_examples/ex10.ml b/src/lib_test_common/typedesc_generated_examples/ex10.ml index 8d5c2a7..298117e 100644 --- a/src/lib_test_common/typedesc_generated_examples/ex10.ml +++ b/src/lib_test_common/typedesc_generated_examples/ex10.ml @@ -38,10 +38,7 @@ let sample_value01 : t Sample_value.t = { x_opt = None; y_opt = None; }; - jv = `obj [ - "xOpt", `null; - "yOpt", `null; - ] + jv = `obj [ ] } let sample_value02 : t Sample_value.t = { @@ -50,7 +47,6 @@ let sample_value02 : t Sample_value.t = { y_opt = Some 42; }; jv = `obj [ - "xOpt", `null; "yOpt", `num 42.; ] } @@ -62,7 +58,6 @@ let sample_value03 : t Sample_value.t = { }; jv = `obj [ "xOpt", `num (-25.); - "yOpt", `null; ] } diff --git a/src/lib_test_common/typedesc_generated_examples/ex17.ml b/src/lib_test_common/typedesc_generated_examples/ex17.ml new file mode 100644 index 0000000..701a6dc --- /dev/null +++ b/src/lib_test_common/typedesc_generated_examples/ex17.ml @@ -0,0 +1,45 @@ +(* Copyright 2022-2023 Kotoi-Xie Consultancy, Inc. This file is a part of the + +==== Bindoj (https://kxc.dev/bindoj) ==== + +software project that is developed, maintained, and distributed by +Kotoi-Xie Consultancy, Inc. (https://kxc.inc) which is also known as KXC. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not +use this file except in compliance with the License. You may obtain a copy +of the License at http://www.apache.org/licenses/LICENSE-2.0. Unless required +by applicable law or agreed to in writing, software distributed under the +License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS +OF ANY KIND, either express or implied. See the License for the specific +language governing permissions and limitations under the License. + *) +(* Acknowledgements --- AnchorZ Inc. --- The current/initial version or a +significant portion of this file is developed under the funding provided by +AnchorZ Inc. to satisfy its needs in its product development workflow. + *) +include Bindoj_gen_test_gen_output.Ex17_gen +open Bindoj_base + +type t = int option [@@deriving show] + +let decl = Bindoj_test_common_typedesc_examples.Ex17.decl +let reflect = int_opt_reflect + +let json_shape_explanation = int_opt_json_shape_explanation +let to_json = int_opt_to_json +let of_json' = int_opt_of_json' +let env = empty_tdenv +let t : t Alcotest.testable = Alcotest.of_pp pp + +let sample_value01 : t Sample_value.t = { + orig = None; jv = `null +} + +let sample_value02 : t Sample_value.t = { + orig = Some 42; jv = `num 42. +} + +let sample_values = [ + sample_value01; + sample_value02; +] diff --git a/src/lib_test_common/typedesc_generated_examples/ex18.ml b/src/lib_test_common/typedesc_generated_examples/ex18.ml new file mode 100644 index 0000000..161d8c5 --- /dev/null +++ b/src/lib_test_common/typedesc_generated_examples/ex18.ml @@ -0,0 +1,142 @@ +(* Copyright 2022-2023 Kotoi-Xie Consultancy, Inc. This file is a part of the + +==== Bindoj (https://kxc.dev/bindoj) ==== + +software project that is developed, maintained, and distributed by +Kotoi-Xie Consultancy, Inc. (https://kxc.inc) which is also known as KXC. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not +use this file except in compliance with the License. You may obtain a copy +of the License at http://www.apache.org/licenses/LICENSE-2.0. Unless required +by applicable law or agreed to in writing, software distributed under the +License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS +OF ANY KIND, either express or implied. See the License for the specific +language governing permissions and limitations under the License. + *) +(* Acknowledgements --- AnchorZ Inc. --- The current/initial version or a +significant portion of this file is developed under the funding provided by +AnchorZ Inc. to satisfy its needs in its product development workflow. + *) +include Bindoj_gen_test_gen_output.Ex18_gen +open Bindoj_base + +type t = optional_variant = + | Tuple_like of int option + | Tuple_like_alias of Ex17.t + | Tuple_like_obj of int option * Ex17.t + | Tuple_like_spreading of Ex10.t + | Inline_record of { + int_opt: Ex17.t; + x_opt: int option; + y_opt: int option; + objtuple: int option * Ex17.t; + } + | Inline_record_spreading of { + int_opt: Ex17.t; + xy_opt: Ex10.t + } + | Reused_inline_record of { + x_opt: int option; + y_opt: int option; + } +[@@deriving show] + +let decl = Bindoj_test_common_typedesc_examples.Ex18.decl +let reflect = optional_variant_reflect + +let json_shape_explanation = optional_variant_json_shape_explanation +let to_json = optional_variant_to_json +let of_json' = optional_variant_of_json' + +let env = + let open Bindoj_typedesc.Typed_type_desc in + { Type_decl_environment.empty with + alias_ident_typemap = + StringMap.of_list [ + "xy_opt", (Boxed (Typed.mk Ex10.decl Ex10.reflect)); + "int_opt", (Boxed (Typed.mk Ex17.decl Ex17.reflect)); ] } + +let t : t Alcotest.testable = Alcotest.of_pp pp + +open struct + let sample_opts = + [ None, `null; Some 42, `num 42. ] + + let sample_tuples = + [ (None, None), []; + (Some 42, None), [ "_0", `num 42. ]; + (None, Some 128), [ "_1", `num 128. ]; + (Some 256, Some 23), [ "_0", `num 256.; "_1", `num 23. ]; + ] + + let sample_xy_opts = Ex10.[ + { x_opt = None; + y_opt = None; + }, []; + + { x_opt = None; + y_opt = Some 42; + }, [ + "yOpt", `num 42.; + ]; + + { x_opt = Some (-25); + y_opt = None; + }, [ + "xOpt", `num (-25.); + ]; + + { x_opt = Some 512; + y_opt = Some (-119); + }, [ + "xOpt", `num 512.; + "yOpt", `num (-119.); + ]; + ] +end + +open Kxclib + +let sample_values : t Sample_value.t list = + [ sample_opts |&> (fun (opt, jv) -> + Tuple_like opt, + [ ("tag", `str "tuple-like"); + ("value", jv) ]); + + sample_opts |&> (fun (opt, jv) -> + Tuple_like_alias opt, + [ ("tag", `str "tuple-like-alias"); + ("value", jv) ]); + + sample_tuples |&> (fun ((a, b), fields) -> + Tuple_like_obj (a, b), + ( ("tag", `str "tuple-like-obj") + :: fields)); + + sample_xy_opts |&> (fun (xy_opt, fields) -> + Tuple_like_spreading xy_opt, + ( ("tag", `str "tuple-like-spreading") + :: fields)); + + sample_opts |&>> (fun (int_opt, opt_jv) -> + sample_xy_opts |&>> (fun ({ x_opt; y_opt }, fields) -> + sample_tuples |&> (fun (objtuple, tuple_fields) -> + Inline_record { int_opt; x_opt; y_opt; objtuple }, + ( ("tag", `str "inline-record") + :: ("intOpt", opt_jv) :: fields @ [ + "objtuple", `obj tuple_fields + ])))); + + sample_opts |&>> (fun (int_opt, jv) -> + sample_xy_opts |&> (fun (xy_opt, fields) -> + Inline_record_spreading { int_opt; xy_opt }, + ( ("tag", `str "inline-record-spreading") + :: ("intOpt", jv) :: fields))); + + sample_xy_opts |&> (fun ({ x_opt; y_opt }, fields) -> + Reused_inline_record { x_opt; y_opt }, + ( ("tag", `str "reused-inline-record") + :: fields)); + ] |&>> (List.map (fun (orig, fields) -> + { Sample_value.orig = orig; + jv = `obj (fields |?> (fun (_, jv) -> jv <> `null)); })) diff --git a/src/lib_test_common/unit_test/comparing_of_json.ml b/src/lib_test_common/unit_test/comparing_of_json.ml index bacd225..42f107e 100644 --- a/src/lib_test_common/unit_test/comparing_of_json.ml +++ b/src/lib_test_common/unit_test/comparing_of_json.ml @@ -40,9 +40,9 @@ let () = if not result then let print_result label = function | Ok x -> eprintf "%s [%s]: Ok %a\n" S.name label S.pp x - | Error (msg, _path, shape) -> + | Error ((_, _, shape) as e) -> eprintf "%s [%s]: Error \"%s\" %a\n" - S.name label msg + S.name label (OfJsonResult.Err.to_string e) Json_shape.pp_shape_explanation shape in print_result "interpreted" interpreted; diff --git a/src/lib_typedesc/type_desc.ml b/src/lib_typedesc/type_desc.ml index 6dd300e..dff9f22 100644 --- a/src/lib_typedesc/type_desc.ml +++ b/src/lib_typedesc/type_desc.ml @@ -326,37 +326,56 @@ let variant_decl ?variant_type ?(doc=`nodoc) ?(configs=Configs.empty) td_name ct td_configs = configs; } -let rec fold_coretypes folder state td = - let fold_record_fields = - List.fold_left (fun state field -> - match field.rf_type with - | `direct ct -> folder state ct - | `nested (td, _) -> fold_coretypes folder state td - ) - in - match td.td_kind with - | Alias_decl ct -> folder state ct - | Record_decl fields -> - fold_record_fields state fields - | Variant_decl ctors -> - ctors |> List.fold_left (fun state ctor -> - match ctor.vc_param with - | `no_param -> state - | `tuple_like ts -> - ts |> List.fold_left (fun state va -> - match va.va_type with - | `direct ct -> folder state ct - | `nested (td, _) -> fold_coretypes folder state td - ) state - | `inline_record fields -> - fold_record_fields state fields - | `reused_inline_record decl -> - let fields = decl.td_kind |> function - | Record_decl fields -> fields - | _ -> failwith' "panic - type decl of reused inline record '%s' muts be record decl." ctor.vc_name - in - fold_record_fields state fields - ) state +type ancestral_configs = [ + | `alias of [`type_decl] configs + | `record_field of [`type_decl] configs * [`record_field] configs + | `variant_field of [`type_decl] configs * [`variant_constructor] configs * [`record_field] configs + | `variant_reused_field of [`type_decl] configs * [`variant_constructor] configs * [`type_decl] configs * [`record_field] configs + | `variant_argument of (** length of arguments *) int * [`type_decl] configs * [`variant_constructor] configs * [`variant_tuple_argument] configs + ] list + +let fold_coretypes' + : ('a -> coretype * ancestral_configs -> 'a) + -> 'a -> type_decl -> 'a = + fun folder -> + let rec go configs state td = + let fold_record_fields to_configs = + List.fold_left (fun state field -> + let configs = to_configs field.rf_configs in + match field.rf_type with + | `direct ct -> folder state (ct, configs) + | `nested (td, _) -> go configs state td + ) + in + match td.td_kind with + | Alias_decl ct -> folder state (ct, `alias (td.td_configs) :: configs) + | Record_decl fields -> + fold_record_fields (fun c -> (`record_field (td.td_configs, c)) :: configs) state fields + | Variant_decl ctors -> + ctors |> List.fold_left (fun state ctor -> + match ctor.vc_param with + | `no_param -> state + | `tuple_like ts -> + let len = List.length ts in + ts |> List.fold_left (fun state va -> + let configs = `variant_argument (len, td.td_configs, ctor.vc_configs, va.va_configs) :: configs in + match va.va_type with + | `direct ct -> folder state (ct, configs) + | `nested (td, _) -> go configs state td + ) state + | `inline_record fields -> + fold_record_fields (fun c -> `variant_field (td.td_configs, ctor.vc_configs, c) :: configs) state fields + | `reused_inline_record decl -> + let fields = decl.td_kind |> function + | Record_decl fields -> fields + | _ -> failwith' "panic - type decl of reused inline record '%s' muts be record decl." ctor.vc_name + in + fold_record_fields (fun c -> `variant_reused_field (td.td_configs, ctor.vc_configs, decl.td_configs, c) :: configs) state fields + ) state + in go [] + +let fold_coretypes folder state td = + fold_coretypes' (fun state (ct, _) -> folder state ct) state td let is_recursive = let check = diff --git a/src/lib_typedesc/type_desc.mli b/src/lib_typedesc/type_desc.mli index be0df2e..320cbce 100644 --- a/src/lib_typedesc/type_desc.mli +++ b/src/lib_typedesc/type_desc.mli @@ -362,6 +362,24 @@ val variant_decl : string -> variant_constructor list -> type_decl (** Creates a new {!type_decl} of {!type_decl_kind.Variant_decl}. *) +type ancestral_configs = [ + | `alias of [`type_decl] configs + (** config of alias decl. *) + | `record_field of [`type_decl] configs * [`record_field] configs + (** configs of field of record decl. *) + | `variant_field of [`type_decl] configs * [`variant_constructor] configs * [`record_field] configs + (** configs of field of variant decl. *) + | `variant_reused_field of [`type_decl] configs * [`variant_constructor] configs * [`type_decl] configs * [`record_field] configs + (** configs of reused field of variant decl. *) + | `variant_argument of (** length of arguments *) int * [`type_decl] configs * [`variant_constructor] configs * [`variant_tuple_argument] configs + (** length of arguments and configs of argument of variant decl. *) + ] list + (** List of kind and configs of type_decl, the parent of the coretype. + The format of the list is path, with head being the closest. *) + +val fold_coretypes' : ('a -> coretype * ancestral_configs -> 'a) -> 'a -> type_decl -> 'a +(** Folds a function over all {!coretype} in the given {!type_decl}. *) + val fold_coretypes : ('a -> coretype -> 'a) -> 'a -> type_decl -> 'a (** Folds a function over all {!coretype} in the given {!type_decl}. *) diff --git a/with_js/apidir-typescript-tests/tests/sample_apidir_05.test.ts b/with_js/apidir-typescript-tests/tests/sample_apidir_05.test.ts index 7c86f9a..f221b4c 100644 --- a/with_js/apidir-typescript-tests/tests/sample_apidir_05.test.ts +++ b/with_js/apidir-typescript-tests/tests/sample_apidir_05.test.ts @@ -32,13 +32,13 @@ describe("apidir-typescript-tests-sample05", () => { list: [1, 2, 3, 4], map: { foo: 4, bar: 2 }, }, - { option: null, list: [], map: {} }, + { list: [], map: {} }, ]; sample_values.forEach((x, i) => { test(`test ${i}`, async () => { const { body, status_code } = await mockClient["option-of-complex"](x); expect(status_code).toBe(200); - expect(body).toBe(x.option); + expect(body).toBe(x.option ?? null); }); }); }); diff --git a/with_js/apidir-typescript-tests/tests/sample_apidir_06.test.ts b/with_js/apidir-typescript-tests/tests/sample_apidir_06.test.ts index 48f64ae..b80b4aa 100644 --- a/with_js/apidir-typescript-tests/tests/sample_apidir_06.test.ts +++ b/with_js/apidir-typescript-tests/tests/sample_apidir_06.test.ts @@ -10,9 +10,9 @@ const mockClient: clientIntf = createMockClient(invpInfo)(mockServer); describe("apidir-typescript-tests-sample06", () => { const sample_values: XyOpt[] = [ - { xOpt: null, yOpt: null }, - { xOpt: null, yOpt: 42 }, - { xOpt: -25, yOpt: null }, + { }, + { yOpt: 42 }, + { xOpt: -25 }, { xOpt: 512, yOpt: -119 }, ]; @@ -21,7 +21,7 @@ describe("apidir-typescript-tests-sample06", () => { test(`test ${i}`, async () => { const { body, status_code } = await mockClient["get-x"](samle); expect(status_code).toBe(200); - expect(body).toBe(samle.xOpt); + expect(body).toBe(samle.xOpt ?? null); }); }); }); @@ -31,7 +31,7 @@ describe("apidir-typescript-tests-sample06", () => { test(`test ${i}`, async () => { const { body, status_code } = await mockClient["get-y"](samle); expect(status_code).toBe(200); - expect(body).toBe(samle.yOpt); + expect(body).toBe(samle.yOpt ?? null); }); }); }); diff --git a/with_js/compile-tests/dune b/with_js/compile-tests/dune index 45fb649..2812e61 100644 --- a/with_js/compile-tests/dune +++ b/with_js/compile-tests/dune @@ -371,3 +371,37 @@ (target ex16_schema.json) (action (with-stdout-to %{target} (run %{exe:./schema/gen.exe} %{target}))) (mode (promote (until-clean)))) + +(rule + (alias gen) + (target ex17_gen.ts) + (deps %{exe:../../src/lib_gen_ts/unit_test/gen/gen.exe}) + (action (with-stdout-to %{target} (run %{deps} %{target}))) + (mode (promote (until-clean)))) +(rule + (alias gen) + (target ex17_examples.json) + (action (with-stdout-to %{target} (run %{exe:./json/gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (alias gen) + (target ex17_schema.json) + (action (with-stdout-to %{target} (run %{exe:./schema/gen.exe} %{target}))) + (mode (promote (until-clean)))) + +(rule + (alias gen) + (target ex18_gen.ts) + (deps %{exe:../../src/lib_gen_ts/unit_test/gen/gen.exe}) + (action (with-stdout-to %{target} (run %{deps} %{target}))) + (mode (promote (until-clean)))) +(rule + (alias gen) + (target ex18_examples.json) + (action (with-stdout-to %{target} (run %{exe:./json/gen.exe} %{target}))) + (mode (promote (until-clean)))) +(rule + (alias gen) + (target ex18_schema.json) + (action (with-stdout-to %{target} (run %{exe:./schema/gen.exe} %{target}))) + (mode (promote (until-clean)))) diff --git a/with_js/jsoo-integration-tests/run.ml b/with_js/jsoo-integration-tests/run.ml index 25ad753..f0e1222 100644 --- a/with_js/jsoo-integration-tests/run.ml +++ b/with_js/jsoo-integration-tests/run.ml @@ -23,6 +23,7 @@ module Ts = Ts2ocaml module Faker = Json_schema_faker open Bindoj_base +open Bindoj_base.Runtime open Bindoj_test_common.Typedesc_generated_examples let notNone (_: 'a Alcotest.testable) : 'a option Alcotest.testable = @@ -120,7 +121,8 @@ let create_test_cases name (module Ex : T) filter = let handle_error = function | Ok x -> Some x - | Error (msg, _, _) -> eprintf "%s\n" msg; None + | Error e -> + eprintf "%s\n" (OfJsonResult.Err.to_string e); None in let interpreted jv =