diff --git a/ppx/browser/dune b/ppx/browser/dune index c6189e7..1779f11 100644 --- a/ppx/browser/dune +++ b/ppx/browser/dune @@ -1,21 +1,13 @@ (library (public_name melange-json.ppx) (name ppx_deriving_json_js) - (modules :standard \ ppx_deriving_json_runtime ppx_deriving_json_js_test) + (modules :standard \ ppx_deriving_json_js_test) (libraries ppxlib) - (ppx_runtime_libraries melange-json melange-json.ppx-runtime) + (ppx_runtime_libraries melange-json) (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) -(library - (public_name melange-json.ppx-runtime) - (name ppx_deriving_json_js_runtime) - (modules ppx_deriving_json_runtime) - (libraries melange-json) - (wrapped false) - (modes melange)) - (executable (name ppx_deriving_json_js_test) (modules ppx_deriving_json_js_test) diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 5afcb83..585712b 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -7,6 +7,13 @@ open Ppx_deriving_tools.Conv open Ppx_deriving_json_common module Of_json = struct + let of_json_error ~loc fmt = + ksprintf + (fun msg -> + let msg = estring ~loc msg in + [%expr raise (Json.Of_json_error (Json_error [%e msg]))]) + fmt + let build_tuple ~loc derive si (ts : core_type list) e = pexp_tuple ~loc (List.mapi ts ~f:(fun i t -> @@ -38,12 +45,7 @@ module Of_json = struct [%e match ld_attr_default ld with | Some default -> default - | None -> - [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "missing field %S" n.txt)]]]] - ) + | None -> of_json_error ~loc "missing field: %S" n.txt]] ) in [%expr let fs = (Obj.magic [%e x] : [%t build_js_type ~loc fs]) in @@ -65,15 +67,12 @@ module Of_json = struct let ensure_json_object ~loc x = [%expr if Stdlib.not [%e eis_json_object ~loc x] then - Ppx_deriving_json_runtime.of_json_error - [%e estring ~loc (sprintf "expected a JSON object")]] + [%e of_json_error ~loc "expected a JSON object"]] let ensure_json_array_len ~loc n len = [%expr if Stdlib.( <> ) [%e len] [%e eint ~loc n] then - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "expected a JSON array of length %i" n)]] + [%e of_json_error ~loc "expected a JSON array of length %i" n]] let derive_of_tuple derive t x = let loc = t.tpl_loc in @@ -88,10 +87,7 @@ module Of_json = struct then let es = (Obj.magic [%e x] : Js.Json.t array) in [%e build_tuple ~loc derive 0 t.tpl_types [%expr es]] - else - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc (sprintf "expected a JSON array of length %i" n)]] + else [%e of_json_error ~loc "expected a JSON array of length %i" n]] let derive_of_record derive t x = let loc = t.rcd_loc in @@ -111,15 +107,12 @@ module Of_json = struct let tag = (Obj.magic tag : string) in [%e body] 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"] + [%e + of_json_error ~loc + "expected a non empty JSON array with element being a \ + string"] + else [%e of_json_error ~loc "expected a non empty JSON array"] + else [%e of_json_error ~loc "expected a non empty JSON array"]] let derive_of_variant_case derive make c next = match c with @@ -152,8 +145,7 @@ module Of_json = struct let deriving : Ppx_deriving_tools.deriving = deriving_of () ~name:"of_json" - ~error:(fun ~loc -> - [%expr Ppx_deriving_json_runtime.of_json_error "invalid JSON"]) + ~error:(fun ~loc -> of_json_error ~loc "invalid JSON") ~of_t:(fun ~loc -> [%type: Js.Json.t]) ~derive_of_tuple ~derive_of_record ~derive_of_variant ~derive_of_variant_case diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml deleted file mode 100644 index 0d5ece2..0000000 --- a/ppx/browser/ppx_deriving_json_runtime.ml +++ /dev/null @@ -1,111 +0,0 @@ -[@@@alert "-deprecated"] - -type t = Js.Json.t - -let to_json t = t -let of_json t = t -let to_string t = Js.Json.stringify t - -let of_string s = - try Js.Json.parseExn s - with exn -> - let msg = - match Js.Exn.asJsExn exn with - | Some jsexn -> Js.Exn.message jsexn - | None -> None - in - let msg = - (* msg really cannot be None in browser or any sane JS runtime *) - Option.value msg ~default:"JSON error" - in - raise (Json.Of_string_error msg) - -type error = Json.of_json_error = - | Json_error of string - | Unexpected_variant of string - -exception Of_json_error = Json.Of_json_error - -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" - external bool_to_json : bool -> t = "%identity" - external int_to_json : int -> t = "%identity" - - let int64_to_json : int64 -> t = fun v -> Obj.magic (Int64.to_string v) - - external float_to_json : float -> t = "%identity" - - let unit_to_json () : t = Obj.magic Js.null - - let array_to_json v_to_json vs : t = - let vs : Js.Json.t array = Js.Array.map ~f:v_to_json vs in - Obj.magic vs - - let list_to_json v_to_json vs : t = - let vs = Array.of_list vs in - array_to_json v_to_json vs - - let option_to_json v_to_json v : t = - match v with None -> Obj.magic Js.null | Some v -> v_to_json v - - let result_to_json a_to_json b_to_json v : t = - match v with - | Ok x -> Obj.magic [| string_to_json "Ok"; a_to_json x |] - | Error x -> Obj.magic [| string_to_json "Error"; b_to_json x |] -end - -module Of_json = struct - let string_of_json = Json.Of_json.string - let bool_of_json = Json.Of_json.bool - let int_of_json = Json.Of_json.int - let int64_of_json = Json.Of_json.int64 - let float_of_json = Json.Of_json.float - let unit_of_json = Json.Of_json.unit - let array_of_json = Json.Of_json.array - let list_of_json = Json.Of_json.list - let option_of_json = Json.Of_json.option - let result_of_json = Json.Of_json.result -end - -module Primitives = struct - include Of_json - include To_json -end - -module Classify = struct - (* This function is also defined in `Json` module, but not exposed on its mli *) - let is_int value = - Js.Float.isFinite value && Js.Math.floor_float value == value - - let classify : - t -> - [ `Null - | `String of string - | `Float of float - | `Int of int - | `Bool of bool - | `List of t list - | `Assoc of (string * t) list ] = - fun json -> - if (Obj.magic json : 'a Js.null) == Js.null then `Null - else - match Js.typeof json with - | "string" -> `String (Obj.magic json : string) - | "number" -> - let v = (Obj.magic json : float) in - if is_int v then `Int (Obj.magic v : int) else `Float v - | "boolean" -> `Bool (Obj.magic json : bool) - | "object" -> - if Js.Array.isArray json then - let xs = Array.to_list (Obj.magic json : t array) in - `List xs - else - let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in - `Assoc (Array.to_list xs) - | typ -> failwith ("unknown JSON value type: " ^ typ) -end diff --git a/ppx/native/dune b/ppx/native/dune index 01c1a7b..18286fe 100644 --- a/ppx/native/dune +++ b/ppx/native/dune @@ -1,24 +1,13 @@ (library (public_name melange-json-native.ppx) (name ppx_deriving_json_native) - (modules - :standard - \ - ppx_deriving_json_runtime - ppx_deriving_json_native_test) + (modules :standard \ ppx_deriving_json_native_test) (libraries ppxlib) - (ppx_runtime_libraries melange-json-native.ppx-runtime yojson) + (ppx_runtime_libraries melange-json-native yojson) (preprocess (pps ppxlib.metaquot)) (kind ppx_deriver)) -(library - (public_name melange-json-native.ppx-runtime) - (name ppx_deriving_json_native_runtime) - (wrapped false) - (modules ppx_deriving_json_runtime) - (libraries yojson)) - (executable (name ppx_deriving_json_native_test) (modules ppx_deriving_json_native_test) diff --git a/ppx/native/ppx_deriving_json_common.ml b/ppx/native/ppx_deriving_json_common.ml index f3524bd..0a528ff 100644 --- a/ppx/native/ppx_deriving_json_common.ml +++ b/ppx/native/ppx_deriving_json_common.ml @@ -119,9 +119,7 @@ module Of_json_string = struct let expand = expand_via ~what:(Expansion_helpers.Suffix "of_json_string") ~through:(Expansion_helpers.Suffix "of_json") (fun ~loc of_json -> - [%expr - fun _json -> - [%e of_json] (Ppx_deriving_json_runtime.of_string _json)]) + [%expr fun _json -> [%e of_json] (Json.of_string _json)]) let register ~of_json () = Deriving.add "of_json_string" @@ -134,9 +132,7 @@ module To_json_string = struct let expand = expand_via ~what:(Expansion_helpers.Suffix "to_json_string") ~through:(Expansion_helpers.Suffix "to_json") (fun ~loc to_json -> - [%expr - fun _data -> - Ppx_deriving_json_runtime.to_string ([%e to_json] _data)]) + [%expr fun _data -> Json.to_string ([%e to_json] _data)]) let register ~to_json () = Deriving.add "to_json_string" diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index e1b8c43..2e6d98d 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -7,6 +7,13 @@ open Ppx_deriving_tools.Conv open Ppx_deriving_json_common module Of_json = struct + let of_json_error ~loc fmt = + ksprintf + (fun msg -> + let msg = estring ~loc msg in + [%expr raise (Json.Of_json_error (Json_error [%e msg]))]) + fmt + let with_refs ~loc prefix fs inner = let gen_name n = sprintf "%s_%s" prefix n in let gen_expr (n : label loc) = @@ -45,10 +52,7 @@ module Of_json = struct [%pat? name] --> if allow_extra_fields then [%expr ()] - else - [%expr - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)] + else of_json_error ~loc "unknown field: %s" "name" in let cases = List.fold_left (List.rev fs) ~init:[ fail_case ] @@ -80,11 +84,7 @@ module Of_json = struct match default with | Some default -> default | None -> - [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc:key.loc - (sprintf "missing field %S" key.txt)]]]] + of_json_error ~loc "missing field: %S" key.txt]] )) in pexp_record ~loc fields None @@ -108,11 +108,7 @@ module Of_json = struct [ xpatt --> build_tuple ~loc derive xexprs t.tpl_types; [%pat? _] - --> [%expr - Ppx_deriving_json_runtime.of_json_error - [%e - estring ~loc - (sprintf "expected a JSON array of length %i" n)]]; + --> of_json_error ~loc "expected a JSON array of length %i" n; ] let derive_of_record derive t x = @@ -125,10 +121,7 @@ module Of_json = struct [%pat? `Assoc fs] --> build_record ~allow_extra_fields ~loc derive t.rcd_fields [%expr fs] Fun.id; - [%pat? _] - --> [%expr - Ppx_deriving_json_runtime.of_json_error - [%e estring ~loc (sprintf "expected a JSON object")]]; + [%pat? _] --> of_json_error ~loc "expected a JSON object"; ] let derive_of_variant_case derive make vcs = diff --git a/ppx/native/ppx_deriving_tools.ml b/ppx/native/ppx_deriving_tools.ml index 0649f46..2d56acc 100644 --- a/ppx/native/ppx_deriving_tools.ml +++ b/ppx/native/ppx_deriving_tools.ml @@ -436,9 +436,8 @@ module Conv = struct ~init: ( [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))], + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))], [] ) ~f:(fun (next, cases) (c, r) -> let ctx = Vcs_ctx_polyvariant c in @@ -466,9 +465,8 @@ module Conv = struct match [%e maybe_e] with | e -> (e :> [%t t]) | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - _) -> + Json.Of_json_error (Json.Unexpected_variant _) + -> [%e next]] in next, cases) @@ -511,9 +509,8 @@ module Conv = struct [%pat? _] --> [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))]; + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))]; ] ~f:(fun next (c : constructor_declaration) -> let ctx = Vcs_ctx_variant c in @@ -565,9 +562,8 @@ module Conv = struct ~init: [%expr raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))] + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))] ~f:(fun next (n, ts) -> let maybe = self#derive_type_ref ~loc self#name n ts x @@ -577,9 +573,7 @@ module Conv = struct match [%e maybe] with | x -> (x :> [%t t]) | exception - Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) - -> + Json.Of_json_error (Json.Unexpected_variant _) -> [%e next]]) in let cases = diff --git a/ppx/test/example.ml b/ppx/test/example.ml index 17687dd..1b5f441 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -23,7 +23,7 @@ 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 json = Json.t type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json let of_json_cases = [ C ({|1|}, user_of_json, user_to_json, 1); @@ -65,11 +65,11 @@ let of_json_cases = [ ] let run' (C (data, of_json, to_json, v)) = print_endline (Printf.sprintf "JSON DATA: %s" data); - let json = Ppx_deriving_json_runtime.of_string data in + let json = Json.of_string data in let v' = of_json json in assert (v' = v); let json' = to_json v' in - let data' = Ppx_deriving_json_runtime.to_string json' in + let data' = Json.to_string json' in print_endline (Printf.sprintf "JSON REPRINT: %s" data') let test () = List.iter run' of_json_cases diff --git a/ppx/test/example_json_string.ml b/ppx/test/example_json_string.ml index b2ac29e..840c716 100644 --- a/ppx/test/example_json_string.ml +++ b/ppx/test/example_json_string.ml @@ -1,4 +1,4 @@ -open Ppx_deriving_json_runtime.Primitives +open Json.Primitives let print fmt = Printf.ksprintf print_endline fmt diff --git a/ppx/test/poly.t b/ppx/test/poly.t index 7944a84..cff0717 100644 --- a/ppx/test/poly.t +++ b/ppx/test/poly.t @@ -2,8 +2,8 @@ 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) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -18,9 +18,10 @@ We can alias poly varaints: | `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) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -40,9 +41,8 @@ We can alias poly varaints: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -65,31 +65,38 @@ We can alias poly varaints: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (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"; + raise + (Json.Of_json_error + (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"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (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") + raise + (Json.Of_json_error + (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) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -111,9 +118,8 @@ We can alias poly varaints: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) === stdout:native === ["A"] === stdout:js === @@ -123,10 +129,10 @@ 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) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = print_endline (Json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === type t = [ `A | `B ][@@deriving json] @@ -141,9 +147,10 @@ We can extend aliased polyvariants: | `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) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -164,12 +171,11 @@ We can extend aliased polyvariants: | x -> (match of_json x with | x -> (x :> [ | t | `C ]) - | exception Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) : Yojson.Basic.t -> u) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : + Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -178,12 +184,10 @@ We can extend aliased polyvariants: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === ppx output:browser === type t = [ `A | `B ][@@deriving json] include @@ -206,31 +210,38 @@ We can extend aliased polyvariants: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (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"; + raise + (Json.Of_json_error + (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"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (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") + raise + (Json.Of_json_error + (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) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t + -> + t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -260,29 +271,36 @@ We can extend aliased polyvariants: 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 _) -> + | exception Json.Of_json_error (Json.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"; + raise + (Json.Of_json_error + (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"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (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") + raise + (Json.Of_json_error + (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) + raise + (Json.Of_json_error + (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 = @@ -293,12 +311,10 @@ We can extend aliased polyvariants: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] @@ -314,10 +330,10 @@ We can extend poly variants which are placed behind signatures: > 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) + > let () = print_endline (Json.to_string (u_to_json `A)) + > let () = print_endline (Json.to_string (u_to_json `C)) + > let () = assert (u_of_json (Json.of_string {|["B"]|}) = `B) + > let () = assert (u_of_json (Json.of_string {|["C"]|}) = `C) > ' | ./run.sh === ppx output:native === module P : @@ -343,9 +359,9 @@ We can extend poly variants which are placed behind signatures: | `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) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : + Yojson.Basic.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -368,12 +384,11 @@ We can extend poly variants which are placed behind signatures: | 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 _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) : Yojson.Basic.t -> u) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : + Yojson.Basic.t -> u) let _ = u_of_json [@@@ocaml.warning "-39-11-27"] let rec u_to_json = @@ -382,12 +397,10 @@ We can extend poly variants which are placed behind signatures: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === ppx output:browser === module P : sig @@ -421,31 +434,39 @@ We can extend poly variants which are placed behind signatures: then (if Stdlib.(<>) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (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"; + raise + (Json.Of_json_error + (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"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (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") + raise + (Json.Of_json_error + (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) + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : + Js.Json.t -> t) let _ = of_json [@@@ocaml.warning "-39-11-27"] let rec to_json = @@ -476,29 +497,36 @@ We can extend poly variants which are placed behind signatures: 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 _) -> + | exception Json.Of_json_error (Json.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"; + raise + (Json.Of_json_error + (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"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a string") + raise + (Json.Of_json_error + (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") + raise + (Json.Of_json_error + (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) + raise + (Json.Of_json_error + (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 = @@ -509,12 +537,10 @@ We can extend poly variants which are placed behind signatures: 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) + let () = print_endline (Json.to_string (u_to_json `A)) + let () = print_endline (Json.to_string (u_to_json `C)) + let () = assert ((u_of_json (Json.of_string {|["B"]|})) = `B) + let () = assert ((u_of_json (Json.of_string {|["C"]|})) = `C) === stdout:native === ["A"] ["C"] diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index dbf65be..c803faf 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -7,7 +7,7 @@ > (name lib) > (modes melange) > (modules example example_json_string main) - > (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + > (flags :standard -w -37-69 -open Json.Primitives) > (preprocess (pps melange.ppx melange-json.ppx))) > (melange.emit > (alias js) diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index e51689f..89c5807 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -135,8 +135,9 @@ ( int_of_json (Js.Array.unsafe_get es 0), string_of_json (Js.Array.unsafe_get es 1) ) else - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2" + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")) : Js.Json.t -> tuple) let _ = tuple_of_json @@ -175,7 +176,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < name : Js.Json.t Js.undefined @@ -187,14 +188,15 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); age = (match Js.Undefined.toOption fs##age with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"age\""); + raise + (Json.Of_json_error (Json_error "missing field: \"age\""))); } : Js.Json.t -> record) @@ -240,7 +242,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < my_name : Js.Json.t Js.undefined @@ -252,8 +254,9 @@ (match Js.Undefined.toOption fs##my_name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"my_name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"my_name\""))); age = (match Js.Undefined.toOption fs##my_age with | Stdlib.Option.Some v -> int_of_json v @@ -302,7 +305,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < k : Js.Json.t Js.undefined > Js.t) in { k = @@ -348,18 +351,21 @@ 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); B (int_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); let fs = Js.Array.unsafe_get array 1 in if Stdlib.not @@ -372,8 +378,9 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object"; + raise + (Json.Of_json_error + (Json_error "expected a JSON object")); let fs = (Obj.magic fs : < name : Js.Json.t Js.undefined > Js.t) in @@ -383,20 +390,25 @@ (match Js.Undefined.toOption fs##name with | Stdlib.Option.Some v -> string_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> sum) let _ = sum_of_json @@ -444,22 +456,27 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "S2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 3"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 3")); S2 ( int_of_json (Js.Array.unsafe_get array 1), string_of_json (Js.Array.unsafe_get array 2) )) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> sum2) let _ = sum2_of_json @@ -503,24 +520,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> other) let _ = other_of_json @@ -554,34 +575,38 @@ 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `B (int_of_json (Js.Array.unsafe_get array 1))) else 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 _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) + -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> poly) let _ = poly_of_json @@ -622,26 +647,30 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "P2" then ( if Stdlib.( <> ) len 3 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 3"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 3")); `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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> poly2) let _ = poly2_of_json @@ -685,24 +714,28 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "C" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `C (a_of_json (Js.Array.unsafe_get array 1))) else raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> 'a c) let _ = c_of_json @@ -741,25 +774,31 @@ 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); Fix (recur_of_json (Js.Array.unsafe_get array 1))) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> recur) let _ = recur_of_json @@ -800,29 +839,34 @@ 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); `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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); `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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> polyrecur) let _ = polyrecur_of_json @@ -863,25 +907,31 @@ 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"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); A) else if Stdlib.( = ) tag "b_aliased" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 1")); B) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> evar) let _ = evar_of_json @@ -921,29 +971,34 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A_aliased" then ( if Stdlib.( <> ) len 1 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 1"; + raise + (Json.Of_json_error + (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"; + raise + (Json.Of_json_error + (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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> epoly) let _ = epoly_of_json @@ -983,25 +1038,31 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); A (a_of_json (Js.Array.unsafe_get array 1))) else if Stdlib.( = ) tag "B" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); B (b_of_json (Js.Array.unsafe_get array 1))) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> ('a, 'b) p2) let _ = p2_of_json @@ -1044,15 +1105,15 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < a : Js.Json.t Js.undefined > Js.t) in { a = (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error (Json_error "missing field: \"a\""))); } : Js.Json.t -> allow_extra_fields) @@ -1092,8 +1153,9 @@ let tag = (Obj.magic tag : string) in if Stdlib.( = ) tag "A" then ( if Stdlib.( <> ) len 2 then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2"; + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")); let fs = Js.Array.unsafe_get array 1 in if Stdlib.not @@ -1106,8 +1168,9 @@ (Obj.magic fs : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object"; + raise + (Json.Of_json_error + (Json_error "expected a JSON object")); let fs = (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t) in @@ -1117,20 +1180,25 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); }) - else Ppx_deriving_json_runtime.of_json_error "invalid JSON" + else raise (Json.Of_json_error (Json_error "invalid JSON")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array with element being a \ - string" + raise + (Json.Of_json_error + (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" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) else - Ppx_deriving_json_runtime.of_json_error - "expected a non empty JSON array" + raise + (Json.Of_json_error + (Json_error "expected a non empty JSON array")) : Js.Json.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -1177,7 +1245,7 @@ (Stdlib.not (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) then - Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + raise (Json.Of_json_error (Json_error "expected a JSON object")); let fs = (Obj.magic x : < a : Js.Json.t Js.undefined @@ -1189,8 +1257,8 @@ (match Js.Undefined.toOption fs##a with | Stdlib.Option.Some v -> int_of_json v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error (Json_error "missing field: \"a\""))); b_opt = (match Js.Undefined.toOption fs##b_opt with | Stdlib.Option.Some v -> (option_of_json int_of_json) v diff --git a/ppx/test/ppx_deriving_json_js_variants.e2e.t b/ppx/test/ppx_deriving_json_js_variants.e2e.t index 27fa139..5a79ca4 100644 --- a/ppx/test/ppx_deriving_json_js_variants.e2e.t +++ b/ppx/test/ppx_deriving_json_js_variants.e2e.t @@ -21,6 +21,6 @@ > let json = sum_to_json A > ' >> main.ml -Can build without having to open Ppx_deriving_json_runtime.Primitives +Can build without having to open Json.Primitives $ dune build @js diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index d9cde85..2ab2253 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -5,7 +5,7 @@ $ echo ' > (executable > (name main) - > (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + > (flags :standard -w -37-69 -open Json.Primitives) > (preprocess (pps melange-json-native.ppx)))' > dune $ echo ' diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 45b991d..cab4326 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -128,8 +128,9 @@ match x with | `List [ x_0; x_1 ] -> int_of_json x_0, string_of_json x_1 | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON array of length 2" + raise + (Json.Of_json_error + (Json_error "expected a JSON array of length 2")) : Yojson.Basic.t -> tuple) let _ = tuple_of_json @@ -169,8 +170,9 @@ x_name := Stdlib.Option.Some (string_of_json v) | "age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -179,18 +181,20 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"age\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"age\""))); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record) let _ = record_of_json @@ -241,8 +245,9 @@ x_name := Stdlib.Option.Some (string_of_json v) | "my_age" -> x_age := Stdlib.Option.Some (int_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -251,16 +256,17 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"my_name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"my_name\""))); age = (match Stdlib.( ! ) x_age with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> 100); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record_aliased) let _ = record_aliased_of_json @@ -308,8 +314,9 @@ x_k := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -320,8 +327,8 @@ | Stdlib.Option.None -> Stdlib.Option.None); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> record_opt) let _ = record_opt_of_json @@ -367,8 +374,9 @@ | "name" -> x_name := Stdlib.Option.Some (string_of_json v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -378,14 +386,14 @@ (match Stdlib.( ! ) x_name with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"name\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"name\""))); } | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> sum) let _ = sum_of_json @@ -430,9 +438,8 @@ S2 (int_of_json x_0, string_of_json x_1) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> sum2) let _ = sum2_of_json @@ -465,9 +472,8 @@ | `List (`String "C" :: []) -> `C | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> other) let _ = other_of_json @@ -496,13 +502,10 @@ | x -> ( 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 _) -> + | exception Json.Of_json_error (Json.Unexpected_variant _) -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant"))) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant"))) : Yojson.Basic.t -> poly) let _ = poly_of_json @@ -537,9 +540,8 @@ `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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> poly2) let _ = poly2_of_json @@ -572,9 +574,8 @@ | `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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> 'a c) let _ = c_of_json @@ -606,9 +607,8 @@ | `List [ `String "Fix"; x_0 ] -> Fix (recur_of_json x_0) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> recur) let _ = recur_of_json @@ -642,9 +642,8 @@ | `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")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> polyrecur) let _ = polyrecur_of_json @@ -678,9 +677,8 @@ | `List (`String "b_aliased" :: []) -> B | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> evar) let _ = evar_of_json @@ -714,9 +712,8 @@ | `List (`String "b" :: []) -> `b | x -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> epoly) let _ = epoly_of_json @@ -750,9 +747,8 @@ | `List [ `String "B"; x_0 ] -> B (b_of_json x_0) | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> ('a, 'b) p2) let _ = p2_of_json @@ -799,12 +795,13 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> allow_extra_fields) let _ = allow_extra_fields_of_json @@ -855,14 +852,14 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); } | _ -> raise - (Ppx_deriving_json_runtime.Of_json_error - (Ppx_deriving_json_runtime.Unexpected_variant - "unexpected variant")) + (Json.Of_json_error + (Json.Unexpected_variant "unexpected variant")) : Yojson.Basic.t -> allow_extra_fields2) let _ = allow_extra_fields2_of_json @@ -915,8 +912,9 @@ x_b_opt := Stdlib.Option.Some ((option_of_json int_of_json) v) | name -> - Ppx_deriving_json_runtime.of_json_error - (Stdlib.Printf.sprintf "unknown field: %s" name)); + raise + (Json.Of_json_error + (Json_error "unknown field: name"))); iter fs in iter fs; @@ -925,16 +923,17 @@ (match Stdlib.( ! ) x_a with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> - Ppx_deriving_json_runtime.of_json_error - "missing field \"a\""); + raise + (Json.Of_json_error + (Json_error "missing field: \"a\""))); b_opt = (match Stdlib.( ! ) x_b_opt with | Stdlib.Option.Some v -> v | Stdlib.Option.None -> Stdlib.Option.None); } | _ -> - Ppx_deriving_json_runtime.of_json_error - "expected a JSON object" + raise + (Json.Of_json_error (Json_error "expected a JSON object")) : Yojson.Basic.t -> drop_default_option) let _ = drop_default_option_of_json diff --git a/ppx/test/run.sh b/ppx/test/run.sh index ea376fa..8bb4ab2 100755 --- a/ppx/test/run.sh +++ b/ppx/test/run.sh @@ -13,7 +13,7 @@ echo ' (name lib) (modes melange) (modules main_js) - (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (flags :standard -w -37-69 -open Json.Primitives) (preprocess (pps melange.ppx melange-json.ppx))) (melange.emit (alias js) @@ -24,7 +24,7 @@ echo ' (executable (name main) (modules main) - (flags :standard -w -37-69 -open Ppx_deriving_json_runtime.Primitives) + (flags :standard -w -37-69 -open Json.Primitives) (preprocess (pps melange-json-native.ppx))) ' > dune diff --git a/src/Json.ml b/src/Json.ml index b156a86..97e2822 100644 --- a/src/Json.ml +++ b/src/Json.ml @@ -445,3 +445,30 @@ let parseOrRaise s = raise @@ ParseError message external stringify : Js.Json.t -> string = "JSON.stringify" + +let classify : + t -> + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] = + fun json -> + if (Obj.magic json : 'a Js.null) == Js.null then `Null + else + match Js.typeof json with + | "string" -> `String (Obj.magic json : string) + | "number" -> + let v = (Obj.magic json : float) in + if Of_json.is_int v then `Int (Obj.magic v : int) else `Float v + | "boolean" -> `Bool (Obj.magic json : bool) + | "object" -> + if Js.Array.isArray json then + let xs = Array.to_list (Obj.magic json : t array) in + `List xs + else + let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in + `Assoc (Array.to_list xs) + | typ -> failwith ("unknown JSON value type: " ^ typ) diff --git a/src/Json.mli b/src/Json.mli index a0c013b..c0fa7ea 100644 --- a/src/Json.mli +++ b/src/Json.mli @@ -412,3 +412,14 @@ type exn += ParseError of string val parse : string -> json option [@@deprecated "Use `of_string` instead"] val parseOrRaise : string -> json [@@deprecated "Use `of_string` instead"] val stringify : json -> string [@@deprecated "Use `to_string` instead"] + +val classify : + json -> + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] +(** Classify a JSON value into a variant type. *) diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/src/native/Json.ml similarity index 51% rename from ppx/native/ppx_deriving_json_runtime.ml rename to src/native/Json.ml index 1d3b146..46ed65b 100644 --- a/ppx/native/ppx_deriving_json_runtime.ml +++ b/src/native/Json.ml @@ -1,7 +1,9 @@ type t = Yojson.Basic.t +(** The type of a JSON data structure *) + +type json = t +(** Defined for convenience. *) -let to_json t = t -let of_json t = t let to_string t = Yojson.Basic.to_string t exception Of_string_error of string @@ -10,6 +12,11 @@ let of_string s = try Yojson.Basic.from_string s with Yojson.Json_error msg -> raise (Of_string_error msg) +type 'a to_json = 'a -> json +(** Describe how to encode a value into JSON. *) + +let to_json : json to_json = fun x -> x + type error = Json_error of string | Unexpected_variant of string exception Of_json_error of error @@ -28,27 +35,10 @@ let show_json_type = function let of_json_error_type_mismatch json expected = of_json_error ("Expected " ^ expected ^ ", got " ^ show_json_type json) -module To_json = struct - let string_to_json v = `String v - let bool_to_json v = `Bool v - let int_to_json v = `Int v - let int64_to_json v = `String (Int64.to_string v) - let float_to_json v = `Float v - let unit_to_json () = `Null - let list_to_json v_to_json vs = `List (List.map v_to_json vs) - - let array_to_json v_to_json vs = - `List (Array.to_list (Array.map v_to_json vs)) - - let option_to_json v_to_json = function - | None -> `Null - | Some v -> v_to_json v - - let result_to_json a_to_json b_to_json v = - match v with - | Ok x -> `List [ `String "Ok"; a_to_json x ] - | Error x -> `List [ `String "Error"; b_to_json x ] -end +type 'a of_json = json -> 'a +(** Describe how to decode a value from JSON. *) + +let of_json : 'a of_json = fun x -> x module Of_json = struct let typeof = function @@ -60,67 +50,98 @@ module Of_json = struct | `Null -> "null" | `String _ -> "string" - let string_of_json = function + let string = function | `String s -> s | json -> of_json_error_type_mismatch json "string" - let bool_of_json = function + let bool = function | `Bool b -> b | json -> of_json_error_type_mismatch json "bool" - let int_of_json = function + let int = function | `Int i -> i | json -> of_json_error_type_mismatch json "int" - let int64_of_json = function + let int64 = function | `String i as json -> ( match Int64.of_string_opt i with | Some v -> v | None -> of_json_error_type_mismatch json "int64 as string") | json -> of_json_error_type_mismatch json "int64 as string" - let float_of_json = function + let float = function | `Float f -> f | `Int i -> float_of_int i | json -> of_json_error_type_mismatch json "float" - let unit_of_json = function - | `Null -> () - | _ -> of_json_error "expected null" + let unit = function `Null -> () | _ -> of_json_error "expected null" - let option_of_json v_of_json = function + let option v_of_json = function | `Null -> None | json -> Some (v_of_json json) - let list_of_json v_of_json = function + let list v_of_json = function | `List l -> List.map v_of_json l | json -> of_json_error_type_mismatch json "array" - let array_of_json v_of_json = function + let array v_of_json = function | `List l -> Array.map v_of_json (Array.of_list l) | json -> of_json_error_type_mismatch json "array" - let result_of_json ok_of_json err_of_json json = + let result ok_of_json err_of_json json = match json with | `List [ `String "Ok"; x ] -> Ok (ok_of_json x) | `List [ `String "Error"; x ] -> Error (err_of_json x) | _ -> of_json_error "invalid JSON" end -module Primitives = struct - include To_json - include Of_json +module To_json = struct + let string v = `String v + let bool v = `Bool v + let int v = `Int v + let int64 v = `String (Int64.to_string v) + let float v = `Float v + let unit () = `Null + let list v_to_json vs = `List (List.map v_to_json vs) + let array v_to_json vs = `List (Array.to_list (Array.map v_to_json vs)) + let option v_to_json = function None -> `Null | Some v -> v_to_json v + + let result a_to_json b_to_json v = + match v with + | Ok x -> `List [ `String "Ok"; a_to_json x ] + | Error x -> `List [ `String "Error"; b_to_json x ] end -module Classify = struct - let classify : - t -> - [ `Null - | `String of string - | `Float of float - | `Int of int - | `Bool of bool - | `List of t list - | `Assoc of (string * t) list ] = - fun x -> x +module Primitives = struct + let string_of_json = Of_json.string + let bool_of_json = Of_json.bool + let float_of_json = Of_json.float + let int_of_json = Of_json.int + let int64_of_json = Of_json.int64 + let option_of_json = Of_json.option + let unit_of_json = Of_json.unit + let result_of_json = Of_json.result + let list_of_json = Of_json.list + let array_of_json = Of_json.array + let string_to_json = To_json.string + let bool_to_json = To_json.bool + let float_to_json = To_json.float + let int_to_json = To_json.int + let int64_to_json = To_json.int64 + let option_to_json = To_json.option + let unit_to_json = To_json.unit + let result_to_json = To_json.result + let list_to_json = To_json.list + let array_to_json = To_json.array end + +let classify : + t -> + [ `Null + | `String of string + | `Float of float + | `Int of int + | `Bool of bool + | `List of t list + | `Assoc of (string * t) list ] = + fun x -> x diff --git a/src/native/dune b/src/native/dune new file mode 100644 index 0000000..25b63a5 --- /dev/null +++ b/src/native/dune @@ -0,0 +1,4 @@ +(library + (name json) + (public_name melange-json-native) + (libraries yojson))