diff --git a/CHANGES.md b/CHANGES.md index b313f3b..8c009b9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,13 @@ ## Unpublished +- **[breaking]** PPX: Code to decode polyvariants doesn't use an additional + `_poly` function which was also generated by the PPX. Instead + `Unexpected_variant` error is used to signal that next decoder should be + tried. + ([#32](https://github.com/melange-community/melange-json/pull/32)) +- **[breaking]** Json.Decode.DecodeError exception now contains a variant type + as payload instead of a string. + ([#32](https://github.com/melange-community/melange-json/pull/32)) - **[breaking]** PPX: Rename `[@json.as]` to `[@json.name]` ([#23](https://github.com/melange-community/melange-json/pull/23)) - **[breaking]** PPX: Drop special encoding for enumeration-like variants (variants with each @@ -10,6 +18,9 @@ ([#27](https://github.com/melange-community/melange-json/pull/27)) - **[breaking]** PPX: Consistent use of exceptions in runtime. ([#28](https://github.com/melange-community/melange-json/pull/28)) +- PPX: `[@@deriving json]` now can be used within signatures (this includes + `.mli` files). + ([#32](https://github.com/melange-community/melange-json/pull/32)) - PPX: Add runtime for `result` ([#13](https://github.com/melange-community/melange-json/pull/13)) - PPX: Add `yojson` as runtime dep for the native version diff --git a/examples/decode.ml b/examples/decode.ml index 11c8e73..d8024d1 100644 --- a/examples/decode.ml +++ b/examples/decode.ml @@ -25,4 +25,4 @@ let _ = let json = {|{ "y": 42 } |} |> Json.parseOrRaise in match Json.Decode.(field "x" int json) with | x -> Js.log x - | exception Json.Decode.DecodeError msg -> Js.log ("Error:" ^ msg) + | exception Json.Decode.DecodeError err -> Js.log ("Error:" ^ Json.Decode.error_to_string err) diff --git a/ppx/browser/dune b/ppx/browser/dune index 80d1c95..c6189e7 100644 --- a/ppx/browser/dune +++ b/ppx/browser/dune @@ -3,7 +3,7 @@ (name ppx_deriving_json_js) (modules :standard \ ppx_deriving_json_runtime ppx_deriving_json_js_test) (libraries ppxlib) - (ppx_runtime_libraries melange-json.ppx-runtime) + (ppx_runtime_libraries melange-json melange-json.ppx-runtime) (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) @@ -39,7 +39,4 @@ (files ../native/ppx_deriving_json_common.ml)) (copy_files# - (files ../tools/ppx_deriving_tools.ml)) - -(copy_files# - (files ../tools/ppx_deriving_tools.mli)) + (files ../native/ppx_deriving_tools.{ml,mli})) diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml index b1898bf..56241ce 100644 --- a/ppx/browser/ppx_deriving_json_runtime.ml +++ b/ppx/browser/ppx_deriving_json_runtime.ml @@ -20,9 +20,16 @@ let of_string s = in raise (Of_string_error msg) +type error = Json.Decode.error = + | Json_error of string + | Unexpected_variant of string + exception Of_json_error = Json.Decode.DecodeError -let of_json_error msg = raise (Of_json_error msg) +let of_json_error msg = raise (Of_json_error (Json_error msg)) + +let unexpected_variant_error tag = + raise (Of_json_error (Unexpected_variant tag)) module To_json = struct external string_to_json : string -> t = "%identity" diff --git a/ppx/native/dune b/ppx/native/dune index 6f0e2db..01c1a7b 100644 --- a/ppx/native/dune +++ b/ppx/native/dune @@ -37,6 +37,3 @@ (with-stdout-to %{target} (run echo "let () = Ppxlib.Driver.standalone ()")))) - -(copy_files# - (files ../tools/ppx_deriving_tools.{ml,mli})) diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index 0729a87..e1b8c43 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -161,8 +161,6 @@ module Of_json = struct let deriving : Ppx_deriving_tools.deriving = deriving_of_match () ~name:"of_json" ~of_t:(fun ~loc -> [%type: Yojson.Basic.t]) - ~error:(fun ~loc -> - [%expr Ppx_deriving_json_runtime.of_json_error "invalid JSON"]) ~derive_of_tuple ~derive_of_record ~derive_of_variant_case end diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/ppx/native/ppx_deriving_json_runtime.ml index ec11e9d..f043e9b 100644 --- a/ppx/native/ppx_deriving_json_runtime.ml +++ b/ppx/native/ppx_deriving_json_runtime.ml @@ -10,9 +10,11 @@ let of_string s = try Yojson.Basic.from_string s with Yojson.Json_error msg -> raise (Of_string_error msg) -exception Of_json_error of string +type error = Json_error of string | Unexpected_variant of string -let of_json_error msg = raise (Of_json_error msg) +exception Of_json_error of error + +let of_json_error msg = raise (Of_json_error (Json_error msg)) let show_json_type = function | `Assoc _ -> "object" @@ -24,9 +26,8 @@ let show_json_type = function | `String _ -> "string" let of_json_error_type_mismatch json expected = - raise - (Of_json_error - ("expected " ^ expected ^ " but got " ^ show_json_type json)) + of_json_error + ("expected " ^ expected ^ " but got " ^ show_json_type json) module To_json = struct let string_to_json v = `String v diff --git a/ppx/tools/ppx_deriving_tools.ml b/ppx/native/ppx_deriving_tools.ml similarity index 69% rename from ppx/tools/ppx_deriving_tools.ml rename to ppx/native/ppx_deriving_tools.ml index cea484f..04215b1 100644 --- a/ppx/tools/ppx_deriving_tools.ml +++ b/ppx/native/ppx_deriving_tools.ml @@ -82,27 +82,38 @@ class virtual deriving = method virtual extension : loc:location -> path:label -> core_type -> expression - method virtual generator + method virtual str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> structure + + method virtual sig_type_decl + : ctxt:Expansion_context.Deriver.t -> + rec_flag * type_declaration list -> + signature end let register ?deps deriving = - Deriving.add deriving#name - ~str_type_decl: - (Deriving.Generator.V2.make ?deps Deriving.Args.empty - deriving#generator) - ~extension:deriving#extension + let args = Deriving.Args.empty in + let str_type_decl = deriving#str_type_decl in + let sig_type_decl = deriving#sig_type_decl in + Deriving.add deriving#name ~extension:deriving#extension + ~str_type_decl:(Deriving.Generator.V2.make ?deps args str_type_decl) + ~sig_type_decl:(Deriving.Generator.V2.make ?deps args sig_type_decl) let register_combined ?deps name derivings = - let generator ~ctxt bindings = + let args = Deriving.Args.empty in + let str_type_decl ~ctxt bindings = + List.fold_left derivings ~init:[] ~f:(fun str d -> + d#str_type_decl ~ctxt bindings @ str) + in + let sig_type_decl ~ctxt bindings = List.fold_left derivings ~init:[] ~f:(fun str d -> - d#generator ~ctxt bindings @ str) + d#sig_type_decl ~ctxt bindings @ str) in Deriving.add name - ~str_type_decl: - (Deriving.Generator.V2.make ?deps Deriving.Args.empty generator) + ~str_type_decl:(Deriving.Generator.V2.make ?deps args str_type_decl) + ~sig_type_decl:(Deriving.Generator.V2.make ?deps args sig_type_decl) module Schema = struct let repr_row_field field = @@ -144,12 +155,6 @@ module Schema = struct | Ptype_record fs, _ -> `Ptype_record fs | Ptype_open, _ -> not_supported ~loc "open types" - let repr_type_declaration_is_poly td = - match repr_type_declaration td with - | `Ptype_core_type ({ ptyp_desc = Ptyp_variant _; _ } as t) -> - `Ptyp_variant t - | _ -> `Other - let gen_type_ascription (td : type_declaration) = let loc = td.ptype_loc in ptyp_constr ~loc @@ -162,6 +167,30 @@ module Schema = struct Location.raise_errorf ~loc "this cannot be a type parameter")) + let derive_sig_type_decl ~derive_t ~derive_label ~ctxt (_rec_flag, tds) + = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map tds ~f:(fun td -> + let name = td.ptype_name in + let type_ = derive_t ~loc name (gen_type_ascription td) in + let type_ = + List.fold_left (List.rev td.ptype_params) ~init:type_ + ~f:(fun acc (t, _) -> + let loc = t.ptyp_loc in + let name = + match t.ptyp_desc with + | Ptyp_var txt -> { txt; loc } + | _ -> + Location.raise_errorf ~loc + "type variable is not a variable" + in + let t = derive_t ~loc name t in + ptyp_arrow ~loc Nolabel t acc) + in + psig_value ~loc + (value_description ~loc ~prim:[] ~name:(derive_label name) + ~type_)) + class virtual deriving1 = object (self) inherit deriving @@ -276,7 +305,7 @@ module Schema = struct let loc = ty.ptyp_loc in as_fun ~loc (self#derive_of_core_type' ty) - method generator + method str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> structure = @@ -289,6 +318,13 @@ module Schema = struct [@@@ocaml.warning "-39-11-27"] [%%i pstr_value ~loc Recursive bindings]] + + method sig_type_decl + : ctxt:Expansion_context.Deriver.t -> + rec_flag * type_declaration list -> + signature = + derive_sig_type_decl ~derive_t:self#t + ~derive_label:self#derive_type_decl_label end end @@ -330,70 +366,8 @@ module Conv = struct let deriving_of ~name ~of_t ~error ~derive_of_tuple ~derive_of_record ~derive_of_variant ~derive_of_variant_case () = - let poly_name = sprintf "%s_poly" name in - let poly = - object (self) - inherit Schema.deriving1 - method name = name - method t ~loc _name t = [%type: [%t of_t ~loc] -> [%t t] option] - - method! derive_type_decl_label name = - map_loc (derive_of_label poly_name) name - - method! derive_of_tuple t ts x = - let t = { tpl_loc = t.ptyp_loc; tpl_types = ts; tpl_ctx = t } in - derive_of_tuple self#derive_of_core_type t x - - method! derive_of_record _ _ _ = assert false - method! derive_of_variant _ _ _ = assert false - - method! derive_of_polyvariant t (cs : row_field list) x = - let loc = t.ptyp_loc in - let cases = repr_polyvariant_cases cs in - let body, cases = - List.fold_left cases - ~init:([%expr None], []) - ~f:(fun (next, cases) (c, r) -> - match r with - | `Rtag (n, ts) -> - let make arg = - [%expr Some [%e pexp_variant ~loc:n.loc n.txt arg]] - in - let ctx = Vcs_ctx_polyvariant c in - let case = - let t = - { tpl_loc = loc; tpl_types = ts; tpl_ctx = ctx } - in - Vcs_tuple (n, t) - in - let next = - derive_of_variant_case self#derive_of_core_type make - case next - in - next, case :: cases - | `Rinherit (id, ts) -> - let x = self#derive_type_ref ~loc poly_name id ts x in - let t = ptyp_variant ~loc cs Closed None in - let next = - [%expr - match [%e x] with - | Some x -> (Some x :> [%t t] option) - | None -> [%e next]] - in - next, cases) - in - let t = - { - vrt_loc = loc; - vrt_cases = cases; - vrt_ctx = Vrt_ctx_polyvariant t; - } - in - derive_of_variant self#derive_of_core_type t body x - end - in (object (self) - inherit Schema.deriving1 as super + inherit Schema.deriving1 method name = name method t ~loc _name t = [%type: [%t of_t ~loc] -> [%t t]] @@ -459,7 +433,13 @@ module Conv = struct let cases = repr_polyvariant_cases cs in let body, cases = List.fold_left cases - ~init:(error ~loc, []) + ~init: + ( [%expr + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))], + [] ) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in match r with @@ -478,14 +458,18 @@ module Conv = struct next, case :: cases | `Rinherit (n, ts) -> let maybe_e = - poly#derive_type_ref ~loc poly_name n ts x + self#derive_type_ref ~loc self#name n ts x in let t = ptyp_variant ~loc cs Closed None in let next = [%expr match [%e maybe_e] with - | Some e -> (e :> [%t t]) - | None -> [%e next]] + | e -> (e :> [%t t]) + | exception + Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + _) -> + [%e next]] in next, cases) in @@ -497,115 +481,13 @@ module Conv = struct } in derive_of_variant self#derive_of_core_type t body x - - method! derive_of_type_declaration td = - match Schema.repr_type_declaration_is_poly td with - | `Ptyp_variant _ -> - let str = - let loc = td.ptype_loc in - let decl_name = td.ptype_name in - let params = - List.map td.ptype_params ~f:(fun (t, _) -> - match t.ptyp_desc with - | Ptyp_var txt -> t, { txt; loc = t.ptyp_loc } - | _ -> assert false) - in - let expr = - let x = [%expr x] in - let init = - poly#derive_type_ref ~loc poly_name - (map_loc lident decl_name) - (List.map params ~f:fst) x - in - let init = - [%expr - (fun x -> - match [%e init] with - | Some x -> x - | None -> [%e error ~loc] - : [%t - self#t ~loc decl_name - (Schema.gen_type_ascription td)])] - in - List.fold_left params ~init ~f:(fun body (_, param) -> - pexp_fun ~loc Nolabel None - (ppat_var ~loc - (map_loc (derive_of_label name) param)) - body) - in - [ - value_binding ~loc - ~pat: - (ppat_var ~loc - (map_loc (derive_of_label self#name) decl_name)) - ~expr; - ] - in - poly#derive_of_type_declaration td @ str - | `Other -> super#derive_of_type_declaration td end :> deriving) - let deriving_of_match ~name ~of_t ~error ~derive_of_tuple - ~derive_of_record ~derive_of_variant_case () = - let poly_name = sprintf "%s_poly" name in - let poly = - object (self) - inherit Schema.deriving1 - method name = name - method t ~loc _name t = [%type: [%t of_t ~loc] -> [%t t] option] - - method! derive_type_decl_label name = - map_loc (derive_of_label poly_name) name - - method! derive_of_tuple t ts x = - let t = { tpl_loc = t.ptyp_loc; tpl_types = ts; tpl_ctx = t } in - derive_of_tuple self#derive_of_core_type t x - - method! derive_of_record _ _ _ = assert false - method! derive_of_variant _ _ _ = assert false - - method! derive_of_polyvariant t (cs : row_field list) x = - let loc = t.ptyp_loc in - let cases = repr_polyvariant_cases cs in - let ctors, inherits = - List.partition_map cases ~f:(fun (c, r) -> - let ctx = Vcs_ctx_polyvariant c in - match r with - | `Rtag (n, ts) -> - let t = - { tpl_loc = loc; tpl_types = ts; tpl_ctx = ctx } - in - Left (n, Vcs_tuple (n, t)) - | `Rinherit (n, ts) -> Right (n, ts)) - in - let catch_all = - [%pat? x] - --> List.fold_left (List.rev inherits) ~init:[%expr None] - ~f:(fun next (n, ts) -> - let maybe = - self#derive_type_ref ~loc poly_name n ts [%expr x] - in - let t = ptyp_variant ~loc cs Closed None in - [%expr - match [%e maybe] with - | Some x -> (Some x :> [%t t] option) - | None -> [%e next]]) - in - let cases = - List.fold_left ctors ~init:[ catch_all ] - ~f:(fun next (n, case) -> - let make arg = - [%expr Some [%e pexp_variant ~loc:n.loc n.txt arg]] - in - derive_of_variant_case self#derive_of_core_type make case - :: next) - in - pexp_match ~loc x cases - end - in + let deriving_of_match ~name ~of_t ~derive_of_tuple ~derive_of_record + ~derive_of_variant_case () = (object (self) - inherit Schema.deriving1 as super + inherit Schema.deriving1 method name = name method t ~loc _name t = [%type: [%t of_t ~loc] -> [%t t]] @@ -624,7 +506,15 @@ module Conv = struct let cs = repr_variant_cases cs in let cases = List.fold_left cs - ~init:[ [%pat? _] --> error ~loc ] + ~init: + [ + [%pat? _] + --> [%expr + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))]; + ] ~f:(fun next (c : constructor_declaration) -> let ctx = Vcs_ctx_variant c in let make (n : label loc) arg = @@ -671,16 +561,26 @@ module Conv = struct in let catch_all = [%pat? x] - --> List.fold_left (List.rev inherits) ~init:(error ~loc) + --> List.fold_left (List.rev inherits) + ~init: + [%expr + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))] ~f:(fun next (n, ts) -> let maybe = - poly#derive_type_ref ~loc poly_name n ts x + self#derive_type_ref ~loc self#name n ts x in let t = ptyp_variant ~loc cs Closed None in [%expr match [%e maybe] with - | Some x -> (x :> [%t t]) - | None -> [%e next]]) + | x -> (x :> [%t t]) + | exception + Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + _) -> + [%e next]]) in let cases = List.fold_left ctors ~init:[ catch_all ] @@ -690,52 +590,6 @@ module Conv = struct :: next) in pexp_match ~loc x cases - - method! derive_of_type_declaration td = - match Schema.repr_type_declaration_is_poly td with - | `Ptyp_variant _ -> - let str = - let loc = td.ptype_loc in - let decl_name = td.ptype_name in - let params = - List.map td.ptype_params ~f:(fun (t, _) -> - match t.ptyp_desc with - | Ptyp_var txt -> t, { txt; loc = t.ptyp_loc } - | _ -> assert false) - in - let expr = - let x = [%expr x] in - let init = - poly#derive_type_ref ~loc poly_name - (map_loc lident decl_name) - (List.map params ~f:fst) x - in - let init = - [%expr - (fun x -> - match [%e init] with - | Some x -> x - | None -> [%e error ~loc] - : [%t - self#t ~loc decl_name - (Schema.gen_type_ascription td)])] - in - List.fold_left params ~init ~f:(fun body (_, param) -> - pexp_fun ~loc Nolabel None - (ppat_var ~loc - (map_loc (derive_of_label name) param)) - body) - in - [ - value_binding ~loc - ~pat: - (ppat_var ~loc - (map_loc (derive_of_label self#name) decl_name)) - ~expr; - ] - in - poly#derive_of_type_declaration td @ str - | `Other -> super#derive_of_type_declaration td end :> deriving) diff --git a/ppx/tools/ppx_deriving_tools.mli b/ppx/native/ppx_deriving_tools.mli similarity index 97% rename from ppx/tools/ppx_deriving_tools.mli rename to ppx/native/ppx_deriving_tools.mli index 18ff21d..7dffca7 100644 --- a/ppx/tools/ppx_deriving_tools.mli +++ b/ppx/native/ppx_deriving_tools.mli @@ -11,11 +11,16 @@ class virtual deriving : object loc:location -> path:label -> core_type -> expression (** a deriver can be applied to as type expression as extension node. *) - method virtual generator : + method virtual str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> structure (** or it can be attached to a type declaration. *) + + method virtual sig_type_decl : + ctxt:Expansion_context.Deriver.t -> + rec_flag * type_declaration list -> + signature end val register : ?deps:Deriving.t list -> deriving -> Deriving.t @@ -121,7 +126,6 @@ module Conv : sig val deriving_of_match : name:label -> of_t:(loc:location -> core_type) -> - error:(loc:location -> expression) -> derive_of_tuple: (derive_of_core_type -> core_type tuple -> expression -> expression) -> derive_of_record: diff --git a/ppx/test/dune b/ppx/test/dune index 7910cf3..1e8909e 100644 --- a/ppx/test/dune +++ b/ppx/test/dune @@ -3,6 +3,7 @@ (package melange-json) ./example.ml ./example_json_string.ml + ./run.sh ../../.ocamlformat ../native/ppx_deriving_json_native_test.exe ../browser/ppx_deriving_json_js_test.exe)) diff --git a/ppx/test/example.ml b/ppx/test/example.ml index edb99a1..23a3e58 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -10,19 +10,18 @@ type record_aliased = { name : string; [@json.key "my_name"] age : int; [@json.k type record_opt = { k : int option; [@json.option] } [@@deriving json] type sum = A | B of int | C of { name : string } [@@deriving json] type sum2 = S2 of int * string [@@deriving json] -type other = [ `C ] [@@deriving json] type poly = [ `A | `B of int | other ] [@@deriving json] +type other = [ `C ] [@@deriving json] +type poly = [ `A | `B of int | other ] [@@deriving json] type poly2 = [ `P2 of int * string ] [@@deriving json] type 'a c = [ `C of 'a ] [@@deriving json] type recur = A | Fix of recur [@@deriving json] type polyrecur = [ `A | `Fix of polyrecur ] [@@deriving json] type evar = A | B [@json.name "b_aliased"] [@@deriving json] -type epoly = [ `a [@json.name "A_aliased"] | `b ] [@@deriving json] type ('a, 'b) p2 = A of 'a | B of 'b [@@deriving json] type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields] type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json] type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json] type array_list = { a: int array; b: int list} [@@deriving json] - type json = Ppx_deriving_json_runtime.t type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json let of_json_cases = [ @@ -43,6 +42,7 @@ let of_json_cases = [ C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum)); C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello"))); C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly)); + C ({|["C"]|}, poly_of_json, poly_to_json, (`C : poly)); C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2)); C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A)))); C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A)))); diff --git a/ppx/test/intf.t b/ppx/test/intf.t new file mode 100644 index 0000000..132265b --- /dev/null +++ b/ppx/test/intf.t @@ -0,0 +1,24 @@ + + $ echo "type ('a, 'b) either [@@deriving json]" | ../browser/ppx_deriving_json_js_test.exe -intf - + type ('a, 'b) either[@@deriving json] + include + sig + [@@@ocaml.warning "-32"] + val either_of_json : + (Js.Json.t -> 'a) -> (Js.Json.t -> 'b) -> Js.Json.t -> ('a, 'b) either + val either_to_json : + ('a -> Js.Json.t) -> ('b -> Js.Json.t) -> ('a, 'b) either -> Js.Json.t + end[@@ocaml.doc "@inline"][@@merlin.hide ] + + $ echo "type ('a, 'b) either [@@deriving json]" | ../native/ppx_deriving_json_native_test.exe -intf - + type ('a, 'b) either[@@deriving json] + include + sig + [@@@ocaml.warning "-32"] + val either_of_json : + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> Yojson.Basic.t -> ('a, 'b) either + val either_to_json : + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> ('a, 'b) either -> Yojson.Basic.t + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/ppx/test/poly.t b/ppx/test/poly.t new file mode 100644 index 0000000..7944a84 --- /dev/null +++ b/ppx/test/poly.t @@ -0,0 +1,523 @@ +We can alias poly varaints: + $ echo ' + > type t = [`A | `B] [@@deriving json] + > type u = t [@@deriving json] + > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) + > ' | ./run.sh + === ppx output:native === + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + match x with + | `List ((`String "A")::[]) -> `A + | `List ((`String "B")::[]) -> `B + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with | `A -> `List [`String "A"] | `B -> `List [`String "B"] : + t -> Yojson.Basic.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + type u = t[@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = (fun x -> of_json x : Yojson.Basic.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = (fun x -> to_json x : u -> Yojson.Basic.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + === ppx output:browser === + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + if Js.Array.isArray x + then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + (if Stdlib.(>) len 0 + then + let tag = Js.Array.unsafe_get array 0 in + (if Stdlib.(=) (Js.typeof tag) "string" + then + let tag = (Obj.magic tag : string) in + (if Stdlib.(=) tag "A" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `A) + else + if Stdlib.(=) tag "B" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `B) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array with element being a string") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array" : Js.Json.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with + | `A -> (Obj.magic [|(Obj.magic "A" : Js.Json.t)|] : Js.Json.t) + | `B -> (Obj.magic [|(Obj.magic "B" : Js.Json.t)|] : Js.Json.t) : + t -> Js.Json.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + type u = t[@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = (fun x -> of_json x : Js.Json.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = (fun x -> to_json x : u -> Js.Json.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + === stdout:native === + ["A"] + === stdout:js === + ["A"] + +We can extend aliased polyvariants: + $ echo ' + > type t = [`A | `B] [@@deriving json] + > type u = [t | `C] [@@deriving json] + > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|}) = `C) + > ' | ./run.sh + === ppx output:native === + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + match x with + | `List ((`String "A")::[]) -> `A + | `List ((`String "B")::[]) -> `B + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with | `A -> `List [`String "A"] | `B -> `List [`String "B"] : + t -> Yojson.Basic.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + type u = [ | t | `C ][@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = + (fun x -> + match x with + | `List ((`String "C")::[]) -> `C + | x -> + (match of_json x with + | x -> (x :> [ | t | `C ]) + | exception Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) : Yojson.Basic.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = + (fun x -> + match x with | #t as x -> to_json x | `C -> `List [`String "C"] : + u -> Yojson.Basic.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + === ppx output:browser === + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + if Js.Array.isArray x + then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + (if Stdlib.(>) len 0 + then + let tag = Js.Array.unsafe_get array 0 in + (if Stdlib.(=) (Js.typeof tag) "string" + then + let tag = (Obj.magic tag : string) in + (if Stdlib.(=) tag "A" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `A) + else + if Stdlib.(=) tag "B" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `B) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array with element being a string") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array" : Js.Json.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with + | `A -> (Obj.magic [|(Obj.magic "A" : Js.Json.t)|] : Js.Json.t) + | `B -> (Obj.magic [|(Obj.magic "B" : Js.Json.t)|] : Js.Json.t) : + t -> Js.Json.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + type u = [ | t | `C ][@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = + (fun x -> + if Js.Array.isArray x + then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + (if Stdlib.(>) len 0 + then + let tag = Js.Array.unsafe_get array 0 in + (if Stdlib.(=) (Js.typeof tag) "string" + then + let tag = (Obj.magic tag : string) in + match of_json x with + | e -> (e :> [ | t | `C ]) + | exception Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + (if Stdlib.(=) tag "C" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `C) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array with element being a string") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array" : Js.Json.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = + (fun x -> + match x with + | #t as x -> to_json x + | `C -> (Obj.magic [|(Obj.magic "C" : Js.Json.t)|] : Js.Json.t) : + u -> Js.Json.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + === stdout:native === + ["A"] + ["C"] + === stdout:js === + ["A"] + ["C"] + +We can extend poly variants which are placed behind signatures: + $ echo ' + > module P : sig + > type t = [`A | `B] [@@deriving json] + > end = struct + > type t = [`A | `B] [@@deriving json] + > end + > type u = [P.t | `C] [@@deriving json] + > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + > let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|}) = `C) + > ' | ./run.sh + === ppx output:native === + module P : + sig + type t = [ `A | `B ][@@deriving json] + include + sig + [@@@ocaml.warning "-32"] + val of_json : Yojson.Basic.t -> t + val to_json : t -> Yojson.Basic.t + end[@@ocaml.doc "@inline"][@@merlin.hide ] + end = + struct + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + match x with + | `List ((`String "A")::[]) -> `A + | `List ((`String "B")::[]) -> `B + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with + | `A -> `List [`String "A"] + | `B -> `List [`String "B"] : t -> Yojson.Basic.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + end + type u = [ | P.t | `C ][@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = + (fun x -> + match x with + | `List ((`String "C")::[]) -> `C + | x -> + (match P.of_json x with + | x -> (x :> [ | P.t | `C ]) + | exception Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) : Yojson.Basic.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = + (fun x -> + match x with | #P.t as x -> P.to_json x | `C -> `List [`String "C"] : + u -> Yojson.Basic.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + === ppx output:browser === + module P : + sig + type t = [ `A | `B ][@@deriving json] + include + sig + [@@@ocaml.warning "-32"] + val of_json : Js.Json.t -> t + val to_json : t -> Js.Json.t + end[@@ocaml.doc "@inline"][@@merlin.hide ] + end = + struct + type t = [ `A | `B ][@@deriving json] + include + struct + let _ = fun (_ : t) -> () + [@@@ocaml.warning "-39-11-27"] + let rec of_json = + (fun x -> + if Js.Array.isArray x + then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + (if Stdlib.(>) len 0 + then + let tag = Js.Array.unsafe_get array 0 in + (if Stdlib.(=) (Js.typeof tag) "string" + then + let tag = (Obj.magic tag : string) in + (if Stdlib.(=) tag "A" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `A) + else + if Stdlib.(=) tag "B" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `B) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array with element being a string") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array" : Js.Json.t -> t) + let _ = of_json + [@@@ocaml.warning "-39-11-27"] + let rec to_json = + (fun x -> + match x with + | `A -> (Obj.magic [|(Obj.magic "A" : Js.Json.t)|] : Js.Json.t) + | `B -> (Obj.magic [|(Obj.magic "B" : Js.Json.t)|] : Js.Json.t) : + t -> Js.Json.t) + let _ = to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + end + type u = [ | P.t | `C ][@@deriving json] + include + struct + let _ = fun (_ : u) -> () + [@@@ocaml.warning "-39-11-27"] + let rec u_of_json = + (fun x -> + if Js.Array.isArray x + then + let array = (Obj.magic x : Js.Json.t array) in + let len = Js.Array.length array in + (if Stdlib.(>) len 0 + then + let tag = Js.Array.unsafe_get array 0 in + (if Stdlib.(=) (Js.typeof tag) "string" + then + let tag = (Obj.magic tag : string) in + match P.of_json x with + | e -> (e :> [ | P.t | `C ]) + | exception Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + (if Stdlib.(=) tag "C" + then + (if Stdlib.(<>) len 1 + then + Ppx_deriving_json_runtime.of_json_error + "expected a JSON array of length 1"; + `C) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array with element being a string") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array") + else + Ppx_deriving_json_runtime.of_json_error + "expected a non empty JSON array" : Js.Json.t -> u) + let _ = u_of_json + [@@@ocaml.warning "-39-11-27"] + let rec u_to_json = + (fun x -> + match x with + | #P.t as x -> P.to_json x + | `C -> (Obj.magic [|(Obj.magic "C" : Js.Json.t)|] : Js.Json.t) : + u -> Js.Json.t) + let _ = u_to_json + end[@@ocaml.doc "@inline"][@@merlin.hide ] + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `A)) + let () = print_endline (Ppx_deriving_json_runtime.to_string (u_to_json `C)) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["B"]|})) = `B) + let () = + assert ((u_of_json (Ppx_deriving_json_runtime.of_string {|["C"]|})) = `C) + === stdout:native === + ["A"] + ["C"] + === stdout:js === + ["A"] + ["C"] diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index f678e5d..5e567fd 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -61,6 +61,8 @@ JSON REPRINT: ["S2",42,"hello"] JSON DATA: ["B", 42] JSON REPRINT: ["B",42] + JSON DATA: ["C"] + JSON REPRINT: ["C"] JSON DATA: ["P2", 42, "hello"] JSON REPRINT: ["P2",42,"hello"] JSON DATA: ["Fix",["Fix",["Fix",["A"]]]] diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index 3745e1c..10a94c5 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -492,7 +492,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec other_of_json_poly = + let rec other_of_json = (fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -505,8 +505,12 @@ if Stdlib.( <> ) len 1 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 1"; - Some `C) - else None + `C) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a \ @@ -517,17 +521,9 @@ else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - : Js.Json.t -> other option) - - and other_of_json = - (fun x -> - match other_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" : Js.Json.t -> other) - let _ = other_of_json_poly - and _ = other_of_json + let _ = other_of_json [@@@ocaml.warning "-39-11-27"] @@ -547,7 +543,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec poly_of_json_poly = + let rec poly_of_json = (fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -560,16 +556,22 @@ if Stdlib.( <> ) len 1 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 1"; - Some `A) + `A) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 2"; - Some (`B (int_of_json (Js.Array.unsafe_get array 1)))) + `B (int_of_json (Js.Array.unsafe_get array 1))) else - match other_of_json_poly x with - | Some x -> (Some x :> [ `A | `B of int | other ] option) - | None -> None + match other_of_json x with + | e -> (e :> [ `A | `B of int | other ]) + | exception + Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a \ @@ -580,17 +582,9 @@ else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - : Js.Json.t -> poly option) - - and poly_of_json = - (fun x -> - match poly_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" : Js.Json.t -> poly) - let _ = poly_of_json_poly - and _ = poly_of_json + let _ = poly_of_json [@@@ocaml.warning "-39-11-27"] @@ -617,7 +611,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec poly2_of_json_poly = + let rec poly2_of_json = (fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -630,11 +624,14 @@ if Stdlib.( <> ) len 3 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 3"; - Some - (`P2 - ( int_of_json (Js.Array.unsafe_get array 1), - string_of_json (Js.Array.unsafe_get array 2) ))) - else None + `P2 + ( int_of_json (Js.Array.unsafe_get array 1), + string_of_json (Js.Array.unsafe_get array 2) )) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a \ @@ -645,17 +642,9 @@ else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - : Js.Json.t -> poly2 option) - - and poly2_of_json = - (fun x -> - match poly2_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" : Js.Json.t -> poly2) - let _ = poly2_of_json_poly - and _ = poly2_of_json + let _ = poly2_of_json [@@@ocaml.warning "-39-11-27"] @@ -685,7 +674,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec c_of_json_poly a_of_json : Js.Json.t -> 'a c option = + let rec c_of_json a_of_json : Js.Json.t -> 'a c = fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -698,8 +687,12 @@ if Stdlib.( <> ) len 2 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 2"; - Some (`C (a_of_json (Js.Array.unsafe_get array 1)))) - else None + `C (a_of_json (Js.Array.unsafe_get array 1))) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a string" @@ -710,14 +703,7 @@ Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - and c_of_json a_of_json : Js.Json.t -> 'a c = - fun x -> - match (c_of_json_poly a_of_json) x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" - - let _ = c_of_json_poly - and _ = c_of_json + let _ = c_of_json [@@@ocaml.warning "-39-11-27"] @@ -800,7 +786,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec polyrecur_of_json_poly = + let rec polyrecur_of_json = (fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -813,14 +799,17 @@ if Stdlib.( <> ) len 1 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 1"; - Some `A) + `A) else if Stdlib.( = ) tag "Fix" then ( if Stdlib.( <> ) len 2 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 2"; - Some - (`Fix (polyrecur_of_json (Js.Array.unsafe_get array 1)))) - else None + `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a \ @@ -831,17 +820,9 @@ else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - : Js.Json.t -> polyrecur option) - - and polyrecur_of_json = - (fun x -> - match polyrecur_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" : Js.Json.t -> polyrecur) - let _ = polyrecur_of_json_poly - and _ = polyrecur_of_json + let _ = polyrecur_of_json [@@@ocaml.warning "-39-11-27"] @@ -926,7 +907,7 @@ [@@@ocaml.warning "-39-11-27"] - let rec epoly_of_json_poly = + let rec epoly_of_json = (fun x -> if Js.Array.isArray x then let array = (Obj.magic x : Js.Json.t array) in @@ -939,13 +920,17 @@ if Stdlib.( <> ) len 1 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 1"; - Some `a) + `a) else if Stdlib.( = ) tag "b" then ( if Stdlib.( <> ) len 1 then Ppx_deriving_json_runtime.of_json_error "expected a JSON array of length 1"; - Some `b) - else None + `b) + else + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array with element being a \ @@ -956,17 +941,9 @@ else Ppx_deriving_json_runtime.of_json_error "expected a non empty JSON array" - : Js.Json.t -> epoly option) - - and epoly_of_json = - (fun x -> - match epoly_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" : Js.Json.t -> epoly) - let _ = epoly_of_json_poly - and _ = epoly_of_json + let _ = epoly_of_json [@@@ocaml.warning "-39-11-27"] diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index 05d867d..b093137 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -51,6 +51,8 @@ JSON REPRINT: ["S2",42,"hello"] JSON DATA: ["B", 42] JSON REPRINT: ["B",42] + JSON DATA: ["C"] + JSON REPRINT: ["C"] JSON DATA: ["P2", 42, "hello"] JSON REPRINT: ["P2",42,"hello"] JSON DATA: ["Fix",["Fix",["Fix",["A"]]]] diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 139c7c3..c5ef8bf 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -381,7 +381,11 @@ Ppx_deriving_json_runtime.of_json_error "missing field \"name\""); } - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> sum) let _ = sum_of_json @@ -424,7 +428,11 @@ match x with | `List [ `String "S2"; x_0; x_1 ] -> S2 (int_of_json x_0, string_of_json x_1) - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> sum2) let _ = sum2_of_json @@ -451,20 +459,18 @@ [@@@ocaml.warning "-39-11-27"] - let rec other_of_json_poly = + let rec other_of_json = (fun x -> - match x with `List (`String "C" :: []) -> Some `C | x -> None - : Yojson.Basic.t -> other option) - - and other_of_json = - (fun x -> - match other_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + match x with + | `List (`String "C" :: []) -> `C + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> other) - let _ = other_of_json_poly - and _ = other_of_json + let _ = other_of_json [@@@ocaml.warning "-39-11-27"] @@ -482,26 +488,24 @@ [@@@ocaml.warning "-39-11-27"] - let rec poly_of_json_poly = + let rec poly_of_json = (fun x -> match x with - | `List (`String "A" :: []) -> Some `A - | `List [ `String "B"; x_0 ] -> Some (`B (int_of_json x_0)) + | `List (`String "A" :: []) -> `A + | `List [ `String "B"; x_0 ] -> `B (int_of_json x_0) | x -> ( - match other_of_json_poly x with - | Some x -> (Some x :> [ `A | `B of int | other ] option) - | None -> None) - : Yojson.Basic.t -> poly option) - - and poly_of_json = - (fun x -> - match poly_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + match other_of_json x with + | x -> (x :> [ `A | `B of int | other ]) + | exception + Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant _) -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant"))) : Yojson.Basic.t -> poly) - let _ = poly_of_json_poly - and _ = poly_of_json + let _ = poly_of_json [@@@ocaml.warning "-39-11-27"] @@ -526,23 +530,19 @@ [@@@ocaml.warning "-39-11-27"] - let rec poly2_of_json_poly = + let rec poly2_of_json = (fun x -> match x with | `List [ `String "P2"; x_0; x_1 ] -> - Some (`P2 (int_of_json x_0, string_of_json x_1)) - | x -> None - : Yojson.Basic.t -> poly2 option) - - and poly2_of_json = - (fun x -> - match poly2_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + `P2 (int_of_json x_0, string_of_json x_1) + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> poly2) - let _ = poly2_of_json_poly - and _ = poly2_of_json + let _ = poly2_of_json [@@@ocaml.warning "-39-11-27"] @@ -566,20 +566,17 @@ [@@@ocaml.warning "-39-11-27"] - let rec c_of_json_poly a_of_json : Yojson.Basic.t -> 'a c option = + let rec c_of_json a_of_json : Yojson.Basic.t -> 'a c = fun x -> match x with - | `List [ `String "C"; x_0 ] -> Some (`C (a_of_json x_0)) - | x -> None + | `List [ `String "C"; x_0 ] -> `C (a_of_json x_0) + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) - and c_of_json a_of_json : Yojson.Basic.t -> 'a c = - fun x -> - match (c_of_json_poly a_of_json) x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" - - let _ = c_of_json_poly - and _ = c_of_json + let _ = c_of_json [@@@ocaml.warning "-39-11-27"] @@ -604,7 +601,11 @@ match x with | `List (`String "A" :: []) -> A | `List [ `String "Fix"; x_0 ] -> Fix (recur_of_json x_0) - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> recur) let _ = recur_of_json @@ -631,24 +632,19 @@ [@@@ocaml.warning "-39-11-27"] - let rec polyrecur_of_json_poly = + let rec polyrecur_of_json = (fun x -> match x with - | `List (`String "A" :: []) -> Some `A - | `List [ `String "Fix"; x_0 ] -> - Some (`Fix (polyrecur_of_json x_0)) - | x -> None - : Yojson.Basic.t -> polyrecur option) - - and polyrecur_of_json = - (fun x -> - match polyrecur_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | `List (`String "A" :: []) -> `A + | `List [ `String "Fix"; x_0 ] -> `Fix (polyrecur_of_json x_0) + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> polyrecur) - let _ = polyrecur_of_json_poly - and _ = polyrecur_of_json + let _ = polyrecur_of_json [@@@ocaml.warning "-39-11-27"] @@ -677,7 +673,11 @@ match x with | `List (`String "A" :: []) -> A | `List (`String "b_aliased" :: []) -> B - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> evar) let _ = evar_of_json @@ -704,23 +704,19 @@ [@@@ocaml.warning "-39-11-27"] - let rec epoly_of_json_poly = + let rec epoly_of_json = (fun x -> match x with - | `List (`String "A_aliased" :: []) -> Some `a - | `List (`String "b" :: []) -> Some `b - | x -> None - : Yojson.Basic.t -> epoly option) - - and epoly_of_json = - (fun x -> - match epoly_of_json_poly x with - | Some x -> x - | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | `List (`String "A_aliased" :: []) -> `a + | `List (`String "b" :: []) -> `b + | x -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> epoly) - let _ = epoly_of_json_poly - and _ = epoly_of_json + let _ = epoly_of_json [@@@ocaml.warning "-39-11-27"] @@ -749,7 +745,11 @@ match x with | `List [ `String "A"; x_0 ] -> A (a_of_json x_0) | `List [ `String "B"; x_0 ] -> B (b_of_json x_0) - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) let _ = p2_of_json @@ -853,7 +853,11 @@ Ppx_deriving_json_runtime.of_json_error "missing field \"a\""); } - | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON" + | _ -> + raise + (Ppx_deriving_json_runtime.Of_json_error + (Ppx_deriving_json_runtime.Unexpected_variant + "unexpected variant")) : Yojson.Basic.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json diff --git a/ppx/test/run.sh b/ppx/test/run.sh new file mode 100755 index 0000000..ea376fa --- /dev/null +++ b/ppx/test/run.sh @@ -0,0 +1,39 @@ +#!/bin/bash + +cat > main.ml +cat main.ml > main_js.ml + +echo '(lang dune 3.11) +(implicit_transitive_deps false) +(using melange 0.1) +' > dune-project + +echo ' +(library + (name lib) + (modes melange) + (modules main_js) + (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (preprocess (pps melange.ppx melange-json.ppx))) +(melange.emit + (alias js) + (target output) + (modules) + (libraries lib) + (module_systems commonjs)) +(executable + (name main) + (modules main) + (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (preprocess (pps melange-json-native.ppx))) +' > dune + +echo '=== ppx output:native ===' +../native/ppx_deriving_json_native_test.exe main.ml +echo '=== ppx output:browser ===' +../browser/ppx_deriving_json_js_test.exe main_js.ml +echo '=== stdout:native ===' +dune exec ./main.exe || exit 1 +echo '=== stdout:js ===' +dune build @js || exit 1 +node ./_build/default/output/main_js.js diff --git a/src/Json_decode.ml b/src/Json_decode.ml index 0595322..5abdf9b 100644 --- a/src/Json_decode.ml +++ b/src/Json_decode.ml @@ -1,38 +1,45 @@ -external _unsafeCreateUninitializedArray : int -> 'a array = "Array" [@@mel.new] +external _unsafeCreateUninitializedArray : int -> 'a array = "Array" +[@@mel.new] + external _stringify : Js.Json.t -> string = "JSON.stringify" let _isInteger value = Js.Float.isFinite value && Js.Math.floor_float value == value type 'a decoder = Js.Json.t -> 'a +type error = Json_error of string | Unexpected_variant of string + +let error_to_string = function + | Json_error msg -> msg + | Unexpected_variant tag -> "unexpected variant: " ^ tag -exception DecodeError of string +exception DecodeError of error +let error msg = raise (DecodeError (Json_error msg)) let id json = json let bool json = if Js.typeof json = "boolean" then (Obj.magic (json : Js.Json.t) : bool) - else raise @@ DecodeError ("Expected boolean, got " ^ _stringify json) + else error ("Expected boolean, got " ^ _stringify json) let float json = if Js.typeof json = "number" then (Obj.magic (json : Js.Json.t) : float) - else raise @@ DecodeError ("Expected number, got " ^ _stringify json) + else error ("Expected number, got " ^ _stringify json) let int json = let f = float json in if _isInteger f then (Obj.magic (f : float) : int) - else raise @@ DecodeError ("Expected integer, got " ^ _stringify json) + else error ("Expected integer, got " ^ _stringify json) let string json = - if Js.typeof json = "string" then (Obj.magic (json : Js.Json.t) : string) - else raise @@ DecodeError ("Expected string, got " ^ _stringify json) + if Js.typeof json = "string" then + (Obj.magic (json : Js.Json.t) : string) + else error ("Expected string, got " ^ _stringify json) let char json = let s = string json in if String.length s = 1 then String.get s 0 - else - raise - @@ DecodeError ("Expected single-character string, got " ^ _stringify json) + else error ("Expected single-character string, got " ^ _stringify json) let date json = json |> string |> Js.Date.fromString @@ -43,7 +50,7 @@ let nullable decode json = (* TODO: remove this? *) let nullAs value json = if (Obj.magic json : 'a Js.null) == Js.null then value - else raise @@ DecodeError ("Expected null, got " ^ _stringify json) + else error ("Expected null, got " ^ _stringify json) let array decode json = if Js.Array.isArray json then ( @@ -53,13 +60,16 @@ let array decode json = for i = 0 to length - 1 do let value = try decode (Array.unsafe_get source i) - with DecodeError msg -> - raise @@ DecodeError (msg ^ "\n\tin array at index " ^ string_of_int i) + with DecodeError err -> + error + (error_to_string err + ^ "\n\tin array at index " + ^ string_of_int i) in Array.unsafe_set target i value done; target) - else raise @@ DecodeError ("Expected array, got " ^ _stringify json) + else error ("Expected array, got " ^ _stringify json) let list decode json = json |> array decode |> Array.to_list @@ -71,13 +81,12 @@ let pair decodeA decodeB json = try ( decodeA (Array.unsafe_get source 0), decodeB (Array.unsafe_get source 1) ) - with DecodeError msg -> raise @@ DecodeError (msg ^ "\n\tin pair/tuple2") + with DecodeError err -> + error (error_to_string err ^ "\n\tin pair/tuple2") else let length = Js.String.make length in - raise - (DecodeError - {j|Expected array of length 2, got array of length $length|j}) - else raise @@ DecodeError ("Expected array, got " ^ _stringify json) + error {j|Expected array of length 2, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) let tuple2 = pair @@ -90,13 +99,12 @@ let tuple3 decodeA decodeB decodeC json = ( decodeA (Array.unsafe_get source 0), decodeB (Array.unsafe_get source 1), decodeC (Array.unsafe_get source 2) ) - with DecodeError msg -> raise @@ DecodeError (msg ^ "\n\tin tuple3") + with DecodeError err -> + error (error_to_string err ^ "\n\tin tuple3") else let length = Js.String.make length in - raise - (DecodeError - {j|Expected array of length 3, got array of length $length|j}) - else raise @@ DecodeError ("Expected array, got " ^ _stringify json) + error {j|Expected array of length 3, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) let tuple4 decodeA decodeB decodeC decodeD json = if Js.Array.isArray json then @@ -108,13 +116,12 @@ let tuple4 decodeA decodeB decodeC decodeD json = decodeB (Array.unsafe_get source 1), decodeC (Array.unsafe_get source 2), decodeD (Array.unsafe_get source 3) ) - with DecodeError msg -> raise @@ DecodeError (msg ^ "\n\tin tuple4") + with DecodeError err -> + error (error_to_string err ^ "\n\tin tuple4") else let length = Js.String.make length in - raise - (DecodeError - {j|Expected array of length 4, got array of length $length|j}) - else raise @@ DecodeError ("Expected array, got " ^ _stringify json) + error {j|Expected array of length 4, got array of length $length|j} + else error ("Expected array, got " ^ _stringify json) let dict decode json = if @@ -130,12 +137,13 @@ let dict decode json = let key = Array.unsafe_get keys i in let value = try decode (Js.Dict.unsafeGet source key) - with DecodeError msg -> raise @@ DecodeError (msg ^ "\n\tin dict") + with DecodeError err -> + error (error_to_string err ^ "\n\tin dict") in Js.Dict.set target key value done; target) - else raise @@ DecodeError ("Expected object, got " ^ _stringify json) + else error ("Expected object, got " ^ _stringify json) let field key decode json = if @@ -147,10 +155,10 @@ let field key decode json = match Js.Dict.get dict key with | Some value -> ( try decode value - with DecodeError msg -> - raise @@ DecodeError (msg ^ "\n\tat field '" ^ key ^ "'")) - | None -> raise @@ DecodeError {j|Expected field '$(key)'|j} - else raise @@ DecodeError ("Expected object, got " ^ _stringify json) + with DecodeError err -> + error (error_to_string err ^ "\n\tat field '" ^ key ^ "'")) + | None -> error {j|Expected field '$(key)'|j} + else error ("Expected object, got " ^ _stringify json) let rec at key_path decoder = match key_path with @@ -158,21 +166,23 @@ let rec at key_path decoder = | first :: rest -> field first (at rest decoder) | [] -> raise - @@ Invalid_argument "Expected key_path to contain at least one element" + @@ Invalid_argument + "Expected key_path to contain at least one element" -let optional decode json = try Some (decode json) with DecodeError _ -> None +let optional decode json = + try Some (decode json) with DecodeError _ -> None let oneOf decoders json = let rec inner decoders errors = match decoders with | [] -> let formattedErrors = - "\n- " ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) + "\n- " + ^ Js.Array.join ~sep:"\n- " (Array.of_list (List.rev errors)) in - raise - @@ DecodeError - ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} - ^ _stringify json) + error + ({j|All decoders given to oneOf failed. Here are all the errors: $formattedErrors\nAnd the JSON being decoded: |j} + ^ _stringify json) | decode :: rest -> ( try decode json with DecodeError e -> inner rest (e :: errors)) in diff --git a/src/Json_decode.mli b/src/Json_decode.mli index 23fac0b..e2dc3e1 100644 --- a/src/Json_decode.mli +++ b/src/Json_decode.mli @@ -13,7 +13,11 @@ third-party libraries. type 'a decoder = Js.Json.t -> 'a (** The type of a decoder combinator *) -exception DecodeError of string +type error = Json_error of string | Unexpected_variant of string + +val error_to_string : error -> string + +exception DecodeError of error val id : Js.Json.t decoder (** Identity decoder. diff --git a/src/__tests__/Json_decode_test.ml b/src/__tests__/Json_decode_test.ml index 3fb49b7..88cca5a 100644 --- a/src/__tests__/Json_decode_test.ml +++ b/src/__tests__/Json_decode_test.ml @@ -73,7 +73,7 @@ let () = try let (_ : int) = int (Encode.int inf) in fail "should throw" - with Decode.DecodeError "Expected integer, got null" -> pass); + with Decode.DecodeError Json_error "Expected integer, got null" -> pass); Test.throws int [ Bool; Float; String; Null; Array; Object; Char ]); @@ -111,7 +111,7 @@ let () = let (_ : char) = char (Encode.string "") in fail "should throw" with - | Decode.DecodeError "Expected single-character string, got \"\"" -> + | Decode.DecodeError Json_error "Expected single-character string, got \"\"" -> pass); test "multiple-character string" (fun () -> @@ -119,7 +119,7 @@ let () = let (_ : char) = char (Encode.string "abc") in fail "should throw" with - | Decode.DecodeError "Expected single-character string, got \"abc\"" + | Decode.DecodeError Json_error "Expected single-character string, got \"abc\"" -> pass); @@ -193,7 +193,7 @@ let () = (array bool) (parseOrRaise {| [1, 2, 3] |}) in fail "should throw" - with DecodeError "Expected boolean, got 1\n\tin array at index 0" -> + with DecodeError Json_error "Expected boolean, got 1\n\tin array at index 0" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -233,7 +233,7 @@ let () = try let (_ : bool list) = (list bool) (parseOrRaise {| [1, 2, 3] |}) in fail "should throw" - with DecodeError "Expected boolean, got 1\n\tin array at index 0" -> + with DecodeError Json_error "Expected boolean, got 1\n\tin array at index 0" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -259,7 +259,7 @@ let () = let (_ : int * int) = (pair int int) (parseOrRaise {| [4] |}) in fail "should throw" with - | DecodeError "Expected array of length 2, got array of length 1" -> + | DecodeError Json_error "Expected array of length 2, got array of length 1" -> pass); test "too large" (fun () -> try @@ -268,7 +268,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 2, got array of length 3" -> + | DecodeError Json_error "Expected array of length 2, got array of length 3" -> pass); test "bad type a" (fun () -> try @@ -276,7 +276,7 @@ let () = (pair int int) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError "Expected number, got \"3\"\n\tin pair/tuple2" -> + with DecodeError Json_error "Expected number, got \"3\"\n\tin pair/tuple2" -> pass); test "bad type b" (fun () -> try @@ -284,12 +284,12 @@ let () = (pair string string) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError "Expected string, got 4\n\tin pair/tuple2" -> pass); + with DecodeError Json_error "Expected string, got 4\n\tin pair/tuple2" -> pass); test "not array" (fun () -> try let (_ : int * int) = (pair int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError "Expected array, got 4" -> pass); + with DecodeError Json_error "Expected array, got 4" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -310,7 +310,7 @@ let () = let (_ : int * int) = (tuple2 int int) (parseOrRaise {| [4] |}) in fail "should throw" with - | DecodeError "Expected array of length 2, got array of length 1" -> + | DecodeError Json_error "Expected array of length 2, got array of length 1" -> pass); test "too large" (fun () -> try @@ -319,7 +319,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 2, got array of length 3" -> + | DecodeError Json_error "Expected array of length 2, got array of length 3" -> pass); test "bad type a" (fun () -> try @@ -327,7 +327,7 @@ let () = (tuple2 int int) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError "Expected number, got \"3\"\n\tin pair/tuple2" -> + with DecodeError Json_error "Expected number, got \"3\"\n\tin pair/tuple2" -> pass); test "bad type b" (fun () -> try @@ -335,12 +335,12 @@ let () = (tuple2 string string) (parseOrRaise {| ["3", 4] |}) in fail "should throw" - with DecodeError "Expected string, got 4\n\tin pair/tuple2" -> pass); + with DecodeError Json_error "Expected string, got 4\n\tin pair/tuple2" -> pass); test "not array" (fun () -> try let (_ : int * int) = (tuple2 int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError "Expected array, got 4" -> pass); + with DecodeError Json_error "Expected array, got 4" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -363,7 +363,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 3, got array of length 1" -> + | DecodeError Json_error "Expected array of length 3, got array of length 1" -> pass); test "too large" (fun () -> try @@ -372,7 +372,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 3, got array of length 5" -> + | DecodeError Json_error "Expected array of length 3, got array of length 5" -> pass); test "bad type a" (fun () -> try @@ -380,21 +380,21 @@ let () = (tuple3 int int int) (parseOrRaise {| ["3", 4, 5] |}) in fail "should throw" - with DecodeError "Expected number, got \"3\"\n\tin tuple3" -> pass); + with DecodeError Json_error "Expected number, got \"3\"\n\tin tuple3" -> pass); test "bad type b" (fun () -> try let (_ : string * string * string) = (tuple3 string string string) (parseOrRaise {| ["3", 4, "5"] |}) in fail "should throw" - with DecodeError "Expected string, got 4\n\tin tuple3" -> pass); + with DecodeError Json_error "Expected string, got 4\n\tin tuple3" -> pass); test "not array" (fun () -> try let (_ : int * int * int) = (tuple3 int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError "Expected array, got 4" -> pass); + with DecodeError Json_error "Expected array, got 4" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -420,7 +420,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 4, got array of length 1" -> + | DecodeError Json_error "Expected array of length 4, got array of length 1" -> pass); test "too large" (fun () -> try @@ -429,7 +429,7 @@ let () = in fail "should throw" with - | DecodeError "Expected array of length 4, got array of length 6" -> + | DecodeError Json_error "Expected array of length 4, got array of length 6" -> pass); test "bad type a" (fun () -> try @@ -437,7 +437,7 @@ let () = (tuple4 int int int int) (parseOrRaise {| ["3", 4, 5, 6] |}) in fail "should throw" - with DecodeError "Expected number, got \"3\"\n\tin tuple4" -> pass); + with DecodeError Json_error "Expected number, got \"3\"\n\tin tuple4" -> pass); test "bad type b" (fun () -> try let (_ : string * string * string * string) = @@ -445,14 +445,14 @@ let () = (parseOrRaise {| ["3", 4, "5", "6"] |}) in fail "should throw" - with DecodeError "Expected string, got 4\n\tin tuple4" -> pass); + with DecodeError Json_error "Expected string, got 4\n\tin tuple4" -> pass); test "not array" (fun () -> try let (_ : int * int * int * int) = (tuple4 int int int int) (parseOrRaise {| 4 |}) in fail "should throw" - with DecodeError "Expected array, got 4" -> pass); + with DecodeError Json_error "Expected array, got 4" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -491,7 +491,7 @@ let () = (dict string) (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError "Expected string, got null\n\tin dict" -> pass); + with DecodeError Json_error "Expected string, got null\n\tin dict" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> try @@ -530,14 +530,14 @@ let () = (field "c" string) (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError "Expected field 'c'" -> pass); + with DecodeError Json_error "Expected field 'c'" -> pass); test "decoder error" (fun () -> try let (_ : string) = (field "b" string) (parseOrRaise {| { "a": null, "b": null } |}) in fail "should throw" - with DecodeError "Expected string, got null\n\tat field 'b'" -> pass); + with DecodeError Json_error "Expected string, got null\n\tat field 'b'" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -584,7 +584,7 @@ let () = } |}) in fail "should throw" - with DecodeError "Expected field 'y'\n\tat field 'a'" -> pass); + with DecodeError Json_error "Expected field 'y'\n\tat field 'a'" -> pass); test "decoder error" (fun () -> try let (_ : 'a Js.null) = @@ -598,7 +598,7 @@ let () = fail "should throw" with | DecodeError - "Expected null, got \"foo\"\n\ + Json_error "Expected null, got \"foo\"\n\ \tat field 'y'\n\ \tat field 'x'\n\ \tat field 'a'" @@ -670,7 +670,7 @@ let () = (field "y" (optional int)) (parseOrRaise {| { "x": 2} |}) in fail "should throw" - with DecodeError "Expected field 'y'" -> pass); + with DecodeError Json_error "Expected field 'y'" -> pass); test "non-DecodeError exceptions in decoder should pass through" (fun () -> @@ -797,7 +797,7 @@ let () = fail "should throw" with | DecodeError - "Expected number, got true\n\ + Json_error "Expected number, got true\n\ \tin array at index 0\n\ \tin array at index 1\n\ \tin dict" @@ -812,7 +812,7 @@ let () = fail "should throw" with | DecodeError - "Expected array, got \"foo\"\n\tin array at index 1\n\tin dict" + Json_error "Expected array, got \"foo\"\n\tin array at index 1\n\tin dict" -> pass); test "field" (fun () ->